switch to using http-slim

src/server/CGIUtils.hs

@@ -1,107 +0,0 @@
-{-# LANGUAGE DeriveDataTypeable, CPP #-}
--- | CGI utility functions for output, error handling and logging
-module CGIUtils (throwCGIError, handleCGIErrors,
-                 stderrToFile,logError,
-                 outputJSONP,outputEncodedJSONP,
-                 outputPNG,outputBinary,outputBinary',
-                 outputHTML,outputPlain,outputText) where
-
-import Control.Exception(Exception(..),SomeException(..),throw)
-import Data.Typeable(Typeable,cast)
-import Prelude hiding (catch)
-import System.IO(hPutStrLn,stderr)
-#ifndef mingw32_HOST_OS
-import System.Posix
-#endif
-
-import Network.CGI(CGI,CGIResult,setHeader,output,outputFPS,outputError,
-                   getInput)
-
-import Text.JSON
-import qualified Codec.Binary.UTF8.String as UTF8 (encodeString)
-import qualified Data.ByteString.Lazy as BS
-import Control.Monad.Catch (MonadThrow(throwM))
-import Control.Monad.Catch (MonadCatch(catch))
-
--- * Logging
-
-#ifndef mingw32_HOST_OS
-logError :: String -> IO ()
-logError s = hPutStrLn stderr s
-
-stderrToFile :: FilePath -> IO ()
-stderrToFile file =
-    do let mode = ownerReadMode<>ownerWriteMode<>groupReadMode<>otherReadMode
-           (<>) = unionFileModes
-           flags = defaultFileFlags { append = True }
-       fileFd <- openFd file WriteOnly (Just mode) flags
-       dupTo fileFd stdError
-       return ()
-#else
-logError :: String -> IO ()
-logError s = return ()
-
-stderrToFile :: FilePath -> IO ()
-stderrToFile s = return ()
-#endif
-
--- * General CGI Error exception mechanism
-
-data CGIError = CGIError { cgiErrorCode :: Int, cgiErrorMessage :: String, cgiErrorText :: [String] }
-                deriving (Show,Typeable)
-
-instance Exception CGIError where
-  toException e = SomeException e
-  fromException (SomeException e) = cast e
-
-throwCGIError :: Int -> String -> [String] -> CGI a
-throwCGIError c m t = throwM $ toException $ CGIError c m t
-
-handleCGIErrors :: CGI CGIResult -> CGI CGIResult
-handleCGIErrors x =
-    x `catch` \e -> case fromException e of
-                         Nothing -> throw e
-                         Just (CGIError c m t) -> do setXO; outputError c m t
-
--- * General CGI and JSON stuff
-
-outputJSONP :: JSON a => a -> CGI CGIResult
-outputJSONP = outputEncodedJSONP . encode
-
-outputEncodedJSONP :: String -> CGI CGIResult
-outputEncodedJSONP json = 
-    do mc <- getInput "jsonp"
-       let (ty,str) = case mc of
-                        Nothing -> ("json",json)
-                        Just c  -> ("javascript",c ++ "(" ++ json ++ ")")
-           ct = "application/"++ty++"; charset=utf-8"
-       outputText ct str
-
-outputPNG :: BS.ByteString -> CGI CGIResult
-outputPNG = outputBinary' "image/png"
-
-outputBinary :: BS.ByteString -> CGI CGIResult
-outputBinary = outputBinary' "application/binary"
-
-outputBinary' :: String -> BS.ByteString -> CGI CGIResult
-outputBinary' ct x = do
-       setHeader "Content-Type" ct
-       setXO
-       outputFPS x
-
-outputHTML :: String -> CGI CGIResult
-outputHTML = outputText "text/html; charset=utf-8"
-
-outputPlain :: String -> CGI CGIResult
-outputPlain = outputText "text/plain; charset=utf-8"
-
-outputText ct = outputStrict ct . UTF8.encodeString
-
-outputStrict :: String -> String -> CGI CGIResult
-outputStrict ct x | x == x = do setHeader "Content-Type" ct
-                                setXO
-                                output x
-                  | otherwise = fail "I am the pope."
-
-setXO = setHeader "Access-Control-Allow-Origin" "*"
-     -- https://developer.mozilla.org/en-US/docs/HTTP/Access_control_CORS

src/server/PGFService.hs

@@ -1,44 +1,31 @@
 {-# LANGUAGE CPP #-}
-module PGFService(cgiMain,cgiMain',getPath,
+module PGFService(pgfMain,
-                  logFile,stderrToFile,
                   Caches,newPGFCache,readCachedPGF,readCachedNGF,
                   flushPGFCache,listPGFCache) where
 
 import PGF2
 import PGF2.Transactions
 import Cache
-import Network.CGI(CGI,readInput,getInput,getVarWithDefault,
-                   CGIResult,handleErrors,setHeader,
-                   Accept(..),Language(..),negotiate,liftIO)
-import CGIUtils(outputJSONP,outputPlain,
-                outputBinary,outputBinary',
-                handleCGIErrors,throwCGIError,stderrToFile)
-import URLEncoding
 
 import Data.Time.Format(formatTime)
 import Data.Time.Format(defaultTimeLocale,rfc822DateFormat)
 import Text.JSON
-import qualified Codec.Binary.UTF8.String as UTF8 (decodeString)
-import qualified Data.ByteString.Lazy as BS
 
 import Control.Concurrent
-import qualified Control.Exception as E
+import Control.Exception
 import Control.Monad
-import Control.Monad.Catch(bracket_)
 import Data.Char
 import qualified Data.Map as Map
 import Data.Maybe
+import Data.Time (UTCTime)
 import System.Process
 import System.Exit
 import System.IO
 import System.IO.Error(isDoesNotExistError)
 import System.FilePath(takeExtension)
 import System.Mem(performGC)
-
+import Network.HTTP
-catchIOE :: IO a -> (E.IOException -> IO a) -> IO a
+import Network.FastCGI
-catchIOE = E.catch
-
-withQSem qsem = bracket_ (liftIO $ waitQSem qsem) (liftIO $ signalQSem qsem)
 
 logFile :: FilePath
 logFile = "pgf-error.log"
@@ -76,71 +63,77 @@ newCache' root rd = do
     clean c = do threadDelay 2000000000 -- 2000 seconds, i.e. ~33 minutes
                  expireCache (24*60*60) c -- 24 hours
 
-getPath =
+pgfMain :: Caches -> Env -> Request -> IO Response
-    do path <- getVarWithDefault "PATH_TRANSLATED" "" -- apache mod_fastcgi
+pgfMain cache env rq =
-       if null path
+  case fromMaybe "grammar" (lookup "command" query) of
-          then getVarWithDefault "SCRIPT_FILENAME" "" -- lighttpd
+    "download"
-          else return path
+      | ext == ".pgf" -> do body <- getFile readBinaryFile path
-
+                            return (Response
-cgiMain :: Caches -> CGI CGIResult
+                                      { rspCode = 200
-cgiMain cache = handleErrors . handleCGIErrors $
+                                      , rspReason = "OK"
-                  cgiMain' cache =<< getPath
+                                      , rspHeaders = [Header HdrServer defaultServer
-
+                                                     ,Header HdrContentType "application/pgf"
-cgiMain' :: Caches -> FilePath -> CGI CGIResult
+                                                     ,Header HdrContentLength (show (length body))
-cgiMain' cache path =
+                                                     ]
-    do command <- liftM (maybe "grammar" (urlDecodeUnicode . UTF8.decodeString))
+                                      , rspBody = body
-                        (getInput "command")
+                                      })
-       case command of
+      | otherwise     -> httpError 415 "Only .pgf files can be downloaded" ""
-         "download" -> outputBinary =<< getFile BS.readFile path
+    command
-         _ -> do let get = case takeExtension path of
+      | ext == ".pgf" -> do tpgf <- getFile (readCache' (pgfCache cache)) path
-                             ".pgf" -> pgfCache
+                            pgfCommand (qsem cache) command query tpgf
-                             ".ngf" -> ngfCache
+      | ext == ".ngf" -> do tpgf <- getFile (readCache' (ngfCache cache)) path
-                             _      -> error "Extension must be .pgf or .ngf"
+                            pgfCommand (qsem cache) command query tpgf
-                 tpgf <- getFile (readCache' (get cache)) path
+      | otherwise     -> httpError 415 "Extension must be .pgf or .ngf" ""
-                 pgfMain (qsem cache) command tpgf
     where
+      path = fromMaybe "" (lookup "PATH_TRANSLATED" env `mplus`
+                           lookup "SCRIPT_FILENAME" env)
+      ext  = takeExtension path
+                           
+      query = rqQuery rq
+
       getFile get path =
-        either failed return =<< liftIO (E.try (get path))
+        (get path)
-        where
+        `catch`
-          failed e = 
+        (\e ->
             if isDoesNotExistError e
               then notFound path
-              else liftIO $ ioError e
+              else ioError e)
+              
+      readBinaryFile fpath = do
+        bracket (openBinaryFile fpath ReadMode) hClose hGetContents
 
 
-pgfMain qsem command (t,pgf) =
+pgfCommand qsem command q (t,pgf) =
   case command of
     "parse"         -> withQSem qsem $
-                       out t=<< join (parse # input % cat % start % limit % treeopts)
+                       out q t=<< join (parse # input % cat % start % limit % treeopts)
 --    "parseToChart"  -> withQSem qsem $
---                       out t=<< join (parseToChart # input % cat % limit)
+--                       out q t=<< join (parseToChart # input % cat % limit)
-    "linearize"     -> out t=<< lin # tree % to
+    "linearize"     -> out q t=<< lin # tree % to
     "bracketedLinearize"
-                    -> out t=<< bracketedLin # tree % to
+                    -> out q t=<< bracketedLin # tree % to
-    "linearizeAll"  -> out t=<< linAll # tree % to
+    "linearizeAll"  -> out q t=<< linAll # tree % to
     "translate"     -> withQSem qsem $
-                       out t=<<join(trans # input % cat % to % start % limit%treeopts)
+                       out q t=<<join(trans # input % cat % to % start % limit%treeopts)
-    "lookupmorpho"  -> out t=<< morpho # from % textInput
+    "lookupmorpho"  -> out q t=<< morpho # from % textInput
-    "lookupcohorts" -> out t=<< cohorts # from % getInput "filter" % textInput
+    "lookupcohorts" -> out q t=<< cohorts # from % filter % textInput
-    "flush"         -> out t=<< flush
+    "flush"         -> out q t=<< flush
-    "grammar"       -> out t grammar
+    "grammar"       -> out q t grammar
     "abstrtree"     -> outputGraphviz=<< graphvizAbstractTree pgf graphvizDefaults # tree
-    "parsetree"     -> outputGraphviz=<< (\cnc -> graphvizParseTree cnc graphvizDefaults) . snd # from %tree
+    "parsetree"     -> outputGraphviz=<< (\cnc -> graphvizParseTree cnc graphvizDefaults) . snd # from % tree
-    "wordforword"   -> out t =<< wordforword # input % cat % to
+    "wordforword"   -> out q t =<< wordforword # input % cat % to
     _               -> badRequest "Unknown command" command
   where
-    flush = liftIO $ do --modifyMVar_ pc $ const $ return Map.empty
+    flush = do performGC
-                        performGC
+               return $ showJSON ()
-                        return $ showJSON ()
 
-    cat :: CGI Type
+    cat :: IO Type
     cat =
-       do mcat  <- getInput1 "cat"
+       case lookup "cat" q of
-          case mcat of
+         Nothing -> return (startCat pgf)
-            Nothing -> return (startCat pgf)
+         Just cat -> case readType cat of
-            Just cat -> case readType cat of
+                       Nothing  -> badRequest "Bad category" cat
-                          Nothing  -> badRequest "Bad category" cat
+                       Just typ -> return typ
-                          Just typ -> return typ
 
     langs = languages pgf
 
@@ -201,6 +194,7 @@ pgfMain qsem command (t,pgf) =
 
         mkChartPArg (PArg _ fid) = showJSON fid
 -}
+
     linAll tree to = showJSON (linAll' tree to)
     linAll' tree tos =
         [makeObj ["to".=to,
@@ -212,7 +206,7 @@ pgfMain qsem command (t,pgf) =
 
     bracketedLin tree to = showJSON (bracketedLin' tree to)
     bracketedLin' tree tos =
-        [makeObj ["to".=to,"brackets".=showJSON (bracketedLinearize c tree)]|(to,c)<-tos]
+        [makeObj ["to".=to,"brackets".=bracketedLinearize c tree]|(to,c)<-tos]
 
     trans input@((from,_),_) cat to start mlimit (trie,jsontree) =
       do parses <- parse' cat start mlimit input
@@ -235,12 +229,12 @@ pgfMain qsem command (t,pgf) =
                      | (l,a,p)<-lookupMorpho concr input]
 
     cohorts (from,concr) filter input =
-      showJSON [makeObj ["start" .=showJSON s
+      showJSON [makeObj ["start" .=s
-                        ,"word"  .=showJSON w
+                        ,"word"  .=w
-                        ,"morpho".=showJSON [makeObj ["lemma".=l
+                        ,"morpho".=[makeObj ["lemma".=l
-                                                     ,"analysis".=a
+                                            ,"analysis".=a
-                                                     ,"prob".=p] 
+                                            ,"prob".=p]
-                                                | (l,a,p)<-ms]
+                                      | (l,a,p)<-ms]
                         ,"end"   .=showJSON e
                         ]
                    | (s,w,ms,e) <- (case filter of
@@ -299,79 +293,103 @@ pgfMain qsem command (t,pgf) =
 
     to = getLangs "to"
 
-    getLangs i = mapM readLang . maybe [] words =<< getInput i
+    getLangs i = mapM readLang (maybe [] words (lookup i q))
 
-    getLang i = do
+    getLang i =
-      mlang <- getInput i
+      case lookup i q of
-      case mlang of
+        Just lang -> fmap Just (readLang lang)
-        Just lang@(_:_) -> Just # readLang lang
+        _         -> return Nothing
-        _               -> return Nothing
 
-    readLang :: String -> CGI (String,Concr)
+    readLang :: String -> IO (String,Concr)
     readLang lang =
       case Map.lookup lang langs of
         Nothing -> badRequest "Bad language" lang
-        Just c -> return (lang,c)
+        Just c  -> return (lang,c)
 
-    tree = do s <- maybe (missing "tree") return =<< getInput1 "tree"
+    tree = do s <- maybe (missing "tree") return (lookup "tree" q)
               maybe (badRequest "bad tree" s) return (readExpr s)
 
+    textInput = maybe (missing "input") return (lookup "input" q)
+    
+    filter = return (lookup "filter" q)
+    
+    start = 
+      case lookup "start" q of
+        Just s  -> case reads s of
+                     [(val,"")] -> return val
+                     _          -> badRequest "bad start" s
+        Nothing -> return 0
 
-out t r = do let fmt = formatTime defaultTimeLocale rfc822DateFormat t
+    limit = 
-             setHeader "Last-Modified" fmt
+      case lookup "limit" q of
-             outputJSONP r
+        Just s  -> case reads s of
+                     [(val,"")] -> return (Just val)
+                     _          -> badRequest "bad limit" s
+        Nothing -> return Nothing
 
+    treeopts = (,) # getBool "trie" % getBool "jsontree"
+
+    getBool x = return (maybe False toBool (lookup x q))
+      where
+        toBool s = s `elem` ["","yes","true","True"]
+
+    outputGraphviz code
+      | fmt == "dot" = outputGraph code
+      | otherwise    = outputGraph =<< pipeIt2graphviz fmt code
+      where
+        fmt = fromMaybe "png" (lookup "format" q)
+
+        outputGraph body =
+          return (Response
+            { rspCode = 200
+            , rspReason = "OK"
+            , rspHeaders = [Header HdrServer defaultServer
+                           ,Header HdrContentType mimeType
+                           ,Header HdrContentLength (show (length body))
+                           ]
+            , rspBody = body
+            })
+
+        mimeType =
+          case fmt of
+            "png" -> "image/png"
+            "gif" -> "image/gif"
+            "svg" -> "image/svg+xml"
+            "dot" -> "text/x-graphviz; charset=UTF8"
+            _     -> "application/binary"
+
+out :: JSON a => Query -> UTCTime -> a -> IO Response
+out q t r = do
+  let (ty,str) = case lookup "jsonp" q of
+                   Nothing -> ("json",encode r)
+                   Just c  -> ("javascript",c ++ "(" ++ encode r ++ ")")
+      fmt = formatTime defaultTimeLocale rfc822DateFormat t
+  return (Response
+            { rspCode = 200
+            , rspReason = "OK"
+            , rspHeaders = [Header HdrServer defaultServer
+                           ,Header HdrContentType ("application/"++ty++"; charset=utf-8")
+                           ,Header HdrLastModified fmt
+                           ,Header HdrContentLength (show (length str))
+                           ]
+            , rspBody = str
+            })
+{-
 getInput1 x = nonEmpty # getInput x
 nonEmpty (Just "") = Nothing
 nonEmpty r = r
 
-textInput :: CGI String
-textInput = liftM (maybe "" (urlDecodeUnicode . UTF8.decodeString)) $ getInput "input"
-
 limit, depth :: CGI (Maybe Int)
 limit = readInput "limit"
 depth = readInput "depth"
-
+-}
-start :: CGI Int
-start = maybe 0 id # readInput "start"
-
-treeopts :: CGI TreeOpts
-treeopts = (,) # getBool "trie" % getBool "jsontree"
-
-getBool x = maybe False toBool # getInput x
-toBool s = s `elem` ["","yes","true","True"]
-
 missing = badRequest "Missing parameter"
 errorMissingId = badRequest "Missing identifier" ""
 
-notFound = throw 404 "Not found"
+notFound = httpError 404 "Not found"
-badRequest = throw 400
+badRequest = httpError 400
 
-throw code msg extra =
+pipeIt2graphviz :: String -> String -> IO String
-    throwCGIError code msg [msg ++(if null extra then "" else ": "++extra)]
-
-format def = maybe def id # getInput "format"
-
-type From = (Maybe Concr,String)
-type TreeOpts = (Bool,Bool) -- (trie,jsontree)
-
-outputGraphviz code =
-  do fmt <- format "png"
-     case fmt of
-       "gv" -> outputPlain code
-       _ -> outputFPS' fmt =<< liftIO (pipeIt2graphviz fmt code)
-  where
-    outputFPS' = outputBinary' . mimeType
-
-    mimeType fmt =
-      case fmt of
-        "png" -> "image/png"
-        "gif" -> "image/gif"
-        "svg" -> "image/svg+xml"
-    -- ...
-        _     -> "application/binary"
-
-pipeIt2graphviz :: String -> String -> IO BS.ByteString
 pipeIt2graphviz fmt code = do
     (Just inh, Just outh, _, pid) <-
         createProcess (proc "dot" ["-T",fmt])
@@ -380,12 +398,12 @@ pipeIt2graphviz fmt code = do
                         std_err = Inherit }
 
     hSetBinaryMode outh True
-    hSetEncoding inh  utf8
+    hSetEncoding inh utf8
 
     -- fork off a thread to start consuming the output
-    output  <- BS.hGetContents outh
+    output  <- hGetContents outh
     outMVar <- newEmptyMVar
-    _ <- forkIO $ E.evaluate (BS.length output) >> putMVar outMVar ()
+    _ <- forkIO $ evaluate (length output) >> putMVar outMVar ()
 
     -- now write and flush any input
     hPutStr inh code
@@ -415,7 +433,7 @@ instance JSON BracketedString where
     showJSON (Leaf s) = makeObj ["token".=s]
 
 -- * PGF utilities
-
+{-
 selectLanguage :: PGF -> Maybe (Accept Language) -> Concr
 selectLanguage pgf macc = case acceptable of
                             []  -> case Map.elems (languages pgf) of
@@ -427,6 +445,7 @@ selectLanguage pgf macc = case acceptable of
 
 langCodeLanguage :: PGF -> String -> Maybe Concr
 langCodeLanguage pgf code = listToMaybe [concr | concr <- Map.elems (languages pgf), languageCode concr == Just code]
+-}
 
 -- * General utilities
 
@@ -435,3 +454,6 @@ infixl 2 #,%
 f .= v = (f,showJSON v)
 f # x = fmap f x
 f % x = ap f x
+
+
+withQSem qsem = bracket_ (waitQSem qsem) (signalQSem qsem)

src/server/pgf-service.cabal

@@ -15,7 +15,7 @@ flag network-uri
    default: True
 
 Library
-  exposed-modules: PGFService URLEncoding CGIUtils
+  exposed-modules: PGFService
   other-modules:   Cache
   build-depends:   base >=4.2,
                    time,
@@ -24,12 +24,9 @@ Library
                    containers,
                    process,
                    pgf2 >= 2,
-                   cgi >= 3001.1.7.3,
+                   http-slim,
-                   httpd-shed>=0.4.0.2,
                    mtl,
-                   exceptions,
                    json >= 0.3.3,
-                   utf8-string >= 0.3.1.1,
                    bytestring,
                    pretty,
                    random