mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-04-09 04:59:31 -06:00
hack for pgf-server for Windows
This commit is contained in:
@@ -1,4 +1,4 @@
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
{-# LANGUAGE DeriveDataTypeable, CPP #-}
|
||||
module FastCGIUtils (initFastCGI, loopFastCGI,
|
||||
throwCGIError, handleCGIErrors,
|
||||
stderrToFile,
|
||||
@@ -16,7 +16,9 @@ import System.Environment
|
||||
import System.Exit
|
||||
import System.IO
|
||||
import System.IO.Unsafe
|
||||
#ifndef mingw32_HOST_OS
|
||||
import System.Posix
|
||||
#endif
|
||||
import System.Time
|
||||
|
||||
import Network.FastCGI
|
||||
@@ -40,6 +42,7 @@ loopFastCGI f =
|
||||
-- Signal handling for FastCGI programs.
|
||||
|
||||
|
||||
#ifndef mingw32_HOST_OS
|
||||
installSignalHandlers :: IO ()
|
||||
installSignalHandlers =
|
||||
do t <- myThreadId
|
||||
@@ -48,15 +51,6 @@ installSignalHandlers =
|
||||
installHandler sigPIPE (Catch (requestAborted t)) Nothing
|
||||
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 t = throwTo t (ErrorCall "**aborted**")
|
||||
|
||||
@@ -68,6 +62,10 @@ gracefulExit :: IO ()
|
||||
gracefulExit =
|
||||
do logError "Graceful exit"
|
||||
writeIORef shouldExit True
|
||||
#else
|
||||
installSignalHandlers :: IO ()
|
||||
installSignalHandlers = return ()
|
||||
#endif
|
||||
|
||||
exitIfToldTo :: IO ()
|
||||
exitIfToldTo =
|
||||
@@ -75,9 +73,18 @@ exitIfToldTo =
|
||||
when b $ do logError "Exiting..."
|
||||
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.
|
||||
|
||||
#ifndef mingw32_HOST_OS
|
||||
{-# NOINLINE myModTimeRef #-}
|
||||
myModTimeRef :: IORef EpochTime
|
||||
myModTimeRef = unsafePerformIO (getProgModTime >>= newIORef)
|
||||
@@ -106,8 +113,14 @@ restartIfModified =
|
||||
-- FIXME: setCurrentDirectory?
|
||||
executeFile prog False args Nothing
|
||||
|
||||
#else
|
||||
restartIfModified :: IO ()
|
||||
restartIfModified = return ()
|
||||
#endif
|
||||
|
||||
-- Logging
|
||||
|
||||
#ifndef mingw32_HOST_OS
|
||||
logError :: String -> IO ()
|
||||
logError s = hPutStrLn stderr s
|
||||
|
||||
@@ -117,6 +130,13 @@ stderrToFile file =
|
||||
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
|
||||
|
||||
@@ -154,4 +174,4 @@ splitBy :: (a -> Bool) -> [a] -> [[a]]
|
||||
splitBy _ [] = [[]]
|
||||
splitBy f list = case break f list of
|
||||
(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
|
||||
build-depends: base,
|
||||
old-time,
|
||||
unix,
|
||||
directory,
|
||||
filepath,
|
||||
containers,
|
||||
@@ -18,9 +17,13 @@ executable pgf.fcgi
|
||||
fastcgi >= 3001.0.2.1,
|
||||
json >= 0.3.3,
|
||||
utf8-string >= 0.3.1.1
|
||||
if !os(windows)
|
||||
build-depends: unix
|
||||
main-is: PGFService.hs
|
||||
other-modules:
|
||||
FastCGIUtils
|
||||
Cache
|
||||
URLEncoding
|
||||
ghc-options: -threaded
|
||||
if os(windows)
|
||||
ghc-options: -optl-mwindows
|
||||
|
||||
Reference in New Issue
Block a user