summaryrefslogtreecommitdiff
path: root/src/server
diff options
context:
space:
mode:
Diffstat (limited to 'src/server')
-rw-r--r--src/server/CGI.hs11
-rw-r--r--src/server/CGIUtils.hs103
-rw-r--r--src/server/FastCGIUtils.hs127
-rw-r--r--src/server/PGFService.hs11
-rw-r--r--src/server/RunHTTP.hs6
-rw-r--r--src/server/ServeStaticFile.hs2
-rw-r--r--src/server/Setup.hs2
-rw-r--r--src/server/exec/pgf-fcgi.hs2
-rw-r--r--src/server/gf-server.cabal11
9 files changed, 148 insertions, 127 deletions
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
-
-import Control.Concurrent
-import Control.Exception
-import Control.Monad
-import Data.Dynamic
-import Data.IORef
+{-# LANGUAGE CPP #-}
+module FastCGIUtils(initFastCGI,loopFastCGI) where
+
+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
generated by cgit v1.2.3 (git 2.39.1) at 2026-05-20 06:41:04 +0000