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

@@ -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 =
+cgiMain cache = cgiMain' cache =<< getPath
-    do path <- getVarWithDefault "SCRIPT_FILENAME" ""
+
-       pgf <- liftIO $ readCache cache path
+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
+         "parse"          -> outputJSONP =<< doParse pgf `fmap` getText `ap` getCat `ap` getFrom 
-         "complete"       -> return (doComplete pgf) `ap` getText `ap` getCat `ap` getFrom `ap` getLimit >>= outputJSONP
+         "complete"       -> outputJSONP =<< doComplete pgf `fmap` getText `ap` getCat `ap` getFrom `ap` getLimit
-         "linearize"      -> return (doLinearize pgf) `ap` getTree `ap` getTo >>= outputJSONP
+         "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
+         "translate"      -> outputJSONP =<< doTranslate pgf `fmap` getText `ap` getCat `ap` getFrom `ap` getTo
-         "translategroup" -> return (doTranslateGroup pgf) `ap` getText `ap` getCat `ap` getFrom `ap` getTo >>= outputJSONP
+         "translategroup" -> outputJSONP =<< doTranslateGroup pgf `fmap` getText `ap` getCat `ap` getFrom `ap` getTo
-         "grammar"        -> return (doGrammar pgf) `ap` requestAcceptLanguage >>= outputJSONP
+         "grammar"        -> outputJSONP =<< doGrammar pgf `fmap` requestAcceptLanguage
-         "abstrtree"      -> getTree >>= liftIO . doGraphvizAbstrTree pgf >>= outputPNG
+         "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 :: FilePath -> FilePath
-cleanFilePath = takeFileName
+--cleanFilePath = takeFileName

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" []
+                            

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"

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