244af9c · typeable/wai

git.iko.soy/typeable/wai

on master help sign in

Using run'' from wai-extra

244af9cMichael Snoyman16 years ago

Network/Wai/Handler/FastCGI.hsc+12−116

compare with master

unifiedsplit

@@ -20,19 +20,17 @@ module Network.Wai.Handler.FastCGI (run) where

20import Data.Maybe

21import Control.Monad ( liftM )

22import Data.Word (Word8)

23−import Foreign ( Ptr, castPtr, nullPtr, peekArray0

23+import Foreign ( Ptr, castPtr, nullPtr, peekArray0

24 , alloca, throwIfNeg_)

25import Foreign.C ( CInt, CString, CStringLen

26 , peekCString )

27import Foreign.Storable ( Storable (..) )

28−import System.IO.Unsafe (unsafeInterleaveIO)

30import qualified Network.Wai as W

29import 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

33import qualified Data.ByteString as BS

34−import qualified Data.ByteString.Char8 as B8

35−import qualified Data.ByteString.Lazy.Char8 as Lazy

36#if __GLASGOW_HASKELL__ >= 608

34#if __GLASGOW_HASKELL__ >= 608

37import qualified Data.ByteString.Internal as BSB

35import qualified Data.ByteString.Internal as BSB

38import qualified Data.ByteString.Unsafe as BSB

36import qualified Data.ByteString.Unsafe as BSB

@@ -42,9 +40,6 @@ import qualified Data.ByteString.Base as BSB

43-- For debugging

41-- For debugging

44import Prelude hiding ( log, catch )

42import Prelude hiding ( log, catch )

45−import qualified System.IO

46−import Control.Arrow ((***))

47−import Data.Char (toLower)

49#include <fcgiapp.h>

44#include <fcgiapp.h>

@@ -107,11 +102,9 @@ handleRequest :: W.Application

107handleRequest f ins outs _errs env =

102handleRequest f ins outs _errs env =

108 do

103 do

109 vars <- environToTable env

104 vars <- environToTable env

110− input <- sRead ins

105+ let input = sRead ins

111 let hPut = sPutStr' outs

106 let hPut = sPutStr' outs

112− run' vars input hPut f

107+ CGI.run'' vars (CGI.requestBodyFunc input) hPut f

113−

114−

115

108

116data FCGX_Request

109data FCGX_Request

117

110

@@ -130,7 +123,7 @@ fcgxPutCStringLen :: StreamPtr -> CStringLen -> IO ()

130fcgxPutCStringLen h (cs,len) =

123fcgxPutCStringLen h (cs,len) =

131 testReturn "FCGX_PutStr" $ fcgx_putStr cs (fromIntegral len) h

124 testReturn "FCGX_PutStr" $ fcgx_putStr cs (fromIntegral len) h

132

125

133−sRead :: StreamPtr -> IO Lazy.ByteString

126+sRead :: StreamPtr -> IO (Maybe BS.ByteString)

134sRead h = buildByteString (fcgxGetBuf h) 4096

127sRead h = buildByteString (fcgxGetBuf h) 4096

135

128

136fcgxGetBuf :: StreamPtr -> Ptr a -> Int -> IO Int

129fcgxGetBuf :: StreamPtr -> Ptr a -> Int -> IO Int

@@ -143,16 +136,12 @@ fcgxGetBuf h p c =

143

136

144-- | Data.ByteString.Lazy.hGetContentsN generalized to arbitrary

137-- | Data.ByteString.Lazy.hGetContentsN generalized to arbitrary

145-- reading functions.

138-- reading functions.

146−buildByteString :: (Ptr Word8 -> Int -> IO Int) -> Int -> IO Lazy.ByteString

139+buildByteString :: (Ptr Word8 -> Int -> IO Int) -> Int -> IO (Maybe BS.ByteString)

147−buildByteString f k = lazyRead >>= return . Lazy.fromChunks

140+buildByteString f k = do

148− where

149− lazyRead = unsafeInterleaveIO $ do

150− ps <- BSB.createAndTrim k $ \p -> f p k

141+ ps <- BSB.createAndTrim k $ \p -> f p k

151− case BS.length ps of

142+ case BS.length ps of

152− 0 -> return []

143+ 0 -> return Nothing

153− n | n < k -> return [ps]

154− _ -> do pss <- lazyRead

155− return (ps : pss)

144+ _ -> return $ Just ps

156

145

157--

146--

158-- * Utilities

147-- * Utilities

@@ -174,96 +163,3 @@ environToTable arr =

174splitBy :: Eq a => a -> [a] -> ([a],[a])

163splitBy :: Eq a => a -> [a] -> ([a],[a])

175splitBy x xs = (y, drop 1 z)

164splitBy x xs = (y, drop 1 z)

176 where (y,z) = break (==x) xs

165 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

wai-handler-fastcgi.cabal+2−2

@@ -1,5 +1,5 @@

1name: wai-handler-fastcgi

2−version: 0.2.0.1

2+version: 0.2.1

3license: BSD3

4license-file: LICENSE

5author: Michael Snoyman <michael@snoyman.com>

@@ -15,7 +15,7 @@ homepage: http://github.com/snoyberg/hack-handler-fastcgi/tree/master

15library

16 build-depends: base >= 4 && < 5,

17 wai >= 0.2.0 && < 0.3.0,

18− wai-extra >= 0.2.0 && < 0.3.0,

18+ wai-extra >= 0.2.1 && < 0.3.0,

19 bytestring >= 0.9.1.4 && < 0.10

20 exposed-modules: Network.Wai.Handler.FastCGI

21 ghc-options: -Wall