From e0e6079c9141a0c2d7d2a6dda50496e237bfc8bb Mon Sep 17 00:00:00 2001 From: hallgren Date: Tue, 2 Sep 2014 12:27:47 +0000 Subject: [PATCH] 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 | 2 +- src/example-based/ExampleService.hs | 2 +- src/server/CGI.hs | 11 +++ src/server/CGIUtils.hs | 103 +++++++++++++++++++++++ src/server/FastCGIUtils.hs | 125 +++------------------------- src/server/PGFService.hs | 11 +-- src/server/RunHTTP.hs | 6 +- src/server/ServeStaticFile.hs | 2 +- src/server/Setup.hs | 2 +- src/server/exec/pgf-fcgi.hs | 2 +- src/server/gf-server.cabal | 11 ++- 11 files changed, 149 insertions(+), 128 deletions(-) create mode 100644 src/server/CGI.hs create mode 100644 src/server/CGIUtils.hs diff --git a/src/compiler/GFServer.hs b/src/compiler/GFServer.hs index 049891b54..a74167b9a 100644 --- a/src/compiler/GFServer.hs +++ b/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) diff --git a/src/example-based/ExampleService.hs b/src/example-based/ExampleService.hs index 0e88ef414..28d3731d4 100644 --- a/src/example-based/ExampleService.hs +++ b/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 diff --git a/src/server/CGI.hs b/src/server/CGI.hs new file mode 100644 index 000000000..1a77351e2 --- /dev/null +++ b/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) diff --git a/src/server/CGIUtils.hs b/src/server/CGIUtils.hs new file mode 100644 index 000000000..ba41dc180 --- /dev/null +++ b/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 diff --git a/src/server/FastCGIUtils.hs b/src/server/FastCGIUtils.hs index e65987b6d..5a61d5282 100644 --- a/src/server/FastCGIUtils.hs +++ b/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 diff --git a/src/server/PGFService.hs b/src/server/PGFService.hs index 316509d1f..2a73462ff 100644 --- a/src/server/PGFService.hs +++ b/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 diff --git a/src/server/RunHTTP.hs b/src/server/RunHTTP.hs index 2b4627add..9f46b1a6f 100644 --- a/src/server/RunHTTP.hs +++ b/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) diff --git a/src/server/ServeStaticFile.hs b/src/server/ServeStaticFile.hs index 4e2dd96e0..9e3b8a19a 100644 --- a/src/server/ServeStaticFile.hs +++ b/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 = diff --git a/src/server/Setup.hs b/src/server/Setup.hs index f0e23432c..1ef4756c0 100644 --- a/src/server/Setup.hs +++ b/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 diff --git a/src/server/exec/pgf-fcgi.hs b/src/server/exec/pgf-fcgi.hs index 3b5b0b3cf..547f263c3 100644 --- a/src/server/exec/pgf-fcgi.hs +++ b/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 diff --git a/src/server/gf-server.cabal b/src/server/gf-server.cabal index 03f418063..bfe8cf346 100644 --- a/src/server/gf-server.cabal +++ b/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