msyds/gf-core
1
0
Fork 0
forked from GitHub/gf-core
Code Pull Requests Activity

gf -server: allow multiple PGF service requests to be handled in parallel

Browse Source 
PGF service requests are stateless and can run in parallel, but some other
requests handled by the server are not and might even change the current
working directory temporarily, and this affects all threads, so it is
important that the PGF service requests access PGF files by absolute paths.
This commit is contained in:
hallgren
2014-01-24 13:49:02 +00:00
parent 55ea6cbec5
commit daa48610b5
1 changed files with 42 additions and 40 deletions
Download Patch File Download Diff File Expand all files Collapse all files

82
src/compiler/GFServer.hs
View File

@@ -9,6 +9,7 @@ import Control.Monad.Error(ErrorT(..),Error(..))
import System.Random(randomRIO) import System.Random(randomRIO)
--import System.IO(stderr,hPutStrLn) --import System.IO(stderr,hPutStrLn)
import GF.System.Catch(try) import GF.System.Catch(try)
import Control.Exception(bracket_)
import System.IO.Error(isAlreadyExistsError) import System.IO.Error(isAlreadyExistsError)
import GF.System.Directory(doesDirectoryExist,doesFileExist,createDirectory, import GF.System.Directory(doesDirectoryExist,doesFileExist,createDirectory,
setCurrentDirectory,getCurrentDirectory, setCurrentDirectory,getCurrentDirectory,
@@ -57,7 +58,7 @@ server port optroot execute1 state0 =
datadir <- getDataDir datadir <- getDataDir
let root = maybe (datadir</>"www") id optroot let root = maybe (datadir</>"www") id optroot
-- debug $ "document root="++root -- debug $ "document root="++root
setCurrentDirectory root setDir root
-- FCGI.acceptLoop forkIO (handle_fcgi execute1 state0 state cache) -- FCGI.acceptLoop forkIO (handle_fcgi execute1 state0 state cache)
-- if acceptLoop returns, then GF was not invoked as a FastCGI script -- if acceptLoop returns, then GF was not invoked as a FastCGI script
http_server execute1 state0 state cache root http_server execute1 state0 state cache root
@@ -68,7 +69,7 @@ server port optroot execute1 state0 =
logPutStrLn $ "Document root = "++root logPutStrLn $ "Document root = "++root
logPutStrLn $ "Starting HTTP server, open http://localhost:" logPutStrLn $ "Starting HTTP server, open http://localhost:"
++show port++"/ in your web browser." ++show port++"/ in your web browser."
initServer port (modifyMVar state . handle root state0 cache execute1) initServer port (handle root state0 cache execute1 state)
gf_version = "This is GF version "++showVersion version++".\n"++buildInfo gf_version = "This is GF version "++showVersion version++".\n"++buildInfo
@@ -117,50 +118,51 @@ put_state state = do qs <- get_qs; put (qs,state)
err :: Response -> HM s a err :: Response -> HM s a
err e = StateT $ \ s -> ErrorT $ return $ Left e err e = StateT $ \ s -> ErrorT $ return $ Left e
hmtry :: HM s a -> HM s (Either (Either IOError Response) a) hmbracket_ :: IO () -> IO () -> HM s a -> HM s a
hmtry m = do s <- get hmbracket_ pre post m =
e <- liftIO $ try $ runErrorT $ runStateT m s do s <- get
case e of e <- liftIO $ bracket_ pre post $ runErrorT $ runStateT m s
Left ioerror -> return (Left (Left ioerror)) case e of
Right (Left resp) -> return (Left (Right resp)) Left resp -> err resp
Right (Right (a,s)) -> do put s;return (Right a) Right (a,s) -> do put s;return a
-- | HTTP request handler -- | HTTP request handler
handle documentroot state0 cache execute1 handle documentroot state0 cache execute1 stateVar
rq@(Request method URI{uriPath=upath,uriQuery=q} hdrs body) state = rq@(Request method URI{uriPath=upath,uriQuery=q} hdrs body) =
case method of case method of
"POST" -> run normal_request (utf8inputs body,state) "POST" -> normal_request (utf8inputs body)
"GET" -> run normal_request (utf8inputs q,state) "GET" -> normal_request (utf8inputs q)
_ -> return (state,resp501 $ "method "++method) _ -> return (resp501 $ "method "++method)
where where
normal_request = normal_request qs =
do -- Defend against unhandled errors under inDir: do logPutStrLn $ method++" "++upath++" "++show (mapSnd (take 100.fst) qs)
liftIO $ setDir documentroot let stateful m = modifyMVar stateVar $ \ s -> run m (qs,s)
qs <- get_qs -- stateful ensures mutual exclusion, so you can use/change the cwd
logPutStrLn $ method++" "++upath++" "++show (mapSnd (take 100.fst) qs)
case upath of case upath of
"/new" -> new "/new" -> stateful $ new
-- "/stop" -> "/gfshell" -> stateful $ inDir command
-- "/start" -> "/cloud" -> stateful $ inDir cloud
"/gfshell" -> inDir command -- "/stop" ->
"/parse" -> parse (decoded qs) -- "/start" ->
"/cloud" -> inDir cloud "/parse" -> parse (decoded qs)
"/version" -> return (ok200 gf_version) "/version" -> return (ok200 gf_version)
'/':rpath -> '/':rpath ->
-- This code runs without mutual exclusion, so it must *not*
-- use/change the cwd. Access files by absolute paths only.
case (takeDirectory path,takeFileName path,takeExtension path) of case (takeDirectory path,takeFileName path,takeExtension path) of
(_ ,_ ,".pgf") -> wrapCGI $ PS.cgiMain' cache path (_ ,_ ,".pgf") -> do debug $ "PGF service: "++path
wrapCGI $ PS.cgiMain' cache path
(dir,"grammars.cgi",_ ) -> grammarList dir (decoded qs) (dir,"grammars.cgi",_ ) -> grammarList dir (decoded qs)
(dir ,"exb.fcgi" ,_ ) -> wrapCGI $ ES.cgiMain' root dir (fst cache) (dir ,"exb.fcgi" ,_ ) -> wrapCGI $ ES.cgiMain' root dir (fst cache)
_ -> liftIO $ serveStaticFile path _ -> serveStaticFile path
where path = translatePath rpath where path = translatePath rpath
_ -> err $ resp400 upath _ -> return $ resp400 upath
root = "." root = documentroot
translatePath rpath = root</>rpath -- hmm, check for ".." translatePath rpath = root</>rpath -- hmm, check for ".."
wrapCGI cgi = wrapCGI cgi = cgiHandler root (handleErrors . handleCGIErrors $ cgi) rq
liftIO $ cgiHandler root (handleErrors . handleCGIErrors $ cgi) rq
look field = look field =
do qs <- get_qs do qs <- get_qs
@@ -173,18 +175,19 @@ handle documentroot state0 cache execute1
where where
cd ('/':dir@('t':'m':'p':_)) = cd ('/':dir@('t':'m':'p':_)) =
do cwd <- liftIO $ getCurrentDirectory do cwd <- liftIO $ getCurrentDirectory
b <- liftIO $ try $ setDir dir b <- liftIO $ doesDirectoryExist dir
case b of case b of
Left _ -> do b <- liftIO $ try $ readFile dir -- poor man's symbolic links False -> do b <- liftIO $ try $ readFile dir -- poor man's symbolic links
case b of case b of
Left _ -> err $ resp404 dir Left _ -> err $ resp404 dir
Right dir' -> cd dir' Right dir' -> cd dir'
Right _ -> do --logPutStrLn $ "cd "++dir True -> do --logPutStrLn $ "cd "++dir
r <- hmtry (ok dir) hmInDir dir (ok dir)
liftIO $ setDir cwd
either (either (liftIO . ioError) err) return r
cd dir = err $ resp400 $ "unacceptable directory "++dir cd dir = err $ resp400 $ "unacceptable directory "++dir
-- First ensure that only one thread that depends on the cwd is running!
hmInDir dir = hmbracket_ (setDir dir) (setDir documentroot)
new = fmap ok200 $ liftIO $ newDirectory new = fmap ok200 $ liftIO $ newDirectory
command dir = command dir =
@@ -262,9 +265,8 @@ handle documentroot state0 cache execute1
download path = liftIO $ serveStaticFile path download path = liftIO $ serveStaticFile path
link_directories olddir newdir@('/':'t':'m':'p':'/':_) | old/=new = link_directories olddir newdir@('/':'t':'m':'p':'/':_) | old/=new =
liftIO $ hmInDir ".." $ liftIO $
do setDir ".." do logPutStrLn =<< getCurrentDirectory
logPutStrLn =<< getCurrentDirectory
logPutStrLn $ "link_dirs new="++new++", old="++old logPutStrLn $ "link_dirs new="++new++", old="++old
#ifdef mingw32_HOST_OS #ifdef mingw32_HOST_OS
isDir <- doesDirectoryExist old isDir <- doesDirectoryExist old