src/server: refactoring to isolate dependencies on the cgi/fastcgi packages

* Introducing the module CGI, re-exporting a subset of the cgi package. It
  might complete replace the cgi package in the future.
* Introducing the module CGIUtils, containing functions from FastCGIUtils that
  have nothing to do with fastcgi.

Some low level hackery with unsafePerformIO and global variables was left
in FastCGIUtils, but it is actually not used, neither for gf -server nor
exec/pgf-fcgi.hs.

src/compiler/GFServer.hs

@@ -28,7 +28,7 @@ import Network.URI(URI(..))
 import Network.Shed.Httpd(initServer,Request(..),Response(..),noCache)
 --import qualified Network.FastCGI as FCGI -- from hackage direct-fastcgi
 import Network.CGI(handleErrors,liftIO)
-import FastCGIUtils(handleCGIErrors)--,outputJSONP,stderrToFile
+import CGIUtils(handleCGIErrors)--,outputJSONP,stderrToFile
 import Text.JSON(encode,showJSON,makeObj)
 --import System.IO.Silently(hCapture)
 import System.Process(readProcessWithExitCode)

src/example-based/ExampleService.hs

@@ -9,7 +9,7 @@ import PGF
 import GF.Compile.ToAPI
 import Network.CGI
 import Text.JSON
-import FastCGIUtils
+import CGIUtils
 import Cache
 import qualified ExampleDemo as E
 

src/server/CGI.hs

@@ -0,0 +1,11 @@
+-- | Isolate dependencies on the problematic cgi package to this module
+module CGI(module C) where
+import Network.CGI as C(
+       CGI,ContentType(..),Accept(..),Language(..),
+       getVarWithDefault,readInput,negotiate,requestAcceptLanguage,getInput,
+       setHeader,output,outputFPS,outputError,
+       handleErrors,catchCGI,throwCGI,
+       liftIO)
+import Network.CGI.Protocol as C(CGIResult(..),CGIRequest(..),Input(..),
+                                 Headers,HeaderName(..))
+import Network.CGI.Monad as C(runCGIT)

src/server/CGIUtils.hs

