1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
|
{-# LANGUAGE DeriveDataTypeable #-}
module FastCGIUtils (initFastCGI, loopFastCGI,
DataRef, newDataRef, getData,
throwCGIError, handleCGIErrors) where
import Control.Concurrent
import Control.Exception
import Control.Monad
import Data.Dynamic
import Data.IORef
import Prelude hiding (catch)
import System.Directory
import System.Environment
import System.Exit
import System.IO
import System.IO.Unsafe
import System.Posix
import System.Time
import Network.FastCGI
initFastCGI :: IO ()
initFastCGI = installSignalHandlers
loopFastCGI :: CGI CGIResult -> IO ()
loopFastCGI f =
do (do runOneFastCGI f
exitIfToldTo
restartIfModified)
`catchAborted` logError "Request aborted"
loopFastCGI f
-- Signal handling for FastCGI programs.
installSignalHandlers :: IO ()
installSignalHandlers =
do t <- myThreadId
installHandler sigUSR1 (Catch gracefulExit) Nothing
installHandler sigTERM (Catch gracelessExit) Nothing
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**")
gracelessExit :: IO ()
gracelessExit = do logError "Graceless exit"
exitWith ExitSuccess
gracefulExit :: IO ()
gracefulExit =
do logError "Graceful exit"
writeIORef shouldExit True
exitIfToldTo :: IO ()
exitIfToldTo =
do b <- readIORef shouldExit
when b $ do logError "Exiting..."
exitWith ExitSuccess
-- Restart handling for FastCGI programs.
{-# NOINLINE myModTimeRef #-}
myModTimeRef :: IORef EpochTime
myModTimeRef = unsafePerformIO (getProgModTime >>= newIORef)
-- FIXME: doesn't get directory
myProgPath :: IO FilePath
myProgPath = getProgName
getProgModTime :: IO EpochTime
getProgModTime = liftM modificationTime (myProgPath >>= getFileStatus)
needsRestart :: IO Bool
needsRestart = liftM2 (/=) (readIORef myModTimeRef) getProgModTime
exitIfModified :: IO ()
exitIfModified =
do restart <- needsRestart
when restart $ exitWith ExitSuccess
restartIfModified :: IO ()
restartIfModified =
do restart <- needsRestart
when restart $ do prog <- myProgPath
args <- getArgs
hPutStrLn stderr $ prog ++ " has been modified, restarting ..."
-- FIXME: setCurrentDirectory?
executeFile prog False args Nothing
-- Utilities for getting and caching read-only data from disk.
-- The data is reloaded when the file on disk has been modified.
type DataRef a = IORef (Maybe (ClockTime, a))
newDataRef :: MonadIO m => m (DataRef a)
newDataRef = liftIO $ newIORef Nothing
getData :: MonadIO m => (FilePath -> m a) -> DataRef a -> FilePath -> m a
getData loadData ref file =
do t' <- liftIO $ getModificationTime file
m <- liftIO $ readIORef ref
case m of
Just (t,x) | t' == t -> return x
_ -> do logCGI $ "Loading " ++ show file ++ "..."
x <- loadData file
liftIO $ writeIORef ref (Just (t',x))
return x
-- Logging
logError :: String -> IO ()
logError s = hPutStrLn stderr s
-- * General CGI Error exception mechanism
data CGIError = CGIError { cgiErrorCode :: Int, cgiErrorMessage :: String, cgiErrorText :: [String] }
deriving Typeable
throwCGIError :: Int -> String -> [String] -> CGI a
throwCGIError c m t = throwCGI $ DynException $ toDyn $ CGIError c m t
handleCGIErrors :: CGI CGIResult -> CGI CGIResult
handleCGIErrors x = x `catchCGI` \e -> case e of
DynException d -> case fromDynamic d of
Nothing -> throw e
Just (CGIError c m t) -> outputError c m t
_ -> throw e
|
