pgf service: added a hook for external services

This is really reinventing CGI, people should learn how to write CGI scripts
instead...
TODO: better handling of temporary files

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."

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