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
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
|
{-# LANGUAGE DeriveDataTypeable, CPP #-}
module FastCGIUtils (initFastCGI, loopFastCGI,
throwCGIError, handleCGIErrors,
stderrToFile,
outputJSONP,
outputPNG,
outputHTML,
splitBy) 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
#ifndef mingw32_HOST_OS
import System.Posix
#endif
import System.Time
import Network.FastCGI
import Text.JSON
import qualified Codec.Binary.UTF8.String as UTF8 (encodeString, decodeString)
import qualified Data.ByteString.Lazy as BS
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.
#ifndef mingw32_HOST_OS
installSignalHandlers :: IO ()
installSignalHandlers =
do t <- myThreadId
installHandler sigUSR1 (Catch gracefulExit) Nothing
installHandler sigTERM (Catch gracelessExit) Nothing
installHandler sigPIPE (Catch (requestAborted t)) Nothing
return ()
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
#else
installSignalHandlers :: IO ()
installSignalHandlers = return ()
#endif
exitIfToldTo :: IO ()
exitIfToldTo =
do b <- readIORef shouldExit
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)
-- 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
#else
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) -> outputError c m t
-- * General CGI and JSON stuff
outputJSONP :: JSON a => a -> CGI CGIResult
outputJSONP x =
do mc <- getInput "jsonp"
let str = case mc of
Nothing -> encode x
Just c -> c ++ "(" ++ encode x ++ ")"
setHeader "Content-Type" "text/json; charset=utf-8"
outputStrict $ UTF8.encodeString str
outputPNG :: BS.ByteString -> CGI CGIResult
outputPNG x = do
setHeader "Content-Type" "image/png"
outputFPS x
outputHTML :: String -> CGI CGIResult
outputHTML x = do
setHeader "Content-Type" "text/html"
outputStrict x
outputStrict :: String -> CGI CGIResult
outputStrict x | x == x = output x
| otherwise = fail "I am the pope."
-- * General utilities
splitBy :: (a -> Bool) -> [a] -> [[a]]
splitBy _ [] = [[]]
splitBy f list = case break f list of
(first,[]) -> [first]
(first,_:rest) -> first : splitBy f rest
|
