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

GFServer.hs: avoid intertwined log messages from parallel requests

Browse Source
This commit is contained in:
hallgren
2014-02-11 14:22:12 +00:00
parent 4c26fc80ee
commit d99f3e19d7
1 changed files with 14 additions and 8 deletions
Download Patch File Download Diff File Expand all files Collapse all files

22
src/compiler/GFServer.hs
View File

@@ -23,7 +23,7 @@ import System.FilePath(dropExtension,takeExtension,takeFileName,takeDirectory,
import System.Posix.Files(getSymbolicLinkStatus,isSymbolicLink,removeLink, import System.Posix.Files(getSymbolicLinkStatus,isSymbolicLink,removeLink,
createSymbolicLink) createSymbolicLink)
#endif #endif
import Control.Concurrent(newMVar,modifyMVar) import Control.Concurrent(forkIO,newMVar,modifyMVar,newChan,writeChan,getChanContents)
import Network.URI(URI(..)) import Network.URI(URI(..))
import Network.Shed.Httpd(initServer,Request(..),Response(..),noCache) import Network.Shed.Httpd(initServer,Request(..),Response(..),noCache)
--import qualified Network.FastCGI as FCGI -- from hackage direct-fastcgi --import qualified Network.FastCGI as FCGI -- from hackage direct-fastcgi
@@ -65,11 +65,14 @@ server port optroot execute1 state0 =
where where
-- | HTTP server -- | HTTP server
http_server execute1 state0 state cache root = http_server execute1 state0 state cache root =
do logPutStrLn gf_version do log <- newChan -- to avoid intertwined log messages
logPutStrLn $ "Document root = "++root forkIO $ mapM_ ePutStrLn =<< getChanContents log
logPutStrLn $ "Starting HTTP server, open http://localhost:" let logLn = writeChan log
++show port++"/ in your web browser." logLn gf_version
initServer port (handle root state0 cache execute1 state) 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)
gf_version = "This is GF version "++showVersion version++".\n"++buildInfo gf_version = "This is GF version "++showVersion version++".\n"++buildInfo
@@ -127,13 +130,16 @@ hmbracket_ pre post m =
Right (a,s) -> do put s;return a Right (a,s) -> do put s;return a
-- | HTTP request handler -- | HTTP request handler
handle documentroot state0 cache execute1 stateVar handle logLn documentroot state0 cache execute1 stateVar
rq@(Request method URI{uriPath=upath,uriQuery=q} hdrs body) = rq@(Request method URI{uriPath=upath,uriQuery=q} hdrs body) =
case method of case method of
"POST" -> normal_request (utf8inputs body) "POST" -> normal_request (utf8inputs body)
"GET" -> normal_request (utf8inputs q) "GET" -> normal_request (utf8inputs q)
_ -> return (resp501 $ "method "++method) _ -> return (resp501 $ "method "++method)
where where
logPutStrLn msg = liftIO $ logLn msg
debug msg = logPutStrLn msg
normal_request qs = normal_request qs =
do logPutStrLn $ method++" "++upath++" "++show (mapSnd (take 100.fst) qs) do logPutStrLn $ method++" "++upath++" "++show (mapSnd (take 100.fst) qs)
let stateful m = modifyMVar stateVar $ \ s -> run m (qs,s) let stateful m = modifyMVar stateVar $ \ s -> run m (qs,s)
@@ -150,7 +156,7 @@ handle documentroot state0 cache execute1 stateVar
-- This code runs without mutual exclusion, so it must *not* -- This code runs without mutual exclusion, so it must *not*
-- use/change the cwd. Access files by absolute paths only. -- 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") -> do debug $ "PGF service: "++path (_ ,_ ,".pgf") -> do --debug $ "PGF service: "++path
wrapCGI $ PS.cgiMain' cache 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)