GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-04-09 04:59:31 -06:00
Code Issues Packages Projects Releases Wiki Activity

when in server mode reuse the NGF cache in the shell as well

Browse Source
This commit is contained in:
Krasimir Angelov
2022-06-23 10:25:16 +02:00
parent 7544e8dfbc
commit 44431d6a69
9 changed files with 129 additions and 150 deletions
Download Patch File Download Diff File Expand all files Collapse all files

10
src/compiler/GF/Command/Importing.hs
View File

@@ -23,8 +23,8 @@ import Control.Monad(foldM)
import Control.Exception(catch,throwIO)
-- import a grammar in an environment where it extends an existing grammar
importGrammar :: Maybe PGF -> Options -> [FilePath] -> IO (Maybe PGF)
importGrammar pgf0 opts _
importGrammar :: (FilePath -> IO PGF) -> Maybe PGF -> Options -> [FilePath] -> IO (Maybe PGF)
importGrammar readNGF pgf0 opts _
| Just name <- flag optBlank opts = do
mb_ngf_file <- if snd (flag optLinkTargets opts)
then do let fname = name <.> ".ngf"
@@ -33,14 +33,14 @@ importGrammar pgf0 opts _
else do return Nothing
pgf <- newNGF name mb_ngf_file
return (Just pgf)
importGrammar pgf0 _ [] = return pgf0
importGrammar pgf0 opts fs
importGrammar readNGF pgf0 _ [] = return pgf0
importGrammar readNGF pgf0 opts fs
| all (extensionIs ".cf") fs = fmap Just $ importCF opts fs getBNFCRules bnfc2cf
| all (extensionIs ".ebnf") fs = fmap Just $ importCF opts fs getEBNFRules ebnf2cf
| all (extensionIs ".gfm") fs = do
ascss <- mapM readMulti fs
let cs = concatMap snd ascss
importGrammar pgf0 opts cs
importGrammar readNGF pgf0 opts cs
| all (\f -> extensionIs ".gf" f || extensionIs ".gfo" f) fs = do
res <- tryIOE $ compileToPGF opts pgf0 fs
case res of

2
src/compiler/GF/Infra/SIO.hs
View File

@@ -131,7 +131,7 @@ getLibraryDirectory = lift0 . IO.getLibraryDirectory
newStdGen = lift0 IO.newStdGen
runInterruptibly = lift1 IO.runInterruptibly
importGrammar pgf opts files = lift0 $ GF.importGrammar pgf opts files
importGrammar readNGF pgf opts files = lift0 $ GF.importGrammar readNGF pgf opts files
importSource opts files = lift0 $ GF.importSource opts files
link opts pgf src = lift0 $ GF.link opts pgf src

82
src/compiler/GF/Interactive.hs
View File

