diff options
Diffstat (limited to 'src/server')
| -rw-r--r-- | src/server/FastCGIUtils.hs | 19 | ||||
| -rw-r--r-- | src/server/PGFService.hs | 30 |
2 files changed, 43 insertions, 6 deletions
diff --git a/src/server/FastCGIUtils.hs b/src/server/FastCGIUtils.hs index f9e575df7..2abc66072 100644 --- a/src/server/FastCGIUtils.hs +++ b/src/server/FastCGIUtils.hs @@ -1,10 +1,11 @@ {-# LANGUAGE DeriveDataTypeable, CPP #-} module FastCGIUtils (--initFastCGI, loopFastCGI, throwCGIError, handleCGIErrors, - stderrToFile, - outputJSONP, + stderrToFile,logError, + outputJSONP,outputEncodedJSONP, outputPNG, outputHTML, + outputPlain, splitBy) where import Control.Concurrent @@ -160,11 +161,14 @@ handleCGIErrors x = x `catchCGI` \e -> case fromException e of -- * General CGI and JSON stuff outputJSONP :: JSON a => a -> CGI CGIResult -outputJSONP x = +outputJSONP = outputEncodedJSONP . encode + +outputEncodedJSONP :: String -> CGI CGIResult +outputEncodedJSONP json = do mc <- getInput "jsonp" let str = case mc of - Nothing -> encode x - Just c -> c ++ "(" ++ encode x ++ ")" + Nothing -> json + Just c -> c ++ "(" ++ json ++ ")" setHeader "Content-Type" "text/javascript; charset=utf-8" outputStrict $ UTF8.encodeString str @@ -178,6 +182,11 @@ outputHTML x = do setHeader "Content-Type" "text/html" outputStrict $ UTF8.encodeString x +outputPlain :: String -> CGI CGIResult +outputPlain x = do + setHeader "Content-Type" "text/plain" + outputStrict $ UTF8.encodeString x + outputStrict :: String -> CGI CGIResult outputStrict x | x == x = output x | otherwise = fail "I am the pope." diff --git a/src/server/PGFService.hs b/src/server/PGFService.hs index 2b872c18d..112d416a9 100644 --- a/src/server/PGFService.hs +++ b/src/server/PGFService.hs @@ -16,7 +16,7 @@ import qualified Codec.Binary.UTF8.String as UTF8 (decodeString) import qualified Data.ByteString.Lazy as BS import Control.Concurrent -import Control.Exception +import Control.Exception(evaluate) import Control.Monad import Data.Char import Data.Function (on) @@ -27,6 +27,7 @@ import System.Random import System.Process import System.Exit import System.IO +import System.Directory(removeFile) logFile :: FilePath logFile = "pgf-error.log" @@ -65,6 +66,9 @@ pgfMain pgf command = do "parsetree" -> getTree >>= \t -> getFrom >>= \(Just l) -> liftIO (doGraphvizParseTree pgf l t) >>= outputPNG "alignment" -> getTree >>= liftIO . doGraphvizAlignment pgf >>= outputPNG "browse" -> outputHTML =<< doBrowse pgf `fmap` getId `ap` getCSSClass `ap` getHRef + "external" -> do cmd <- getInput "external" + input <- getText + doExternal cmd input _ -> throwCGIError 400 "Unknown command" ["Unknown command: " ++ show command] where getText :: CGI String @@ -127,6 +131,30 @@ pgfMain pgf command = do Just lang | lang `elem` PGF.languages pgf -> return $ Just lang | otherwise -> throwCGIError 400 "Unknown language" ["Unknown language: " ++ l] +-- Hook for simple extensions of the PGF service +doExternal Nothing input = throwCGIError 400 "Unknown external command" ["Unknown external command"] +doExternal (Just cmd) input = + do liftIO $ logError ("External command: "++cmd) + cmds <- liftIO $ (readIO =<< readFile "external_services") + `catch` const (return []) + liftIO $ logError ("External services: "++show cmds) + maybe err ok (lookup cmd cmds) + where + err = throwCGIError 400 "Unknown external command" ["Unknown external command: "++cmd] + ok output_type = + do let tmpfile1 = "external_input.txt" + tmpfile2 = "external_output.txt" + liftIO $ writeFile "external_input.txt" input + liftIO $ system $ cmd ++ " " ++ tmpfile1 ++ " > " ++ tmpfile2 + liftIO $ removeFile tmpfile1 + r <- case output_type of + "jsonp" -> outputEncodedJSONP =<< liftIO (readFile tmpfile2) + "image/png" -> outputPNG =<< liftIO (BS.readFile tmpfile2) + "text/html" -> outputHTML =<< liftIO (readFile tmpfile2) + _ -> outputPlain =<< liftIO (readFile tmpfile2) + liftIO $ removeFile tmpfile2 + return r + doTranslate :: PGF -> String -> Maybe PGF.Type -> Maybe PGF.Language -> Maybe PGF.Language -> JSValue doTranslate pgf input mcat mfrom mto = showJSON |