@@ -20,19 +20,17 @@ module Network.Wai.Handler.FastCGI (run) where
2020import Data.Maybe
2121import Control.Monad ( liftM )
2222import Data.Word (Word8)
23−import Foreign ( Ptr, castPtr, nullPtr, peekArray0
23+import Foreign ( Ptr, castPtr, nullPtr, peekArray0
2424 , alloca, throwIfNeg_)
2525import Foreign.C ( CInt, CString, CStringLen
2626 , peekCString )
2727import Foreign.Storable ( Storable (..) )
28−import System.IO.Unsafe (unsafeInterleaveIO)
2928
3029import qualified Network.Wai as W
31−import qualified Network.Wai.Enumerator as WE
30+import qualified Network.Wai.Handler.CGI as CGI
31+import qualified Network.Wai.Handler.Helper as CGI
3232
3333import qualified Data.ByteString as BS
34−import qualified Data.ByteString.Char8 as B8
35−import qualified Data.ByteString.Lazy.Char8 as Lazy
3634#if __GLASGOW_HASKELL__ >= 608
3735import qualified Data.ByteString.Internal as BSB
3836import qualified Data.ByteString.Unsafe as BSB
@@ -42,9 +40,6 @@ import qualified Data.ByteString.Base as BSB
4240
4341-- For debugging
4442import Prelude hiding ( log, catch )
45−import qualified System.IO
46−import Control.Arrow ((***))
47−import Data.Char (toLower)
4843
4944#include <fcgiapp.h>
5045
@@ -107,11 +102,9 @@ handleRequest :: W.Application
107102handleRequest f ins outs _errs env =
108103 do
109104 vars <- environToTable env
110− input <- sRead ins
105+ let input = sRead ins
111106 let hPut = sPutStr' outs
112− run' vars input hPut f
113−
114−
107+ CGI.run'' vars (CGI.requestBodyFunc input) hPut f
115108
116109data FCGX_Request
117110
@@ -130,7 +123,7 @@ fcgxPutCStringLen :: StreamPtr -> CStringLen -> IO ()
130123fcgxPutCStringLen h (cs,len) =
131124 testReturn "FCGX_PutStr" $ fcgx_putStr cs (fromIntegral len) h
132125
133−sRead :: StreamPtr -> IO Lazy.ByteString
126+sRead :: StreamPtr -> IO (Maybe BS.ByteString)
134127sRead h = buildByteString (fcgxGetBuf h) 4096
135128
136129fcgxGetBuf :: StreamPtr -> Ptr a -> Int -> IO Int
@@ -143,16 +136,12 @@ fcgxGetBuf h p c =
143136
144137-- | Data.ByteString.Lazy.hGetContentsN generalized to arbitrary
145138-- reading functions.
146−buildByteString :: (Ptr Word8 -> Int -> IO Int) -> Int -> IO Lazy.ByteString
147−buildByteString f k = lazyRead >>= return . Lazy.fromChunks
148− where
149− lazyRead = unsafeInterleaveIO $ do
150− ps <- BSB.createAndTrim k $ \p -> f p k
151− case BS.length ps of
152− 0 -> return []
153− n | n < k -> return [ps]
154− _ -> do pss <- lazyRead
155− return (ps : pss)
139+buildByteString :: (Ptr Word8 -> Int -> IO Int) -> Int -> IO (Maybe BS.ByteString)
140+buildByteString f k = do
141+ ps <- BSB.createAndTrim k $ \p -> f p k
142+ case BS.length ps of
143+ 0 -> return Nothing
144+ _ -> return $ Just ps
156145
157146--
158147-- * Utilities
@@ -174,96 +163,3 @@ environToTable arr =
174163splitBy :: Eq a => a -> [a] -> ([a],[a])
175164splitBy x xs = (y, drop 1 z)
176165 where (y,z) = break (==x) xs
177−
178−run' :: [(String, String)] -- ^ all variables
179− -> Lazy.ByteString -- ^ responseBody of input
180− -> (BS.ByteString -> IO ()) -- ^ destination for output
181− -> W.Application
182− -> IO ()
183−run' vars inputH hPut app = do
184− let rmethod = B8.pack $ lookup' "REQUEST_METHOD" vars
185− pinfo = lookup' "PATH_INFO" vars
186− qstring = lookup' "QUERY_STRING" vars
187− servername = lookup' "SERVER_NAME" vars
188− serverport = safeRead 80 $ lookup' "SERVER_PORT" vars
189− contentLength = safeRead 0 $ lookup' "CONTENT_LENGTH" vars
190− remoteHost' =
191− case lookup "REMOTE_HOST" vars of
192− Just x -> x
193− Nothing ->
194− case lookup "REMOTE_ADDR" vars of
195− Just x -> x
196− Nothing -> ""
197− isSecure' =
198− case map toLower $ lookup' "SERVER_PROTOCOL" vars of
199− "https" -> True
200− _ -> False
201− let env = W.Request
202− { W.requestMethod = rmethod
203− , W.pathInfo = B8.pack pinfo
204− , W.queryString = B8.pack qstring
205− , W.serverName = B8.pack servername
206− , W.serverPort = serverport
207− , W.requestHeaders = map (cleanupVarName *** B8.pack) vars
208− , W.isSecure = isSecure'
209− , W.requestBody = requestBodyLBS inputH contentLength
210− , W.errorHandler = System.IO.hPutStr System.IO.stderr
211− , W.remoteHost = B8.pack remoteHost'
212− , W.httpVersion = "" -- FIXME
213− }
214− res <- app env
215− let h = W.responseHeaders res
216− let h' = case lookup "Content-Type" h of
217− Nothing -> ("Content-Type", "text/html; charset=utf-8")
218− : h
219− Just _ -> h
220− hPut $ B8.pack $ "Status: " ++ (show $ W.statusCode $ W.status res) ++ " "
221− hPut $ W.statusMessage $ W.status res
222− hPut $ B8.singleton '\n'
223− mapM_ (printHeader hPut) h'
224− hPut $ B8.singleton '\n'
225− _ <- W.runEnumerator (WE.fromResponseBody (W.responseBody res))
226− (myPut hPut) ()
227− return ()
228−
229−myPut :: (BS.ByteString -> IO ()) -> () -> BS.ByteString -> IO (Either () ())
230−myPut output () bs = output bs >> return (Right ())
231−
232−printHeader :: (BS.ByteString -> IO ())
233− -> (W.ResponseHeader, BS.ByteString)
234− -> IO ()
235−printHeader f (x, y) = do
236− f $ W.ciOriginal x
237− f $ B8.pack ": "
238− f y
239− f $ B8.singleton '\n'
240−
241−cleanupVarName :: String -> W.RequestHeader
242−cleanupVarName ('H':'T':'T':'P':'_':a:as) =
243− W.mkCIByteString $ B8.pack $ a : helper' as where
244− helper' ('_':x:rest) = '-' : x : helper' rest
245− helper' (x:rest) = toLower x : helper' rest
246− helper' [] = []
247−cleanupVarName "CONTENT_TYPE" = "Content-Type"
248−cleanupVarName "CONTENT_LENGTH" = "Content-Length"
249−cleanupVarName "SCRIPT_NAME" = "CGI-Script-Name"
250−cleanupVarName x = W.mkCIByteString $ B8.pack x -- FIXME remove?
251−
252−requestBodyLBS :: Lazy.ByteString -> Int -> W.Source
253−requestBodyLBS = go . Lazy.toChunks
254− where
255− go _ 0 = W.Source $ return Nothing
256− go [] _ = W.Source $ return Nothing
257− go (l:ls) len =
258− let len' = len - BS.length l
259− len'' = if len' < 0 then 0 else len'
260− in W.Source $ return $ Just (l, go ls len'')
261−
262−lookup' :: String -> [(String, String)] -> String
263−lookup' key pairs = fromMaybe "" $ lookup key pairs
264−
265−safeRead :: Read a => a -> String -> a
266−safeRead d s =
267− case reads s of
268− ((x, _):_) -> x
269− [] -> d