@@ -1,12 +1,11 @@
11{-# LANGUAGE ForeignFunctionInterface #-}
22{-# LANGUAGE EmptyDataDecls #-}
3−{-# LANGUAGE OverloadedStrings #-}
43-----------------------------------------------------------------------------
54-- |
65-- Module : Network.Wai.Handler.FastCGI
7−-- Copyright : (c) Bjorn Bringert 2004-2005, (c) Lemmih 2006
6+-- Copyright : (c) Bjorn Bringert 2004-2005, (c) Lemmih 2006, (c) Michael Snoyman 2010
87-- License : BSD-style (see the file libraries/network/LICENSE)
9−--
8+--
109-- Maintainer : michael@snoyman.com
1110-- Stability : experimental
1211-- Portability : non-portable (uses FFI)
@@ -18,15 +17,16 @@
1817module Network.Wai.Handler.FastCGI
1918 ( run
2019 , runSendfile
20+ , runFork
2121 ) where
2222
23−import Data.Maybe
24−import Control.Monad ( liftM )
23+import Control.Monad ( liftM, forever )
2524import Data.Word (Word8)
2625import Foreign ( Ptr, castPtr, nullPtr, peekArray0
27− , alloca, throwIfNeg_)
26+ , throwIfNeg_, mallocBytes, free )
2827import Foreign.C ( CInt, CString, CStringLen
2928 , peekCString )
29+import Control.Exception (finally)
3030import Foreign.Storable ( Storable (..) )
3131
3232import qualified Network.Wai as W
@@ -34,15 +34,8 @@ import qualified Network.Wai.Handler.CGI as CGI
3434import qualified Network.Wai.Handler.Helper as CGI
3535
3636import qualified Data.ByteString as BS
37−#if __GLASGOW_HASKELL__ >= 608
3837import qualified Data.ByteString.Internal as BSB
3938import qualified Data.ByteString.Unsafe as BSB
40−#else
41−import qualified Data.ByteString.Base as BSB
42−#endif
43−
44−-- For debugging
45−import Prelude hiding ( log, catch )
4639
4740#include <fcgiapp.h>
4841
@@ -60,59 +53,80 @@ foreign import ccall unsafe "fcgiapp.h FCGX_GetStr" fcgx_getStr
6053foreign import ccall unsafe "fcgiapp.h FCGX_PutStr" fcgx_putStr
6154 :: CString -> CInt -> StreamPtr -> IO CInt
6255
63−foreign import ccall safe "fcgiapp.h FCGX_Accept" fcgx_accept
64− :: Ptr StreamPtr -> Ptr StreamPtr -> Ptr StreamPtr -> Ptr Environ -> IO CInt
65−foreign import ccall unsafe "fcgiapp.h FCGX_Finish" fcgx_finish
66− :: IO ()
6756
6857------------------------------------------------------------------------
6958
59+foreign import ccall unsafe "fcgiapp.h FCGX_Init" fcgx_init
60+ :: IO CInt
61+
62+runFork :: Maybe String -> (IO () -> IO a) -> Int -> W.Application -> IO ()
63+runFork sf fork threads app = do
64+ testReturn "FCGX_Init" $ fcgx_init
65+ let oneThread = forever $ oneRequest app sf
66+ mapM_ fork $ replicate (threads - 1) oneThread
67+ oneThread
68+
7069-- | Handle FastCGI requests in an infinite loop.
7170run :: W.Application -> IO ()
72−run f = runOneFastCGI Nothing f >> run f
71+run = runFork Nothing id 1
7372
7473-- | Handle FastCGI requests in an infinite loop. For a server which supports
7574-- the X-Sendfile header.
7675runSendfile :: String -> W.Application -> IO ()
77−runSendfile sf f = runOneFastCGI (Just sf) f >> runSendfile sf f
78−
79−-- | Handle a single FastCGI request.
80−runOneFastCGI :: Maybe String -- X-Sendfile
81− -> W.Application -> IO ()
82−runOneFastCGI xsendfile f = do
83− alloca (\inp ->
84− alloca (\outp ->
85− alloca (\errp ->
86− alloca (\envp ->
87− oneRequest f inp outp errp envp
88− xsendfile))))
76+runSendfile sf = runFork (Just sf) id 1
8977
9078oneRequest :: W.Application
91− -> Ptr StreamPtr
92− -> Ptr StreamPtr
93− -> Ptr StreamPtr
94− -> Ptr Environ
9579 -> Maybe String -- X-Sendfile
9680 -> IO ()
97−oneRequest f inp outp errp envp xsendfile =
98− do
99− testReturn "FCGX_Accept" $ fcgx_accept inp outp errp envp
100− ins <- peek inp
101− outs <- peek outp
102− errs <- peek errp
103− env <- peek envp
104− handleRequest f ins outs errs env xsendfile
105− fcgx_finish
81+oneRequest app xsendfile = withRequest $ \r -> do
82+ putStrLn "Received 1 request"
83+ env <- peekEnvp r
84+ ins <- peekIn r
85+ outs <- peekOut r
86+ handleRequest app ins outs env xsendfile
87+
88+peekIn, peekOut :: Ptr FCGX_Request -> IO (Ptr FCGX_Stream)
89+peekIn = (#peek FCGX_Request, in)
90+peekOut = (#peek FCGX_Request, out)
91+
92+peekEnvp :: Ptr FCGX_Request -> IO Environ
93+peekEnvp = (#peek FCGX_Request, envp)
94+
95+foreign import ccall unsafe "fcgiapp.h FCGX_InitRequest" fcgx_initrequest
96+ :: Ptr FCGX_Request -> CInt -> CInt -> IO CInt
97+
98+foreign import ccall safe "fcgiapp.h FCGX_Accept_r" fcgx_accept_r
99+ :: Ptr FCGX_Request -> IO CInt
100+
101+acceptRequest :: IO (Ptr FCGX_Request)
102+acceptRequest = do
103+ reqp <- mallocBytes (#size FCGX_Request)
104+ initAndAccept reqp
105+ return reqp
106+ where initAndAccept reqp = do
107+ testReturn "FCGX_InitRequest" $ fcgx_initrequest reqp 0 0
108+ testReturn "FCGX_Accept_r" $ fcgx_accept_r reqp
109+
110+withRequest :: (Ptr FCGX_Request -> IO ()) -> IO ()
111+withRequest f = do
112+ req <- acceptRequest
113+ f req `finally` finishRequest req
114+
115+foreign import ccall unsafe "fcgiapp.h FCGX_Finish_r" fcgx_finish_r
116+ :: Ptr FCGX_Request -> IO ()
117+
118+finishRequest :: Ptr FCGX_Request -> IO ()
119+finishRequest reqp = do
120+ fcgx_finish_r reqp
121+ free reqp
106122
107123handleRequest :: W.Application
108− -> StreamPtr
109124 -> StreamPtr
110125 -> StreamPtr
111126 -> Environ
112127 -> Maybe String -- sendfile
113128 -> IO ()
114−handleRequest f ins outs _errs env xsendfile =
115− do
129+handleRequest f ins outs env xsendfile = do
116130 vars <- environToTable env
117131 let input = const $ sRead ins
118132 let hPut = sPutStr' outs
@@ -120,9 +134,6 @@ handleRequest f ins outs _errs env xsendfile =
120134
121135data FCGX_Request
122136
123−_peekErr :: Ptr FCGX_Request -> IO (Ptr FCGX_Stream)
124−_peekErr = (#peek FCGX_Request, err)
125−
126137--
127138-- * Stream IO
128139--