diff --git a/src/server/CGIUtils.hs b/src/server/CGIUtils.hs deleted file mode 100644 index f47e3eceb..000000000 --- a/src/server/CGIUtils.hs +++ /dev/null @@ -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 diff --git a/src/server/PGFService.hs b/src/server/PGFService.hs index 5db39872f..42aceeb37 100644 --- a/src/server/PGFService.hs +++ b/src/server/PGFService.hs @@ -1,44 +1,31 @@ {-# LANGUAGE CPP #-} -module PGFService(cgiMain,cgiMain',getPath, - logFile,stderrToFile, +module PGFService(pgfMain, 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) - -catchIOE :: IO a -> (E.IOException -> IO a) -> IO a -catchIOE = E.catch - -withQSem qsem = bracket_ (liftIO $ waitQSem qsem) (liftIO $ signalQSem qsem) +import Network.HTTP +import Network.FastCGI 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 = - do path <- getVarWithDefault "PATH_TRANSLATED" "" -- apache mod_fastcgi - if null path - then getVarWithDefault "SCRIPT_FILENAME" "" -- lighttpd - else return path - -cgiMain :: Caches -> CGI CGIResult -cgiMain cache = handleErrors . handleCGIErrors $ - cgiMain' cache =<< getPath - -cgiMain' :: Caches -> FilePath -> CGI CGIResult -cgiMain' cache path = - do command <- liftM (maybe "grammar" (urlDecodeUnicode . UTF8.decodeString)) - (getInput "command") - case command of - "download" -> outputBinary =<< getFile BS.readFile path - _ -> do let get = case takeExtension path of - ".pgf" -> pgfCache - ".ngf" -> ngfCache - _ -> error "Extension must be .pgf or .ngf" - tpgf <- getFile (readCache' (get cache)) path - pgfMain (qsem cache) command tpgf +pgfMain :: Caches -> Env -> Request -> IO Response +pgfMain 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 HdrServer defaultServer + ,Header HdrContentType "application/pgf" + ,Header HdrContentLength (show (length body)) + ] + , 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 + | ext == ".ngf" -> do tpgf <- getFile (readCache' (ngfCache cache)) path + pgfCommand (qsem cache) command query tpgf + | otherwise -> httpError 415 "Extension must be .pgf or .ngf" "" 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)) - where - failed e = + (get path) + `catch` + (\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) - "linearize" -> out t=<< lin # tree % to +-- out q t=<< join (parseToChart # input % cat % limit) + "linearize" -> out q t=<< lin # tree % to "bracketedLinearize" - -> out t=<< bracketedLin # tree % to - "linearizeAll" -> out t=<< linAll # tree % to + -> out q t=<< bracketedLin # tree % to + "linearizeAll" -> out q t=<< linAll # tree % to "translate" -> withQSem qsem $ - out t=< out t=<< morpho # from % textInput - "lookupcohorts" -> out t=<< cohorts # from % getInput "filter" % textInput - "flush" -> out t=<< flush - "grammar" -> out t grammar + out q t=< out q t=<< morpho # from % textInput + "lookupcohorts" -> out q t=<< cohorts # from % filter % textInput + "flush" -> out q t=<< flush + "grammar" -> out q t grammar "abstrtree" -> outputGraphviz=<< graphvizAbstractTree pgf graphvizDefaults # tree - "parsetree" -> outputGraphviz=<< (\cnc -> graphvizParseTree cnc graphvizDefaults) . snd # from %tree - "wordforword" -> out t =<< wordforword # input % cat % to + "parsetree" -> outputGraphviz=<< (\cnc -> graphvizParseTree cnc graphvizDefaults) . snd # from % tree + "wordforword" -> out q t =<< wordforword # input % cat % to _ -> badRequest "Unknown command" command where - flush = liftIO $ do --modifyMVar_ pc $ const $ return Map.empty - performGC - return $ showJSON () + flush = do performGC + return $ showJSON () - cat :: CGI Type + cat :: IO Type cat = - do mcat <- getInput1 "cat" - case mcat of - Nothing -> return (startCat pgf) - Just cat -> case readType cat of - Nothing -> badRequest "Bad category" cat - Just typ -> return typ + case lookup "cat" q of + Nothing -> return (startCat pgf) + Just cat -> case readType cat of + Nothing -> badRequest "Bad category" cat + 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 - ,"word" .=showJSON w - ,"morpho".=showJSON [makeObj ["lemma".=l - ,"analysis".=a - ,"prob".=p] - | (l,a,p)<-ms] + showJSON [makeObj ["start" .=s + ,"word" .=w + ,"morpho".=[makeObj ["lemma".=l + ,"analysis".=a + ,"prob".=p] + | (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 - mlang <- getInput i - case mlang of - Just lang@(_:_) -> Just # readLang lang - _ -> return Nothing + getLang i = + case lookup i q of + Just lang -> fmap Just (readLang lang) + _ -> 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 - setHeader "Last-Modified" fmt - outputJSONP r + limit = + case lookup "limit" q of + 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" -badRequest = throw 400 +notFound = httpError 404 "Not found" +badRequest = httpError 400 -throw code msg extra = - 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 :: String -> String -> IO String 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) diff --git a/src/server/pgf-service.cabal b/src/server/pgf-service.cabal index f73911405..7df0b612d 100644 --- a/src/server/pgf-service.cabal +++ b/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, - httpd-shed>=0.4.0.2, + http-slim, mtl, - exceptions, json >= 0.3.3, - utf8-string >= 0.3.1.1, bytestring, pretty, random