diff --git a/src/compiler/GF/Server.hs b/src/compiler/GF/Server.hs index d08e4e61e..bd3c9add3 100644 --- a/src/compiler/GF/Server.hs +++ b/src/compiler/GF/Server.hs @@ -1,6 +1,6 @@ -- | GF server mode {-# LANGUAGE CPP #-} -module GF.Server(server) where +module GF.Server(GF.Server.server) where import Data.List(partition,stripPrefix,isInfixOf) import Data.Maybe(fromMaybe) @@ -64,7 +64,7 @@ server jobs port optroot init execute1 = do logLn $ "Document root = "++root logLn $ "Starting HTTP server, open http://localhost:" ++show port++"/ in your web browser." - simpleServer (Just port) Nothing (handle logLn root state0 cache execute state) + Network.HTTP.server (Just port) Nothing (handle logLn root state0 cache execute state) gf_version = "This is GF version "++showVersion version++".\n"++buildInfo @@ -96,40 +96,37 @@ hmbracket_ pre post m = Right (a,s) -> do put s;return a -- | HTTP request handler -handle logLn documentroot state0 cache execute stateVar - rq@(Request URI{uriPath=upath} method hdrs body) = - addDate $ normal_request rq +handle logLn documentroot state0 cache execute stateVar conn = do + rq <- receiveHTTP conn + let query = rqQuery rq + upath = uriPath (rqURI rq) + logLn $ show (rqMethod rq) ++" "++upath++" "++show (mapSnd (take 500) query) + let stateful m = modifyMVar stateVar $ \s -> run m (query,s) + -- stateful ensures mutual exclusion, so you can use/change the cwd + case upath of + "/new" -> addDate (stateful $ new) + "/gfshell" -> addDate (stateful $ inDir command) + "/cloud" -> addDate (stateful $ inDir cloud) + "/parse" -> addDate (parse query) + "/version" -> addDate (versionInfo `fmap` PS.listPGFCache cache) + "/flush" -> addDate (PS.flushPGFCache cache >> return (ok200 "flushed")) + '/':rpath -> + -- This code runs without mutual exclusion, so it must *not* + -- use/change the cwd. Access files by absolute paths only. + let path = translatePath rpath + in case (takeDirectory path,takeFileName path,takeExtension path) of + (_ ,_ ,".pgf") -> PS.pgfMain logLn conn cache [("PATH_TRANSLATED",path)] rq + (_ ,_ ,".ngf") -> PS.pgfMain logLn conn cache [("PATH_TRANSLATED",path)] rq + (dir,"grammars.cgi",_ ) -> addDate (grammarList dir query) + _ -> do rsp <- serveStaticFile rpath path + respondHTTP conn rsp + _ -> addDate (return $ resp400 upath) where - logPutStrLn msg = liftIO $ logLn msg - addDate m = do t <- getCurrentTime r <- m let fmt = formatTime defaultTimeLocale rfc822DateFormat t - return (insertHeader HdrDate fmt r) - - normal_request rq = - do let query = rqQuery rq - logPutStrLn $ show method++" "++upath++" "++show (mapSnd (take 500) query) - let stateful m = modifyMVar stateVar $ \s -> run m (query,s) - -- stateful ensures mutual exclusion, so you can use/change the cwd - case upath of - "/new" -> stateful $ new - "/gfshell" -> stateful $ inDir command - "/cloud" -> stateful $ inDir cloud - "/parse" -> parse query - "/version" -> versionInfo `fmap` PS.listPGFCache cache - "/flush" -> do PS.flushPGFCache cache; return (ok200 "flushed") - '/':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 - (_ ,_ ,".pgf") -> PS.pgfMain cache [("PATH_TRANSLATED",path)] rq - (_ ,_ ,".ngf") -> PS.pgfMain cache [("PATH_TRANSLATED",path)] rq - (dir,"grammars.cgi",_ ) -> grammarList dir query - _ -> serveStaticFile rpath path - where path = translatePath rpath - _ -> return $ resp400 upath + respondHTTP conn (insertHeader HdrDate fmt r) translatePath rpath = documentroot rpath -- hmm, check for ".." @@ -217,9 +214,9 @@ handle logLn documentroot state0 cache execute stateVar flag (n,"") = n flag (n,v) = n++"="++v cmd = unwords ("gf":args) - logPutStrLn cmd + liftIO $ logLn cmd out@(ecode,_,_) <- liftIO $ readProcessWithExitCode "gf" args "" - logPutStrLn $ show ecode + liftIO (logLn $ show ecode) cwd <- getCurrentDirectory return $ json200 (jsonresult cwd ('/':dir++"/") cmd out files) @@ -305,8 +302,7 @@ jsonresult cwd dir cmd (ecode,stdout,stderr) files = -- * Static content serveStaticFile rpath path = - do --logPutStrLn $ "Serving static file "++path - b <- doesDirectoryExist path + do b <- doesDirectoryExist path if b then if rpath `elem` ["","."] || last path=='/' then serveStaticFile' (path "index.html") @@ -319,7 +315,10 @@ serveStaticFile' path = if ext `elem` [".cgi",".fcgi",".sh",".php"] then return $ resp400 $ "Unsupported file type: "++ext else do b <- doesFileExist path - if b then fmap (ok200' (ct t "")) $ rdFile path + if b then do time <- getModificationTime path + let fmt = formatTime defaultTimeLocale rfc822DateFormat time + body <- rdFile path + return (insertHeader HdrDate fmt (ok200' (ct t "") body)) else do cwd <- getCurrentDirectory logPutStrLn $ "Not found: "++path++" cwd="++cwd return (resp404 path) diff --git a/src/server/PGFService.hs b/src/server/PGFService.hs index b01e0f277..30757de18 100644 --- a/src/server/PGFService.hs +++ b/src/server/PGFService.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP, ScopedTypeVariables #-} module PGFService(pgfMain, Caches,newPGFCache,readCachedPGF,readCachedNGF, flushPGFCache,listPGFCache) where @@ -26,9 +26,8 @@ import System.FilePath(takeExtension) import System.Mem(performGC) import Network.HTTP import Network.FastCGI +import Numeric(showHex) -logFile :: FilePath -logFile = "pgf-error.log" data Caches = Caches { qsem :: QSem, pgfCache :: Cache PGF, @@ -63,24 +62,20 @@ newCache' root rd = do clean c = do threadDelay 2000000000 -- 2000 seconds, i.e. ~33 minutes expireCache (24*60*60) c -- 24 hours -pgfMain :: Caches -> Env -> Request -> IO Response -pgfMain cache env rq = +pgfMain :: (String -> IO ()) -> Connection -> Caches -> Env -> Request -> IO () +pgfMain logLn conn cache env rq = case fromMaybe "grammar" (lookup "command" query) of "download" - | ext == ".pgf" -> do body <- getFile readBinaryFile path - return (Response - { rspCode = 200 - , rspReason = "OK" - , rspHeaders = [Header HdrContentType "application/pgf"] - , rspBody = body - }) - | otherwise -> httpError 415 "Only .pgf files can be downloaded" "" + | ext == ".pgf" -> do tpgf <- getFile (readCache' (pgfCache cache)) path + pgfDownload conn query tpgf + | ext == ".ngf" -> do tpgf <- getFile (readCache' (ngfCache cache)) path + pgfDownload conn query tpgf command | ext == ".pgf" -> do tpgf <- getFile (readCache' (pgfCache cache)) path - pgfCommand (qsem cache) command query tpgf + handleErrors logLn (pgfCommand (qsem cache) command query tpgf) >>= respondHTTP conn | ext == ".ngf" -> do tpgf <- getFile (readCache' (ngfCache cache)) path - pgfCommand (qsem cache) command query tpgf - | otherwise -> httpError 415 "Extension must be .pgf or .ngf" "" + handleErrors logLn (pgfCommand (qsem cache) command query tpgf) >>= respondHTTP conn + _ -> respondHTTP conn (Response 415 "Bad Request" [] "Extension must be .pgf or .ngf") where path = fromMaybe "" (lookup "PATH_TRANSLATED" env `mplus` lookup "SCRIPT_FILENAME" env) @@ -95,10 +90,6 @@ pgfMain cache env rq = if isDoesNotExistError e then notFound path else ioError e) - - readBinaryFile fpath = do - bracket (openBinaryFile fpath ReadMode) hClose hGetContents - pgfCommand qsem command q (t,pgf) = case command of @@ -350,6 +341,30 @@ pgfCommand qsem command q (t,pgf) = "dot" -> "text/x-graphviz; charset=UTF8" _ -> "application/binary" +pgfDownload conn query (t,pgf) = do + let fmt = formatTime defaultTimeLocale rfc822DateFormat t + mb_langs = fmap words (lookup "lang" query) + writeHeaders conn (Response + { rspCode = 200 + , rspReason = "OK" + , rspHeaders = [ Header HdrContentType "application/pgf" + , Header HdrContentDisposition ("attachment; filename=\""++abstractName pgf++".pgf\"") + , Header HdrTransferEncoding "chunked" + , Header HdrDate fmt + ] + , rspBody = "" + }) + writePGF_ (writeChunk conn) pgf mb_langs + writeAscii conn "0\r\n\r\n" + where + writeChunk conn ptr len = + (do writeAscii conn (showHex len "\r\n") + n <- writeBytes conn ptr len + writeAscii conn "\r\n" + return n) + `catch` + (\(e :: SomeException) -> return (-1)) + out :: JSON a => Query -> UTCTime -> a -> IO Response out q t r = do let (ty,str) = case lookup "jsonp" q of