From 44431d6a69e5e6df98e9115c635e316158908144 Mon Sep 17 00:00:00 2001 From: Krasimir Angelov Date: Thu, 23 Jun 2022 10:25:16 +0200 Subject: [PATCH] when in server mode reuse the NGF cache in the shell as well --- src/compiler/GF/Command/Importing.hs | 10 ++-- src/compiler/GF/Infra/SIO.hs | 2 +- src/compiler/GF/Interactive.hs | 82 ++++++++++++++-------------- src/compiler/GF/Main.hs | 1 - src/compiler/GF/Server.hs | 64 +++++----------------- src/server/Cache.hs | 52 ++++++++++-------- src/server/PGFService.hs | 61 ++++++++++++--------- src/server/pgf-fcgi.hs | 3 +- src/server/pgf-service.cabal | 4 +- 9 files changed, 129 insertions(+), 150 deletions(-) diff --git a/src/compiler/GF/Command/Importing.hs b/src/compiler/GF/Command/Importing.hs index d8e498c96..ba8d51a6a 100644 --- a/src/compiler/GF/Command/Importing.hs +++ b/src/compiler/GF/Command/Importing.hs @@ -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 diff --git a/src/compiler/GF/Infra/SIO.hs b/src/compiler/GF/Infra/SIO.hs index 27b4926c3..ad5a27e2a 100644 --- a/src/compiler/GF/Infra/SIO.hs +++ b/src/compiler/GF/Infra/SIO.hs @@ -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 diff --git a/src/compiler/GF/Interactive.hs b/src/compiler/GF/Interactive.hs index 19a21d028..17445d1c3 100644 --- a/src/compiler/GF/Interactive.hs +++ b/src/compiler/GF/Interactive.hs @@ -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) diff --git a/src/compiler/GF/Main.hs b/src/compiler/GF/Main.hs index 4eba71d3e..85328712a 100644 --- a/src/compiler/GF/Main.hs +++ b/src/compiler/GF/Main.hs @@ -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'.) diff --git a/src/compiler/GF/Server.hs b/src/compiler/GF/Server.hs index cd1dde57a..31c817899 100644 --- a/src/compiler/GF/Server.hs +++ b/src/compiler/GF/Server.hs @@ -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 diff --git a/src/server/Cache.hs b/src/server/Cache.hs index 85c84df36..588dd4470 100644 --- a/src/server/Cache.hs +++ b/src/server/Cache.hs @@ -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')) diff --git a/src/server/PGFService.hs b/src/server/PGFService.hs index 04d576168..5db39872f 100644 --- a/src/server/PGFService.hs +++ b/src/server/PGFService.hs @@ -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) = diff --git a/src/server/pgf-fcgi.hs b/src/server/pgf-fcgi.hs index 9fddeed89..85dd2604d 100644 --- a/src/server/pgf-fcgi.hs +++ b/src/server/pgf-fcgi.hs @@ -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 diff --git a/src/server/pgf-service.cabal b/src/server/pgf-service.cabal index d8bc842d0..5a8e81490 100644 --- a/src/server/pgf-service.cabal +++ b/src/server/pgf-service.cabal @@ -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,