From ac23280320313b0e470c8de6d49415e93d3c9d97 Mon Sep 17 00:00:00 2001 From: hallgren Date: Wed, 1 Sep 2010 14:08:52 +0000 Subject: [PATCH] Standalone HTTP version of pgf-server pgf-server can now act as a standalone HTTP server. To activate this mode, start it with pfg-server http to use the default port number (41296), or give an explicit port number, e.g., pgf-server http 8080 The HTTP server serves PGF files in the same way as the old FastCGI interface. In addition, it also serves static files. The document root for static files is the www subdirectory of the current directory where pgf-server is started. In spite of these addition, backwards compatibility is maintaned. The old FastCGI interface continues to work as before. (It is activated when pgf-server is started without arguments.) --- src/server/PGFService.hs | 64 +++++++++++++++++++++++++++-------- src/server/RunHTTP.hs | 41 ++++++++++++++++++++++ src/server/ServeStaticFile.hs | 20 +++++++++++ src/server/gf-server.cabal | 4 +++ 4 files changed, 114 insertions(+), 15 deletions(-) create mode 100644 src/server/RunHTTP.hs create mode 100644 src/server/ServeStaticFile.hs diff --git a/src/server/PGFService.hs b/src/server/PGFService.hs index c19f7961c..4d8cd2f51 100644 --- a/src/server/PGFService.hs +++ b/src/server/PGFService.hs @@ -5,6 +5,8 @@ import qualified PGF import Cache import FastCGIUtils import URLEncoding +import RunHTTP +import ServeStaticFile import Network.FastCGI import Text.JSON @@ -25,6 +27,7 @@ import System.FilePath import System.Process import System.Exit import System.IO +import System.Environment(getArgs) logFile :: FilePath logFile = "pgf-error.log" @@ -33,33 +36,64 @@ logFile = "pgf-error.log" main :: IO () main = do stderrToFile logFile cache <- newCache PGF.readPGF + args <- getArgs + case args of + [] -> fcgiMain cache + ["http"] -> httpMain cache 41296 + ["http",port] -> httpMain cache =<< readIO port + +httpMain cache port = runHTTP port (do log ; serve =<< getPath) + where + log = do method <- requestMethod + uri <- getVarWithDefault "REQUEST_URI" "-" + logCGI $ method++" "++uri + + serve path = + if takeExtension path==".pgf" + then cgiMain' cache path + else if takeFileName path=="grammars.cgi" + then grammarList (takeDirectory path) + else serveStaticFile path + + grammarList dir = + do paths <- liftIO $ getDirectoryContents dir + let pgfs = [path|path<-paths, takeExtension path==".pgf"] + outputJSONP pgfs + +fcgiMain :: Cache PGF -> IO () +fcgiMain cache = #ifndef mingw32_HOST_OS - runFastCGIConcurrent' forkIO 100 (handleErrors (handleCGIErrors (cgiMain cache))) + runFastCGIConcurrent' forkIO 100 (cgiMain cache) #else - runFastCGI (handleErrors (handleCGIErrors (cgiMain cache))) + runFastCGI (cgiMain cache) #endif +getPath = getVarWithDefault "SCRIPT_FILENAME" "" + cgiMain :: Cache PGF -> CGI CGIResult -cgiMain cache = - do path <- getVarWithDefault "SCRIPT_FILENAME" "" - pgf <- liftIO $ readCache cache path +cgiMain cache = cgiMain' cache =<< getPath + +cgiMain' :: Cache PGF -> FilePath -> CGI CGIResult +cgiMain' cache path = + handleErrors . handleCGIErrors $ + do pgf <- liftIO $ readCache cache path command <- liftM (maybe "grammar" (urlDecodeUnicode . UTF8.decodeString)) (getInput "command") pgfMain pgf command pgfMain :: PGF -> String -> CGI CGIResult pgfMain pgf command = case command of - "parse" -> return (doParse pgf) `ap` getText `ap` getCat `ap` getFrom >>= outputJSONP - "complete" -> return (doComplete pgf) `ap` getText `ap` getCat `ap` getFrom `ap` getLimit >>= outputJSONP - "linearize" -> return (doLinearize pgf) `ap` getTree `ap` getTo >>= outputJSONP + "parse" -> outputJSONP =<< doParse pgf `fmap` getText `ap` getCat `ap` getFrom + "complete" -> outputJSONP =<< doComplete pgf `fmap` getText `ap` getCat `ap` getFrom `ap` getLimit + "linearize" -> outputJSONP =<< doLinearize pgf `fmap` getTree `ap` getTo "random" -> getCat >>= \c -> getLimit >>= liftIO . doRandom pgf c >>= outputJSONP - "translate" -> return (doTranslate pgf) `ap` getText `ap` getCat `ap` getFrom `ap` getTo >>= outputJSONP - "translategroup" -> return (doTranslateGroup pgf) `ap` getText `ap` getCat `ap` getFrom `ap` getTo >>= outputJSONP - "grammar" -> return (doGrammar pgf) `ap` requestAcceptLanguage >>= outputJSONP - "abstrtree" -> getTree >>= liftIO . doGraphvizAbstrTree pgf >>= outputPNG + "translate" -> outputJSONP =<< doTranslate pgf `fmap` getText `ap` getCat `ap` getFrom `ap` getTo + "translategroup" -> outputJSONP =<< doTranslateGroup pgf `fmap` getText `ap` getCat `ap` getFrom `ap` getTo + "grammar" -> outputJSONP =<< doGrammar pgf `fmap` requestAcceptLanguage + "abstrtree" -> outputPNG =<< liftIO . doGraphvizAbstrTree pgf =<< getTree "parsetree" -> getTree >>= \t -> getFrom >>= \(Just l) -> liftIO (doGraphvizParseTree pgf l t) >>= outputPNG "alignment" -> getTree >>= liftIO . doGraphvizAlignment pgf >>= outputPNG - "browse" -> return (doBrowse pgf) `ap` getId `ap` getCSSClass `ap` getHRef >>= outputHTML + "browse" -> outputHTML =<< doBrowse pgf `fmap` getId `ap` getCSSClass `ap` getHRef _ -> throwCGIError 400 "Unknown command" ["Unknown command: " ++ show command] where getText :: CGI String @@ -447,5 +481,5 @@ langCodeLanguage pgf code = listToMaybe [l | l <- PGF.languages pgf, PGF.languag -- * General utilities -cleanFilePath :: FilePath -> FilePath -cleanFilePath = takeFileName +--cleanFilePath :: FilePath -> FilePath +--cleanFilePath = takeFileName diff --git a/src/server/RunHTTP.hs b/src/server/RunHTTP.hs new file mode 100644 index 000000000..cf536d054 --- /dev/null +++ b/src/server/RunHTTP.hs @@ -0,0 +1,41 @@ +module RunHTTP(runHTTP) where +import Network.URI(uriPath,uriQuery) +import Network.CGI(ContentType(..)) +import Network.CGI.Protocol(CGIResult(..),CGIRequest(..),Input(..), + Headers,HeaderName(..)) +import Network.CGI.Monad(runCGIT) +import Network.Shed.Httpd(initServer,Request(..),Response(..),queryToArguments) +import qualified Data.ByteString.Lazy.Char8 as BS(pack,unpack) +import qualified Data.Map as M(fromList) + +documentRoot = "www" + +runHTTP port = initServer port . cgiHandler + +cgiHandler h = fmap httpResp . runCGIT h . cgiReq + +httpResp :: (Headers,CGIResult) -> Response +httpResp (hdrs,r) = Response code (map name hdrs) (body r) + where + code = maybe 200 (read.head.words) (lookup (HeaderName "Status") hdrs) + body CGINothing = "" + body (CGIOutput s) = BS.unpack s + + name (HeaderName n,v) = (n,v) + +cgiReq :: Request -> CGIRequest +cgiReq (Request method uri hdrs body) = CGIRequest vars inputs body' + where + vars = M.fromList [("REQUEST_METHOD",method), + ("REQUEST_URI",show uri), + ("SCRIPT_FILENAME",documentRoot++uriPath uri), + ("QUERY_STRING",qs)] + qs = case uriQuery uri of + '?':s -> s + s -> s + inputs = map input $ queryToArguments qs -- assumes method=="GET" + body' = BS.pack body + + input (name,val) = (name,Input (BS.pack val) Nothing plaintext) + plaintext = ContentType "plain" "text" [] + \ No newline at end of file diff --git a/src/server/ServeStaticFile.hs b/src/server/ServeStaticFile.hs new file mode 100644 index 000000000..f2bbc3e81 --- /dev/null +++ b/src/server/ServeStaticFile.hs @@ -0,0 +1,20 @@ +module ServeStaticFile where +import System.FilePath +import Network.CGI(setHeader,outputFPS,liftIO) +import qualified Data.ByteString.Lazy.Char8 as BS + +serveStaticFile path = + do setHeader "Content-Type" (contentTypeFromExt (takeExtension path)) + outputFPS =<< liftIO (BS.readFile path) + +contentTypeFromExt ext = + case ext of + ".html" -> "text/html; charset=\"iso8859-1\"" + ".htm" -> "text/html; charset=\"iso8859-1\"" + ".xml" -> "text/xml; charset=\"iso8859-1\"" + ".txt" -> "text/plain; charset=\"iso8859-1\"" + ".css" -> "text/css; charset=\"iso8859-1\"" + ".js" -> "text/javascript; charset=\"iso8859-1\"" + ".png" -> "image/png" + ".jpg" -> "image/jpg" + _ -> "application/octet-stream" \ No newline at end of file diff --git a/src/server/gf-server.cabal b/src/server/gf-server.cabal index fa576db4e..619efdde1 100644 --- a/src/server/gf-server.cabal +++ b/src/server/gf-server.cabal @@ -16,6 +16,8 @@ executable pgf-server gf >= 3.1, cgi >= 3001.1.8.0, fastcgi >= 3001.0.2.2, + httpd-shed, + network, json >= 0.3.3, utf8-string >= 0.3.1.1, bytestring, @@ -27,6 +29,8 @@ executable pgf-server FastCGIUtils Cache URLEncoding + RunHTTP + ServeStaticFile ghc-options: -threaded if os(windows) ghc-options: -optl-mwindows