forked from GitHub/gf-core
hack for pgf-server for Windows
This commit is contained in:
@@ -1,4 +1,4 @@
|
|||||||
{-# LANGUAGE DeriveDataTypeable #-}
|
{-# LANGUAGE DeriveDataTypeable, CPP #-}
|
||||||
module FastCGIUtils (initFastCGI, loopFastCGI,
|
module FastCGIUtils (initFastCGI, loopFastCGI,
|
||||||
throwCGIError, handleCGIErrors,
|
throwCGIError, handleCGIErrors,
|
||||||
stderrToFile,
|
stderrToFile,
|
||||||
@@ -16,7 +16,9 @@ import System.Environment
|
|||||||
import System.Exit
|
import System.Exit
|
||||||
import System.IO
|
import System.IO
|
||||||
import System.IO.Unsafe
|
import System.IO.Unsafe
|
||||||
|
#ifndef mingw32_HOST_OS
|
||||||
import System.Posix
|
import System.Posix
|
||||||
|
#endif
|
||||||
import System.Time
|
import System.Time
|
||||||
|
|
||||||
import Network.FastCGI
|
import Network.FastCGI
|
||||||
@@ -40,6 +42,7 @@ loopFastCGI f =
|
|||||||
-- Signal handling for FastCGI programs.
|
-- Signal handling for FastCGI programs.
|
||||||
|
|
||||||
|
|
||||||
|
#ifndef mingw32_HOST_OS
|
||||||
installSignalHandlers :: IO ()
|
installSignalHandlers :: IO ()
|
||||||
installSignalHandlers =
|
installSignalHandlers =
|
||||||
do t <- myThreadId
|
do t <- myThreadId
|
||||||
@@ -48,15 +51,6 @@ installSignalHandlers =
|
|||||||
installHandler sigPIPE (Catch (requestAborted t)) Nothing
|
installHandler sigPIPE (Catch (requestAborted t)) Nothing
|
||||||
return ()
|
return ()
|
||||||
|
|
||||||
{-# NOINLINE shouldExit #-}
|
|
||||||
shouldExit :: IORef Bool
|
|
||||||
shouldExit = unsafePerformIO $ newIORef False
|
|
||||||
|
|
||||||
catchAborted :: IO a -> IO a -> IO a
|
|
||||||
catchAborted x y = x `catch` \e -> case e of
|
|
||||||
ErrorCall "**aborted**" -> y
|
|
||||||
_ -> throw e
|
|
||||||
|
|
||||||
requestAborted :: ThreadId -> IO ()
|
requestAborted :: ThreadId -> IO ()
|
||||||
requestAborted t = throwTo t (ErrorCall "**aborted**")
|
requestAborted t = throwTo t (ErrorCall "**aborted**")
|
||||||
|
|
||||||
@@ -68,6 +62,10 @@ gracefulExit :: IO ()
|
|||||||
gracefulExit =
|
gracefulExit =
|
||||||
do logError "Graceful exit"
|
do logError "Graceful exit"
|
||||||
writeIORef shouldExit True
|
writeIORef shouldExit True
|
||||||
|
#else
|
||||||
|
installSignalHandlers :: IO ()
|
||||||
|
installSignalHandlers = return ()
|
||||||
|
#endif
|
||||||
|
|
||||||
exitIfToldTo :: IO ()
|
exitIfToldTo :: IO ()
|
||||||
exitIfToldTo =
|
exitIfToldTo =
|
||||||
@@ -75,9 +73,18 @@ exitIfToldTo =
|
|||||||
when b $ do logError "Exiting..."
|
when b $ do logError "Exiting..."
|
||||||
exitWith ExitSuccess
|
exitWith ExitSuccess
|
||||||
|
|
||||||
|
{-# NOINLINE shouldExit #-}
|
||||||
|
shouldExit :: IORef Bool
|
||||||
|
shouldExit = unsafePerformIO $ newIORef False
|
||||||
|
|
||||||
|
catchAborted :: IO a -> IO a -> IO a
|
||||||
|
catchAborted x y = x `catch` \e -> case e of
|
||||||
|
ErrorCall "**aborted**" -> y
|
||||||
|
_ -> throw e
|
||||||
|
|
||||||
-- Restart handling for FastCGI programs.
|
-- Restart handling for FastCGI programs.
|
||||||
|
|
||||||
|
#ifndef mingw32_HOST_OS
|
||||||
{-# NOINLINE myModTimeRef #-}
|
{-# NOINLINE myModTimeRef #-}
|
||||||
myModTimeRef :: IORef EpochTime
|
myModTimeRef :: IORef EpochTime
|
||||||
myModTimeRef = unsafePerformIO (getProgModTime >>= newIORef)
|
myModTimeRef = unsafePerformIO (getProgModTime >>= newIORef)
|
||||||
@@ -106,8 +113,14 @@ restartIfModified =
|
|||||||
-- FIXME: setCurrentDirectory?
|
-- FIXME: setCurrentDirectory?
|
||||||
executeFile prog False args Nothing
|
executeFile prog False args Nothing
|
||||||
|
|
||||||
|
#else
|
||||||
|
restartIfModified :: IO ()
|
||||||
|
restartIfModified = return ()
|
||||||
|
#endif
|
||||||
|
|
||||||
-- Logging
|
-- Logging
|
||||||
|
|
||||||
|
#ifndef mingw32_HOST_OS
|
||||||
logError :: String -> IO ()
|
logError :: String -> IO ()
|
||||||
logError s = hPutStrLn stderr s
|
logError s = hPutStrLn stderr s
|
||||||
|
|
||||||
@@ -117,6 +130,13 @@ stderrToFile file =
|
|||||||
fileFd <- openFd file WriteOnly (Just mode) (defaultFileFlags { append = True })
|
fileFd <- openFd file WriteOnly (Just mode) (defaultFileFlags { append = True })
|
||||||
dupTo fileFd stdError
|
dupTo fileFd stdError
|
||||||
return ()
|
return ()
|
||||||
|
#else
|
||||||
|
logError :: String -> IO ()
|
||||||
|
logError s = return ()
|
||||||
|
|
||||||
|
stderrToFile :: FilePath -> IO ()
|
||||||
|
stderrToFile s = return ()
|
||||||
|
#endif
|
||||||
|
|
||||||
-- * General CGI Error exception mechanism
|
-- * General CGI Error exception mechanism
|
||||||
|
|
||||||
@@ -154,4 +174,4 @@ splitBy :: (a -> Bool) -> [a] -> [[a]]
|
|||||||
splitBy _ [] = [[]]
|
splitBy _ [] = [[]]
|
||||||
splitBy f list = case break f list of
|
splitBy f list = case break f list of
|
||||||
(first,[]) -> [first]
|
(first,[]) -> [first]
|
||||||
(first,_:rest) -> first : splitBy f rest
|
(first,_:rest) -> first : splitBy f rest
|
||||||
|
|||||||
@@ -9,7 +9,6 @@ synopsis: FastCGI Server for Grammatical Framework
|
|||||||
executable pgf.fcgi
|
executable pgf.fcgi
|
||||||
build-depends: base,
|
build-depends: base,
|
||||||
old-time,
|
old-time,
|
||||||
unix,
|
|
||||||
directory,
|
directory,
|
||||||
filepath,
|
filepath,
|
||||||
containers,
|
containers,
|
||||||
@@ -18,9 +17,13 @@ executable pgf.fcgi
|
|||||||
fastcgi >= 3001.0.2.1,
|
fastcgi >= 3001.0.2.1,
|
||||||
json >= 0.3.3,
|
json >= 0.3.3,
|
||||||
utf8-string >= 0.3.1.1
|
utf8-string >= 0.3.1.1
|
||||||
|
if !os(windows)
|
||||||
|
build-depends: unix
|
||||||
main-is: PGFService.hs
|
main-is: PGFService.hs
|
||||||
other-modules:
|
other-modules:
|
||||||
FastCGIUtils
|
FastCGIUtils
|
||||||
Cache
|
Cache
|
||||||
URLEncoding
|
URLEncoding
|
||||||
ghc-options: -threaded
|
ghc-options: -threaded
|
||||||
|
if os(windows)
|
||||||
|
ghc-options: -optl-mwindows
|
||||||
|
|||||||
Reference in New Issue
Block a user