@@ -0,0 +1,392 @@
1+{-# LANGUAGE ForeignFunctionInterface #-}
2+{-# LANGUAGE EmptyDataDecls #-}
3+-----------------------------------------------------------------------------
4+-- |
5+-- Module : Network.Wai.Handler.FastCGI
6+-- Copyright : (c) Bjorn Bringert 2004-2005, (c) Lemmih 2006
7+-- License : BSD-style (see the file libraries/network/LICENSE)
8+--
9+-- Maintainer : michael@snoyman.com
10+-- Stability : experimental
11+-- Portability : non-portable (uses FFI)
12+--
13+-- Interface for FastCGI <http://fastcgi.com/>, using the fcgiapp API.
14+-- Totally ripped off by Michael Snoyman to work with Hack, then WAI.
15+--
16+-----------------------------------------------------------------------------
17+module Network.Wai.Handler.FastCGI
18+ (
19+ -- * Single-threaded interface
20+ runFastCGIorCGI
21+ , runOneFastCGIorCGI
22+ , runFastCGI
23+ , runOneFastCGI
24+ -- * Concurrent interface
25+ , runFastCGIConcurrent
26+ , runFastCGIConcurrent'
27+ ) where
28+
29+import Data.Maybe
30+import Data.ByteString.Lazy.Internal (defaultChunkSize)
31+import Control.Concurrent ( forkOS )
32+import Control.Concurrent.MVar
33+import Control.Concurrent.QSem
34+import Control.Exception as Exception (catch, finally)
35+import Control.Monad ( liftM )
36+import Data.Word (Word8)
37+import Foreign ( Ptr, castPtr, nullPtr, peekArray0
38+ , alloca, mallocBytes, free, throwIfNeg_)
39+import Foreign.C ( CInt, CString, CStringLen
40+ , peekCString )
41+import Foreign.Storable ( Storable (..) )
42+import System.IO.Unsafe (unsafeInterleaveIO,unsafePerformIO)
43+
44+import qualified Network.Wai as W
45+import qualified Network.Wai.Enumerator as WE
46+import qualified Network.Wai.Source as WS
47+import qualified Network.Wai.Handler.CGI as CGI
48+
49+import qualified Data.ByteString as BS
50+import qualified Data.ByteString.Char8 as B8
51+import qualified Data.ByteString.Lazy.Char8 as Lazy
52+#if __GLASGOW_HASKELL__ >= 608
53+import qualified Data.ByteString.Internal as BSB
54+import qualified Data.ByteString.Unsafe as BSB
55+#else
56+import qualified Data.ByteString.Base as BSB
57+#endif
58+
59+-- For debugging
60+import Control.Concurrent ( myThreadId )
61+import Prelude hiding ( log, catch )
62+import System.IO ( hPutStrLn, stderr )
63+import qualified System.IO
64+import Control.Arrow ((***))
65+import Data.Char (toLower)
66+
67+#include <fcgiapp.h>
68+
69+------------------------------------------------------------------------
70+
71+data FCGX_Stream
72+type StreamPtr = Ptr FCGX_Stream
73+type Environ = Ptr CString
74+
75+------------------------------------------------------------------------
76+
77+foreign import ccall unsafe "fcgiapp.h FCGX_IsCGI" fcgx_isCGI
78+ :: IO CInt
79+
80+foreign import ccall unsafe "fcgiapp.h FCGX_GetStr" fcgx_getStr
81+ :: CString -> CInt -> StreamPtr -> IO CInt
82+
83+foreign import ccall unsafe "fcgiapp.h FCGX_PutStr" fcgx_putStr
84+ :: CString -> CInt -> StreamPtr -> IO CInt
85+
86+foreign import ccall threadsafe "fcgiapp.h FCGX_Accept" fcgx_accept
87+ :: Ptr StreamPtr -> Ptr StreamPtr -> Ptr StreamPtr -> Ptr Environ -> IO CInt
88+foreign import ccall unsafe "fcgiapp.h FCGX_Finish" fcgx_finish
89+ :: IO ()
90+
91+------------------------------------------------------------------------
92+
93+-- | Handle a single CGI request, or FastCGI requests in an infinite loop.
94+-- This function only returns normally if it was a CGI request.
95+-- This lets you use the same program
96+-- as either a FastCGI or CGI program, depending on what the server
97+-- treats it as.
98+runFastCGIorCGI :: W.Application -> IO ()
99+runFastCGIorCGI f = do fcgi <- runOneFastCGIorCGI f
100+ if fcgi then runFastCGIorCGI f
101+ else return ()
102+
103+-- | Handle a single FastCGI or CGI request. This lets you use the same program
104+-- as either a FastCGI or CGI program, depending on what the server
105+-- treats it as.
106+runOneFastCGIorCGI :: W.Application
107+ -> IO Bool -- ^ True if it was a FastCGI request,
108+ -- False if CGI.
109+runOneFastCGIorCGI f =
110+ do x <- fcgx_isCGI
111+ if x /= 0 then CGI.run f >> return False
112+ else runOneFastCGI f >> return True
113+
114+-- | Handle FastCGI requests in an infinite loop.
115+runFastCGI :: W.Application -> IO ()
116+runFastCGI f = runOneFastCGI f >> runFastCGI f
117+
118+-- | Handle a single FastCGI request.
119+runOneFastCGI :: W.Application -> IO ()
120+runOneFastCGI f = do
121+ alloca (\inp ->
122+ alloca (\outp ->
123+ alloca (\errp ->
124+ alloca (\envp ->
125+ oneRequest f inp outp errp envp))))
126+
127+oneRequest :: W.Application
128+ -> Ptr StreamPtr
129+ -> Ptr StreamPtr
130+ -> Ptr StreamPtr
131+ -> Ptr Environ
132+ -> IO ()
133+oneRequest f inp outp errp envp =
134+ do
135+ testReturn "FCGX_Accept" $ fcgx_accept inp outp errp envp
136+ ins <- peek inp
137+ outs <- peek outp
138+ errs <- peek errp
139+ env <- peek envp
140+ handleRequest f ins outs errs env
141+ fcgx_finish
142+
143+handleRequest :: W.Application
144+ -> StreamPtr
145+ -> StreamPtr
146+ -> StreamPtr
147+ -> Environ
148+ -> IO ()
149+handleRequest f ins outs _errs env =
150+ do
151+ vars <- environToTable env
152+ input <- sRead ins
153+ let hPut = sPutStr' outs
154+ run' vars input hPut f
155+
156+
157+
158+data FCGX_Request
159+
160+foreign import ccall unsafe "fcgiapp.h FCGX_Init" fcgx_init
161+ :: IO CInt
162+
163+foreign import ccall unsafe "fcgiapp.h FCGX_InitRequest" fcgx_initrequest
164+ :: Ptr FCGX_Request -> CInt -> CInt -> IO CInt
165+
166+foreign import ccall threadsafe "fcgiapp.h FCGX_Accept_r" fcgx_accept_r
167+ :: Ptr FCGX_Request -> IO CInt
168+
169+foreign import ccall unsafe "fcgiapp.h FCGX_Finish_r" fcgx_finish_r
170+ :: Ptr FCGX_Request -> IO ()
171+
172+-- | Like 'Network.CGI.runCGI', but uses the FastCGI interface
173+-- and forks off a new thread (using 'forkOS') for every request.
174+runFastCGIConcurrent :: Int -- ^ Max number of concurrent threads.
175+ -> W.Application -> IO ()
176+runFastCGIConcurrent = runFastCGIConcurrent' forkOS
177+
178+runFastCGIConcurrent' :: (IO () -> IO a) -- ^ How to fork a request.
179+ -> Int -- ^ Max number of concurrent threads.
180+ -> W.Application -> IO ()
181+
182+runFastCGIConcurrent' fork m f
183+ = do qsem <- newQSem m
184+ testReturn "FCGX_Init" $ fcgx_init
185+ let loop = do waitQSem qsem
186+ reqp <- acceptRequest
187+ fork (oneRequestMT f reqp
188+ `finally`
189+ (finishRequest reqp >> signalQSem qsem))
190+ loop
191+ loop -- FIXME `catch` \e -> log (show e)
192+
193+oneRequestMT :: W.Application -> Ptr FCGX_Request -> IO ()
194+oneRequestMT app r = do
195+ env <- peekEnvp r
196+ vars <- environToTable env
197+ ins <- peekIn r
198+ input <- sRead ins
199+ outs <- peekOut r
200+ let hPut = sPutStr' outs
201+ run' vars input hPut app
202+--
203+-- * FCGX_Reqest struct
204+--
205+
206+acceptRequest :: IO (Ptr FCGX_Request)
207+acceptRequest = do
208+ reqp <- mallocBytes (#size FCGX_Request)
209+ initAndAccept reqp
210+ return reqp
211+ where initAndAccept reqp = do
212+ testReturn "FCGX_InitRequest" $ fcgx_initrequest reqp 0 0
213+ testReturn "FCGX_Accept_r" $ fcgx_accept_r reqp
214+
215+finishRequest :: Ptr FCGX_Request -> IO ()
216+finishRequest reqp = do
217+ fcgx_finish_r reqp
218+ free reqp
219+
220+peekIn, peekOut, _peekErr :: Ptr FCGX_Request -> IO (Ptr FCGX_Stream)
221+peekIn = (#peek FCGX_Request, in)
222+peekOut = (#peek FCGX_Request, out)
223+_peekErr = (#peek FCGX_Request, err)
224+
225+peekEnvp :: Ptr FCGX_Request -> IO Environ
226+peekEnvp = (#peek FCGX_Request, envp)
227+
228+
229+--
230+-- * Stream IO
231+--
232+
233+sPutStr' :: StreamPtr -> BS.ByteString -> IO ()
234+sPutStr' h str =
235+ BSB.unsafeUseAsCStringLen str $ fcgxPutCStringLen h
236+
237+sPutStr :: StreamPtr -> Lazy.ByteString -> IO ()
238+sPutStr h str =
239+ mapM_ (flip BSB.unsafeUseAsCStringLen (fcgxPutCStringLen h)) (Lazy.toChunks str)
240+
241+fcgxPutCStringLen :: StreamPtr -> CStringLen -> IO ()
242+fcgxPutCStringLen h (cs,len) =
243+ testReturn "FCGX_PutStr" $ fcgx_putStr cs (fromIntegral len) h
244+
245+sRead :: StreamPtr -> IO Lazy.ByteString
246+sRead h = buildByteString (fcgxGetBuf h) 4096
247+
248+fcgxGetBuf :: StreamPtr -> Ptr a -> Int -> IO Int
249+fcgxGetBuf h p c =
250+ liftM fromIntegral $ fcgx_getStr (castPtr p) (fromIntegral c) h
251+
252+--
253+-- * ByteString utilities
254+--
255+
256+-- | Data.ByteString.Lazy.hGetContentsN generalized to arbitrary
257+-- reading functions.
258+buildByteString :: (Ptr Word8 -> Int -> IO Int) -> Int -> IO Lazy.ByteString
259+buildByteString f k = lazyRead >>= return . Lazy.fromChunks
260+ where
261+ lazyRead = unsafeInterleaveIO $ do
262+ ps <- BSB.createAndTrim k $ \p -> f p k
263+ case BS.length ps of
264+ 0 -> return []
265+ n | n < k -> return [ps]
266+ _ -> do pss <- lazyRead
267+ return (ps : pss)
268+
269+--
270+-- * Utilities
271+--
272+
273+testReturn :: String -> IO CInt -> IO ()
274+testReturn e = throwIfNeg_ (\n -> e ++ " failed with error code: "++ show n)
275+
276+environToTable :: Environ -> IO [(String,String)]
277+environToTable arr =
278+ do css <- peekArray0 nullPtr arr
279+ ss <- mapM peekCString css
280+ return $ map (splitBy '=') ss
281+
282+-- | Split a list at the first occurence of a marker.
283+-- Do not include the marker in any of the resulting lists.
284+-- If the marker does not occur in the list, the entire
285+-- input with be in the first list.
286+splitBy :: Eq a => a -> [a] -> ([a],[a])
287+splitBy x xs = (y, drop 1 z)
288+ where (y,z) = break (==x) xs
289+
290+--
291+-- * Debugging
292+--
293+
294+{-# NOINLINE logMutex #-}
295+logMutex :: MVar ()
296+logMutex = unsafePerformIO (newMVar ())
297+
298+log :: String -> IO ()
299+log msg = do
300+ t <- myThreadId
301+ withMVar logMutex (const $ hPutStrLn stderr (show t ++ ": " ++ msg))
302+
303+run' :: [(String, String)] -- ^ all variables
304+ -> Lazy.ByteString -- ^ responseBody of input
305+ -> (BS.ByteString -> IO ()) -- ^ destination for output
306+ -> W.Application
307+ -> IO ()
308+run' vars inputH hPut app = do
309+ let rmethod = safeRead W.GET $ lookup' "REQUEST_METHOD" vars
310+ pinfo = lookup' "PATH_INFO" vars
311+ qstring = lookup' "QUERY_STRING" vars
312+ servername = lookup' "SERVER_NAME" vars
313+ serverport = safeRead 80 $ lookup' "SERVER_PORT" vars
314+ contentLength = safeRead 0 $ lookup' "CONTENT_LENGTH" vars
315+ remoteHost' =
316+ case lookup "REMOTE_HOST" vars of
317+ Just x -> x
318+ Nothing ->
319+ case lookup "REMOTE_ADDR" vars of
320+ Just x -> x
321+ Nothing -> ""
322+ urlScheme' =
323+ case map toLower $ lookup' "SERVER_PROTOCOL" vars of
324+ "https" -> W.HTTPS
325+ _ -> W.HTTP
326+ let env = W.Request
327+ { W.requestMethod = rmethod
328+ , W.pathInfo = B8.pack pinfo
329+ , W.queryString = B8.pack qstring
330+ , W.serverName = B8.pack servername
331+ , W.serverPort = serverport
332+ , W.requestHeaders = map (cleanupVarName *** B8.pack) vars
333+ , W.urlScheme = urlScheme'
334+ , W.requestBody = requestBodyLBS inputH contentLength
335+ , W.errorHandler = System.IO.hPutStr System.IO.stderr
336+ , W.remoteHost = B8.pack remoteHost'
337+ , W.httpVersion = W.HttpVersion BS.empty
338+ }
339+ res <- app env
340+ let h = W.responseHeaders res
341+ let h' = case lookup W.ContentType h of
342+ Nothing -> (W.ContentType, B8.pack "text/html; charset=utf-8")
343+ : h
344+ Just _ -> h
345+ hPut $ B8.pack $ "Status: " ++ (show $ W.statusCode $ W.status res) ++ " "
346+ hPut $ W.statusMessage $ W.status res
347+ hPut $ B8.singleton '\n'
348+ mapM_ (printHeader hPut) h'
349+ hPut $ B8.singleton '\n'
350+ _ <- W.runEnumerator (WE.fromEitherFile (W.responseBody res)) (myPut hPut) ()
351+ return ()
352+
353+myPut :: (BS.ByteString -> IO ()) -> () -> BS.ByteString -> IO (Either () ())
354+myPut output () bs = output bs >> return (Right ())
355+
356+printHeader :: (BS.ByteString -> IO ())
357+ -> (W.ResponseHeader, BS.ByteString)
358+ -> IO ()
359+printHeader f (x, y) = do
360+ f $ W.responseHeaderToBS x
361+ f $ B8.pack ": "
362+ f y
363+ f $ B8.singleton '\n'
364+
365+cleanupVarName :: String -> W.RequestHeader
366+cleanupVarName ('H':'T':'T':'P':'_':a:as) =
367+ W.requestHeaderFromBS $ B8.pack $ a : helper' as where
368+ helper' ('_':x:rest) = '-' : x : helper' rest
369+ helper' (x:rest) = toLower x : helper' rest
370+ helper' [] = []
371+cleanupVarName "CONTENT_TYPE" = W.ReqContentType
372+cleanupVarName "CONTENT_LENGTH" = W.ReqContentLength
373+cleanupVarName "SCRIPT_NAME" = W.requestHeaderFromBS $ B8.pack "CGI-Script-Name"
374+cleanupVarName x = W.requestHeaderFromBS $ B8.pack x -- FIXME remove?
375+
376+requestBodyLBS :: Lazy.ByteString -> Int -> W.Source
377+requestBodyLBS l len = go (Lazy.toChunks l) len
378+ where
379+ go _ 0 = W.Source $ return Nothing
380+ go (l:ls) len =
381+ let len' = len - BS.length l
382+ len'' = if len' < 0 then 0 else len'
383+ in W.Source $ return $ Just (l, go ls len'')
384+
385+lookup' :: String -> [(String, String)] -> String
386+lookup' key pairs = fromMaybe "" $ lookup key pairs
387+
388+safeRead :: Read a => a -> String -> a
389+safeRead d s =
390+ case reads s of
391+ ((x, _):_) -> x
392+ [] -> d