@@ -0,0 +1,103 @@
+{-# 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) where
+
+import Control.Exception(Exception(..),SomeException(..),throw)
+import Data.Dynamic(Typeable,cast)
+import Prelude hiding (catch)
+import System.IO(hPutStrLn,stderr)
+#ifndef mingw32_HOST_OS
+import System.Posix
+#endif
+
+import CGI(CGI,CGIResult,setHeader,output,outputFPS,outputError,
+           getInput,catchCGI,throwCGI)
+
+import Text.JSON
+import qualified Codec.Binary.UTF8.String as UTF8 (encodeString)
+import qualified Data.ByteString.Lazy as BS
+
+-- * 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 = throwCGI $ toException $ CGIError c m t
+
+handleCGIErrors :: CGI CGIResult -> CGI CGIResult
+handleCGIErrors x =
+    x `catchCGI` \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"
+       outputStrict ct $ UTF8.encodeString 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 = outputStrict "text/html; charset=utf-8" . UTF8.encodeString
+
+outputPlain :: String -> CGI CGIResult
+outputPlain = outputStrict "text/plain; charset=utf-8" . 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/FastCGIUtils.hs

@@ -1,35 +1,24 @@
-{-# LANGUAGE DeriveDataTypeable, CPP #-}
-module FastCGIUtils (--initFastCGI, loopFastCGI,
-                     throwCGIError, handleCGIErrors,
-                     stderrToFile,logError,
-                     outputJSONP,outputEncodedJSONP,
-                     outputPNG,outputBinary,
-                     outputHTML,outputPlain,
-                     splitBy) where
+{-# LANGUAGE CPP #-}
+module FastCGIUtils(initFastCGI,loopFastCGI) where
 
-import Control.Concurrent
-import Control.Exception
-import Control.Monad
-import Data.Dynamic
-import Data.IORef
+import Control.Concurrent(ThreadId,myThreadId)
+import Control.Exception(ErrorCall(..),throw,throwTo,catch)
+import Control.Monad(when,liftM,liftM2)
+import Data.IORef(IORef,newIORef,readIORef,writeIORef)
 import Prelude hiding (catch)
-import System.Environment
-import System.Exit
-import System.IO
-import System.IO.Unsafe
+import System.Environment(getArgs,getProgName)
+import System.Exit(ExitCode(..),exitWith)
+import System.IO(hPutStrLn,stderr)
+import System.IO.Unsafe(unsafePerformIO)
 #ifndef mingw32_HOST_OS
 import System.Posix
 #endif
 
---import Network.FastCGI
-import Network.CGI(CGI,CGIResult,setHeader,output,outputFPS,outputError,
-                   getInput,catchCGI,throwCGI)
+import Network.FastCGI
 
-import Text.JSON
-import qualified Codec.Binary.UTF8.String as UTF8 (encodeString)
-import qualified Data.ByteString.Lazy as BS
+import CGIUtils(logError)
 
-{- -- There are used in MorphoService.hs, but not in PGFService.hs
+ -- There are used in MorphoService.hs, but not in PGFService.hs
 initFastCGI :: IO ()
 initFastCGI = installSignalHandlers
 
@@ -40,11 +29,9 @@ loopFastCGI f =
            restartIfModified) 
          `catchAborted` logError "Request aborted"
        loopFastCGI f
--}
 
 -- Signal handling for FastCGI programs.
 
-
 #ifndef mingw32_HOST_OS
 installSignalHandlers :: IO ()
 installSignalHandlers =
@@ -121,89 +108,3 @@ restartIfModified :: IO ()
 restartIfModified = return ()
 #endif
 
--- Logging
-
-#ifndef mingw32_HOST_OS
-logError :: String -> IO ()
-logError s = hPutStrLn stderr s
-
-stderrToFile :: FilePath -> IO ()
-stderrToFile file =
-    do let mode = ownerReadMode `unionFileModes` ownerWriteMode `unionFileModes` groupReadMode `unionFileModes` otherReadMode
-       fileFd <- openFd file WriteOnly (Just mode) (defaultFileFlags { append = True })
-       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 = throwCGI $ toException $ CGIError c m t
-
-handleCGIErrors :: CGI CGIResult -> CGI CGIResult
-handleCGIErrors x =
-    x `catchCGI` \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"
-       outputStrict ct $ UTF8.encodeString str
-
-outputPNG :: BS.ByteString -> CGI CGIResult
-outputPNG x = do
-       setHeader "Content-Type" "image/png"
-       setXO
-       outputFPS x
-
-outputBinary :: BS.ByteString -> CGI CGIResult
-outputBinary x = do
-       setHeader "Content-Type" "application/binary"
-       setXO
-       outputFPS x
-
-outputHTML :: String -> CGI CGIResult
-outputHTML = outputStrict "text/html; charset=utf-8" . UTF8.encodeString
-
-outputPlain :: String -> CGI CGIResult
-outputPlain = outputStrict "text/plain; charset=utf-8" . 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
-
--- * General utilities
-
-splitBy :: (a -> Bool) -> [a] -> [[a]]
-splitBy _ [] = [[]]
-splitBy f list = case break f list of
-                   (first,[]) -> [first]
-                   (first,_:rest) -> first : splitBy f rest

src/server/PGFService.hs

@@ -7,7 +7,11 @@ import PGF (PGF)
 import qualified PGF
 import PGF.Lexing
 import Cache
-import FastCGIUtils
+import CGIUtils(outputJSONP,outputPlain,outputHTML,logError,outputBinary,
+                outputBinary',handleCGIErrors,throwCGIError,stderrToFile)
+import CGI(CGI,readInput,getInput,getVarWithDefault,
+           CGIResult,requestAcceptLanguage,handleErrors,setHeader,
+           Accept(..),Language(..),negotiate,liftIO)
 import URLEncoding
 
 #if C_RUNTIME
@@ -18,7 +22,6 @@ import qualified PGF2 as C
 import Data.Time.Clock(UTCTime)
 import Data.Time.Format(formatTime)
 import System.Locale(defaultTimeLocale,rfc822DateFormat)
-import Network.CGI
 import Text.JSON
 import Text.PrettyPrint as PP(render, text, (<+>))
 import qualified Codec.Binary.UTF8.String as UTF8 (decodeString)
@@ -687,9 +690,7 @@ outputGraphviz code =
        "gv" -> outputPlain code
        _ -> outputFPS' fmt =<< liftIO (pipeIt2graphviz fmt code)
   where
-    outputFPS' fmt bs =
-      do setHeader "Content-Type" (mimeType fmt)
-         outputFPS bs
+    outputFPS' = outputBinary' . mimeType
 
     mimeType fmt =
       case fmt of

src/server/RunHTTP.hs

@@ -1,9 +1,9 @@
 module RunHTTP(runHTTP,Options(..),cgiHandler) where
 import Network.URI(uriPath,uriQuery)
-import Network.CGI(ContentType(..))
-import Network.CGI.Protocol(CGIResult(..),CGIRequest(..),Input(..),
+import CGI(ContentType(..))
+import CGI(CGIResult(..),CGIRequest(..),Input(..),
                             Headers,HeaderName(..))
-import Network.CGI.Monad(runCGIT)
+import CGI(runCGIT)
 import Network.Shed.Httpd(initServer,Request(..),Response(..))
 import qualified Data.ByteString.Lazy.Char8 as BS(pack,unpack)
 import qualified Data.Map as M(fromList)

src/server/ServeStaticFile.hs

@@ -1,7 +1,7 @@
 module ServeStaticFile where
 import System.FilePath
 import System.Directory(doesDirectoryExist)
-import Network.CGI(setHeader,outputFPS,liftIO)
+import CGI(setHeader,outputFPS,liftIO)
 import qualified Data.ByteString.Lazy.Char8 as BS
 
 serveStaticFile path =

src/server/Setup.hs

@@ -4,7 +4,7 @@ import Control.Monad(when)
 import System.Directory(createDirectoryIfMissing,doesFileExist,
                         getDirectoryContents,copyFile,removeFile)
 import System.FilePath((</>))
-import System.Cmd(system)
+import System.Process(system)
 import System.Exit(ExitCode(..))
 
 import Distribution.Simple

src/server/exec/pgf-fcgi.hs

@@ -3,7 +3,7 @@ import Control.Concurrent(forkIO)
 import Network.FastCGI(runFastCGI,runFastCGIConcurrent')
 
 import PGFService(cgiMain,newPGFCache,stderrToFile,logFile)
-import System.IO
+
 main = do stderrToFile logFile
           fcgiMain =<< newPGFCache
 

src/server/gf-server.cabal

@@ -21,10 +21,13 @@ flag c-runtime
   Default:     False
 
 Library
-  exposed-modules: PGFService FastCGIUtils ServeStaticFile RunHTTP Cache
-  other-modules: URLEncoding Fold
+  exposed-modules: PGFService FastCGIUtils CGIUtils ServeStaticFile RunHTTP Cache
+  other-modules: URLEncoding CGI Fold
   hs-source-dirs: . transfer
 
+  build-depends: fastcgi >= 3001.0.2.2
+       -- Install it in Ubuntu with: apt-get install libghc-fastcgi-dev
+
   build-depends:   base >=4.2 && <5,
                    time, time-compat, old-locale,
                    directory,
@@ -41,6 +44,8 @@ Library
                    bytestring,
                    pretty,
                    random
+
+  ghc-options: -fwarn-unused-imports
   if os(windows)
     ghc-options: -optl-mwindows
   else
@@ -65,7 +70,7 @@ executable pgf-http
 executable pgf-service
   main-is: pgf-fcgi.hs
   Hs-source-dirs: exec
-  ghc-options: -threaded
+  ghc-options: -threaded -fwarn-unused-imports
   if impl(ghc>=7.0)
     ghc-options: -rtsopts