make it possible to download a grammar

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
+handle logLn documentroot state0 cache execute stateVar conn = do
-       rq@(Request URI{uriPath=upath} method hdrs body) =
+  rq <- receiveHTTP conn
-    addDate $ normal_request rq 
+  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)
+         respondHTTP conn (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
 
     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
+  do b <- doesDirectoryExist path
-     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)

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 :: (String -> IO ()) -> Connection -> Caches -> Env -> Request -> IO ()
-pgfMain cache env rq =
+pgfMain logLn conn cache env rq =
   case fromMaybe "grammar" (lookup "command" query) of
     "download"
-      | ext == ".pgf" -> do body <- getFile readBinaryFile path
+      | ext == ".pgf" -> do tpgf <- getFile (readCache' (pgfCache cache)) path
-                            return (Response
+                            pgfDownload conn query tpgf
-                                      { rspCode = 200
+      | ext == ".ngf" -> do tpgf <- getFile (readCache' (ngfCache cache)) path
-                                      , rspReason = "OK"
+                            pgfDownload conn query tpgf
-                                      , rspHeaders = [Header HdrContentType "application/pgf"]
-                                      , rspBody = body
-                                      })
-      | otherwise     -> httpError 415 "Only .pgf files can be downloaded" ""
     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
+                            handleErrors logLn (pgfCommand (qsem cache) command query tpgf) >>= respondHTTP conn
-      | otherwise     -> httpError 415 "Extension must be .pgf or .ngf" ""
+    _                 -> 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