@@ -36,10 +36,12 @@ import System.Directory(getAppUserDataDirectory)
import Control.Exception(SomeException,fromException,evaluate,try)
import Control.Monad.State hiding (void)
import qualified GF.System.Signal as IO(runInterruptibly)
import GF.Command.Messages(welcome)
#ifdef SERVER_MODE
import GF.Server(server)
#endif
import GF.Command.Messages(welcome)
type ReadNGF = FilePath -> IO PGF
-- | Run the GF Shell in quiet mode (@gf -run@).
mainRunGFI :: Options -> [FilePath] -> IO ()
@@ -53,39 +55,36 @@ mainGFI opts files = do
P.putStrLn welcome
shell opts files
shell opts files = flip evalStateT (emptyGFEnv opts) $
do mapStateT runSIO $ importInEnv opts files
modify $ \ gfenv0 -> gfenv0 {history = [unwords ("i":files)]}
loop
shell opts files =
flip evalStateT (emptyGFEnv opts) $
do mapStateT runSIO $ importInEnv readNGF opts files
modify $ \ gfenv0 -> gfenv0 {history = [unwords ("i":files)]}
repeatM (mapStateT runSIO . execute1 readNGF =<< readCommand)
#ifdef SERVER_MODE
-- | Run the GF Server (@gf -server@).
-- The 'Int' argument is the port number for the HTTP service.
mainServerGFI opts0 port files =
server jobs port root execute1' . snd
=<< runSIO (runStateT (importInEnv opts files) (emptyGFEnv opts))
server jobs port root init execute
where
root = flag optDocumentRoot opts
opts = beQuiet opts0
jobs = join (flag optJobs opts)
execute1' gfenv0 cmd =
do (continue,gfenv) <- runStateT (execute1 cmd) gfenv0
return $ if continue then Just gfenv else Nothing
init readNGF = do
(_, gfenv) <- runSIO (runStateT (importInEnv readNGF opts files) (emptyGFEnv opts))
return gfenv
execute readNGF gfenv0 cmd = do
(continue,gfenv) <- runStateT (execute1 readNGF cmd) gfenv0
return $ if continue then Just gfenv else Nothing
#else
mainServerGFI opts port files =
mainServerGFI readNGF opts port files =
fail "GF has not been compiled with server mode support"
#endif
-- | Read end execute commands until it is time to quit
loop :: StateT GFEnv IO ()
loop = repeatM readAndExecute1
-- | Read and execute one command, returning 'True' to continue execution,
-- | 'False' when it is time to quit
readAndExecute1 :: StateT GFEnv IO Bool
readAndExecute1 = mapStateT runSIO . execute1 =<< readCommand
-- | Read a command
readCommand :: StateT GFEnv IO String
readCommand =
@@ -113,13 +112,13 @@ type ShellM = StateT GFEnv SIO
-- | Execute a given command line, returning 'True' to continue execution,
-- | 'False' when it is time to quit
execute1, execute1' :: String -> ShellM Bool
execute1 s0 =
execute1, execute1' :: ReadNGF -> String -> ShellM Bool
execute1 readNGF s0 =
do modify $ \ gfenv0 -> gfenv0 {history = s0 : history gfenv0}
execute1' s0
execute1' readNGF s0
-- | Execute a given command line, without adding it to the history
execute1' s0 =
execute1' readNGF s0 =
do opts <- gets startOpts
interruptible $ optionallyShowCPUTime opts $
case pwords s0 of
@@ -128,7 +127,16 @@ execute1' s0 =
"q" :_ -> quit
"!" :ws -> system_command ws
"eh":ws -> execute_history ws
"i" :ws -> do import_ ws; continue
"i" :ws -> do import_ readNGF ws; continue
"r" :_ -> do gfenv0 <- get
let imports = [(s,ws) | s <- history gfenv0, ("i":ws) <- [pwords s]]
case imports of
(s,ws):_ -> do
putStrLnE $ "repeating latest import: " ++ s
import_ readNGF ws
continue
_ -> do putStrLnE $ "no import in history"
continue
(w :ws) | w == "c" || w == "d" -> do
case readTransactionCommand s0 of
Just cmd -> do checkout
@@ -178,7 +186,7 @@ execute1' s0 =
continue
where
execute [] = return ()
execute (line:lines) = whenM (execute1' line) (execute lines)
execute (line:lines) = whenM (execute1' readNGF line) (execute lines)
execute_history _ =
do putStrLnE "eh command not parsed"
@@ -219,13 +227,13 @@ pwords s = case words s of
w:ws -> getCommandOp w :ws
ws -> ws
import_ args =
import_ readNGF args =
do case parseOptions args of
Ok (opts',files) -> do
opts <- gets startOpts
curr_dir <- lift getCurrentDirectory
lib_dir <- lift $ getLibraryDirectory (addOptions opts opts')
importInEnv (addOptions opts (fixRelativeLibPaths curr_dir lib_dir opts')) files
importInEnv readNGF (addOptions opts (fixRelativeLibPaths curr_dir lib_dir opts')) files
Bad err -> putStrLnE $ "Command parse error: " ++ err
transactionCommand :: TransactionCommand -> PGF -> ShellM ()
@@ -353,17 +361,7 @@ moreCommands = [
}),
("r", emptyCommandInfo {
longname = "reload",
synopsis = "repeat the latest import command",
exec = \ _ _ ->
do gfenv0 <- get
let imports = [(s,ws) | s <- history gfenv0, ("i":ws) <- [pwords s]]
case imports of
(s,ws):_ -> do
putStrLnE $ "repeating latest import: " ++ s
import_ ws
return void
_ -> do putStrLnE $ "no import in history"
return void
synopsis = "repeat the latest import command"
})
]
@@ -385,8 +383,8 @@ fetchCommand gfenv = do
Right Nothing -> return "q"
Right (Just s) -> return s
importInEnv :: Options -> [FilePath] -> ShellM ()
importInEnv opts files =
importInEnv :: ReadNGF -> Options -> [FilePath] -> ShellM ()
importInEnv readNGF opts files =
do pgf0 <- gets multigrammar
case flag optRetainResource opts of
RetainAll -> do src <- lift $ importSource opts files
@@ -399,7 +397,7 @@ importInEnv opts files =
where
importPGF pgf0 =
do let opts' = addOptions (setOptimization OptCSE False) opts
pgf1 <- importGrammar pgf0 opts' files
pgf1 <- importGrammar readNGF pgf0 opts' files
if (verbAtLeast opts Normal)
then case pgf1 of
Just pgf -> putStrLnFlush $ unwords $ "\nLanguages:" : Map.keys (languages pgf)

1
src/compiler/GF/Main.hs
View File

@@ -14,7 +14,6 @@ import System.Directory
import System.Environment (getArgs)
import System.Exit
import GHC.IO.Encoding
-- import GF.System.Console (setConsoleEncoding)
-- | Run the GF main program, taking arguments from the command line.
-- (It calls 'setConsoleEncoding' and 'getOptions', then 'mainOpts'.)

64
src/compiler/GF/Server.hs
View File

@@ -1,13 +1,13 @@
-- | GF server mode
{-# LANGUAGE CPP #-}
module GF.Server(server) where
import Data.List(partition,stripPrefix,isInfixOf)
import qualified Data.Map as M
import Control.Monad(when)
import Control.Monad.State(StateT(..),get,gets,put)
import Control.Monad.Except(ExceptT(..),runExceptT)
import System.Random(randomRIO)
--import System.IO(stderr,hPutStrLn)
import GF.System.Catch(try)
import Control.Exception(bracket_)
import System.IO.Error(isAlreadyExistsError)
@@ -30,11 +30,9 @@ import System.Posix.Files(getSymbolicLinkStatus,isSymbolicLink,removeLink,
import GF.Infra.Concurrency(newMVar,modifyMVar,newLog)
import Network.URI(URI(..))
import Network.Shed.Httpd(initServer,Request(..),Response(..),noCache)
--import qualified Network.FastCGI as FCGI -- from hackage direct-fastcgi
import Network.CGI(handleErrors,liftIO)
import CGIUtils(handleCGIErrors)
import Text.JSON(encode,showJSON,makeObj)
--import System.IO.Silently(hCapture)
import System.Process(readProcessWithExitCode)
import System.Exit(ExitCode(..))
import Codec.Binary.UTF8.String(decodeString,encodeString)
@@ -49,61 +47,30 @@ import GF.Server.SimpleEditor.Convert(parseModule)
import GF.Server.RunHTTP(cgiHandler)
import URLEncoding(decodeQuery)
--logFile :: FilePath
--logFile = "pgf-error.log"
debug s = logPutStrLn s
-- | Combined FastCGI and HTTP server
server jobs port optroot execute1 state0 =
do --stderrToFile logFile
state <- newMVar M.empty
cache <- PS.newPGFCache jobs
datadir <- getDataDir
let root = maybe (datadir</>"www") id optroot
-- debug $ "document root="++root
setDir root
-- FCGI.acceptLoop forkIO (handle_fcgi execute1 state0 state cache)
-- if acceptLoop returns, then GF was not invoked as a FastCGI script
http_server execute1 state0 state cache root
server jobs port optroot init execute1 = do
state <- newMVar M.empty
datadir <- getDataDir
let root = maybe (datadir</>"www") id optroot
cache <- PS.newPGFCache root jobs
setDir root
let readNGF = PS.readCachedNGF cache
state0 <- init readNGF
http_server (execute1 readNGF) state0 state cache root
where
-- | HTTP server
http_server execute1 state0 state cache root =
http_server execute state0 state cache root =
do logLn <- newLog ePutStrLn -- to avoid intertwined log messages
logLn gf_version
logLn $ "Document root = "++root
logLn $ "Starting HTTP server, open http://localhost:"
++show port++"/ in your web browser."
initServer port (handle logLn root state0 cache execute1 state)
initServer port (handle logLn root state0 cache execute state)
gf_version = "This is GF version "++showVersion version++".\n"++buildInfo
{-
-- | FastCGI request handler
handle_fcgi execute1 state0 stateM cache =
do Just method <- FCGI.getRequestMethod
debug $ "request method="++method
Just path <- FCGI.getPathInfo
-- debug $ "path info="++path
query <- maybe (return "") return =<< FCGI.getQueryString
-- debug $ "query string="++query
let uri = URI "" Nothing path query ""
headers <- fmap (mapFst show) FCGI.getAllRequestHeaders
body <- fmap BS.unpack FCGI.fGetContents
let req = Request method uri headers body
-- debug (show req)
(output,resp) <- liftIO $ hCapture [stdout] $ modifyMVar stateM $ handle state0 cache execute1 req
let Response code headers body = resp
-- debug output
debug $ " "++show code++" "++show headers
FCGI.setResponseStatus code
mapM_ (uncurry (FCGI.setResponseHeader . toHeader)) headers
let pbody = BS.pack body
n = BS.length pbody
FCGI.fPut pbody
debug $ "done "++show n
-}
-- * Request handler
-- | Handler monad
type HM s a = StateT (Q,s) (ExceptT Response IO) a
@@ -132,7 +99,7 @@ hmbracket_ pre post m =
Right (a,s) -> do put s;return a
-- | HTTP request handler
handle logLn documentroot state0 cache execute1 stateVar
handle logLn documentroot state0 cache execute stateVar
rq@(Request method URI{uriPath=upath,uriQuery=q} hdrs body) =
addDate $
case method of
@@ -141,7 +108,6 @@ handle logLn documentroot state0 cache execute1 stateVar
_ -> return (resp501 $ "method "++method)
where
logPutStrLn msg = liftIO $ logLn msg
-- debug msg = logPutStrLn msg
addDate m =
do t <- getCurrentTime
@@ -157,8 +123,6 @@ handle logLn documentroot state0 cache execute1 stateVar
"/new" -> stateful $ new
"/gfshell" -> stateful $ inDir command
"/cloud" -> stateful $ inDir cloud
-- "/stop" ->
-- "/start" ->
"/parse" -> parse (decoded qs)
"/version" -> versionInfo `fmap` PS.listPGFCache cache
"/flush" -> do PS.flushPGFCache cache; return (ok200 "flushed")
@@ -229,7 +193,7 @@ handle logLn documentroot state0 cache execute1 stateVar
do cmd <- look "command"
state <- get_state
let st = maybe state0 id $ M.lookup dir state
(output,st') <- liftIO $ captureSIO $ execute1 st cmd
(output,st') <- liftIO $ captureSIO $ execute st cmd
let state' = maybe state (flip (M.insert dir) state) st'
put_state state'
return $ ok200 output

52
src/server/Cache.hs
View File

@@ -6,12 +6,14 @@ import Data.Map (Map)
import qualified Data.Map as Map
import Data.Foldable as T(mapM_)
import Data.Maybe(mapMaybe)
import System.Directory (getModificationTime)
import System.Directory (getModificationTime, canonicalizePath)
import System.FilePath (makeRelative)
import System.Mem(performGC)
import Data.Time (UTCTime,getCurrentTime,diffUTCTime)
--import Data.Time.Compat (toUTCTime)
data Cache a = Cache {
cacheRoot :: FilePath,
cacheLoad :: Maybe a -> FilePath -> IO a,
cacheObjects :: MVar (Map FilePath (MVar (Maybe (FileInfo a))))
}
@@ -19,10 +21,13 @@ data Cache a = Cache {
type FileInfo a = (UTCTime,UTCTime,a) -- modification time, access time, contents
-- | Create a new cache that uses the given function to read and parse files
newCache :: (Maybe a -> FilePath -> IO a) -> IO (Cache a)
newCache load =
do objs <- newMVar Map.empty
return $ Cache { cacheLoad = load, cacheObjects = objs }
newCache :: FilePath -> (Maybe a -> FilePath -> IO a) -> IO (Cache a)
newCache root load = do
objs <- newMVar Map.empty
return (Cache { cacheRoot = root
, cacheLoad = load
, cacheObjects = objs
})
-- | Forget all cached objects
flushCache :: Cache a -> IO ()
@@ -40,11 +45,10 @@ expireCache age c =
-- | List currently cached files
listCache :: Cache a -> IO [(FilePath,UTCTime)]
listCache c =
fmap (mapMaybe id) . mapM check . Map.toList =<< readMVar (cacheObjects c)
fmap (mapMaybe id) . mapM check . Map.toList =<< readMVar (cacheObjects c)
where
check (path,v) = maybe Nothing (Just . (,) path . fst3) `fmap` readMVar v
fst3 (x,y,z) = x
fst3 (x,y,z) = x
-- | Lookup a cached object (or read the file if it is not in the cache or if
-- it has been modified)
@@ -53,20 +57,24 @@ readCache c file = snd `fmap` readCache' c file
-- | Like 'readCache', but also return the last modification time of the file
readCache' :: Cache a -> FilePath -> IO (UTCTime,a)
readCache' c file =
do v <- modifyMVar (cacheObjects c) findEntry
modifyMVar v readObject
readCache' c file = do
file <- canonicalizePath file
v <- modifyMVar (cacheObjects c)
(findEntry (makeRelative (cacheRoot c) file))
modifyMVar v (readObject file)
where
-- Find the cache entry, inserting a new one if neccessary.
findEntry objs = case Map.lookup file objs of
Just v -> return (objs,v)
Nothing -> do v <- newMVar Nothing
return (Map.insert file v objs, v)
findEntry file objs = case Map.lookup file objs of
Just v -> return (objs,v)
Nothing -> do v <- newMVar Nothing
return (Map.insert file v objs, v)
-- Check time stamp, and reload if different than the cache entry
readObject m = do t' <- {-toUTCTime `fmap`-} getModificationTime file
now <- getCurrentTime
x' <- case m of
Just (t,_,x) | t' == t -> return x
| otherwise -> cacheLoad c (Just x) file
_ -> cacheLoad c Nothing file
return (Just (t',now,x'), (t',x'))
readObject file m = do
t' <- getModificationTime file
now <- getCurrentTime
x' <- case m of
Just (t,_,x) | t' == t -> return x
| otherwise -> cacheLoad c (Just x) file
_ -> cacheLoad c Nothing file
return (Just (t',now,x'), (t',x'))

61
src/server/PGFService.hs
View File

@@ -1,7 +1,8 @@
{-# LANGUAGE CPP #-}
module PGFService(cgiMain,cgiMain',getPath,
logFile,stderrToFile,
Caches,pgfCache,newPGFCache,flushPGFCache,listPGFCache) where
Caches,newPGFCache,readCachedPGF,readCachedNGF,
flushPGFCache,listPGFCache) where
import PGF2
import PGF2.Transactions
@@ -44,28 +45,33 @@ logFile = "pgf-error.log"
data Caches = Caches { qsem :: QSem,
pgfCache :: Cache PGF,
ngfCache :: Cache PGF,
labelsCache :: Cache Labels }
newPGFCache jobs = do let n = maybe 4 id jobs
qsem <- newQSem n
pgfCache <- newCache' readGrammar
lblCache <- newCache' (const (fmap getDepLabels . readFile))
return $ Caches qsem pgfCache lblCache
newPGFCache root jobs = do
let n = maybe 4 id jobs
qsem <- newQSem n
pgfCache <- newCache' root (const readPGF)
ngfCache <- newCache' root (maybe readNGF (const . checkoutPGF))
lblCache <- newCache' root (const (fmap getDepLabels . readFile))
return $ Caches qsem pgfCache ngfCache lblCache
readCachedPGF :: Caches -> FilePath -> IO PGF
readCachedPGF = readCache . pgfCache
readCachedNGF :: Caches -> FilePath -> IO PGF
readCachedNGF = readCache . ngfCache
flushPGFCache c = do flushCache (pgfCache c)
flushCache (ngfCache c)
flushCache (labelsCache c)
listPGFCache c = listCache (pgfCache c)
readGrammar mb_pgf path =
case takeExtension path of
".pgf" -> readPGF path
".ngf" -> case mb_pgf of
Nothing -> readNGF path
Just gr -> checkoutPGF gr
_ -> error "Extension must be .pgf or .ngf"
listPGFCache c = liftM2 (++) (listCache (pgfCache c)) (listCache (ngfCache c))
newCache' rd = do c <- newCache rd
forkIO $ forever $ clean c
return c
newCache' root rd = do
c <- newCache root rd
forkIO $ forever $ clean c
return c
where
clean c = do threadDelay 2000000000 -- 2000 seconds, i.e. ~33 minutes
expireCache (24*60*60) c -- 24 hours
@@ -86,15 +92,20 @@ cgiMain' cache path =
(getInput "command")
case command of
"download" -> outputBinary =<< getFile BS.readFile path
_ -> do tpgf <- getFile (readCache' (pgfCache cache)) path
_ -> do let get = case takeExtension path of
".pgf" -> pgfCache
".ngf" -> ngfCache
_ -> error "Extension must be .pgf or .ngf"
tpgf <- getFile (readCache' (get cache)) path
pgfMain (qsem cache) command tpgf
getFile get path =
either failed return =<< liftIO (E.try (get path))
where
failed e = if isDoesNotExistError e
then notFound path
else liftIO $ ioError e
where
getFile get path =
either failed return =<< liftIO (E.try (get path))
where
failed e =
if isDoesNotExistError e
then notFound path
else liftIO $ ioError e
pgfMain qsem command (t,pgf) =

3
src/server/pgf-fcgi.hs
View File

@@ -5,8 +5,7 @@ import Network.FastCGI
import PGFService(cgiMain,newPGFCache,stderrToFile,logFile)
main = do stderrToFile logFile
fcgiMain =<< newPGFCache Nothing
fcgiMain =<< newPGFCache "" Nothing
fcgiMain cache =
#ifndef mingw32_HOST_OS

4
src/server/pgf-service.cabal
View File

@@ -15,8 +15,8 @@ flag network-uri
default: True
Library
exposed-modules: PGFService URLEncoding CGIUtils Cache
exposed-modules: PGFService URLEncoding CGIUtils
other-modules: Cache
build-depends: base >=4.2 && <5,
time,
directory,