02ae797 · typeable/wai

git.iko.soy/typeable/wai

on master help sign in

Most of wai-extra rewritten

02ae797Michael Snoyman12 years ago

wai-extra/Network/Wai/Handler/CGI.hs+54−51

compare with master

unifiedsplit

@@ -13,8 +13,8 @@ module Network.Wai.Handler.CGI

13import Network.Wai

14import Network.Wai.Internal

15import Network.Socket (getAddrInfo, addrAddress)

16+import Data.IORef

16import Data.Maybe (fromMaybe)

17import Data.Maybe (fromMaybe)

17−import Control.Exception (mask)

18import qualified Data.ByteString.Char8 as B

19import qualified Data.ByteString.Lazy as L

20import Control.Arrow ((***))

@@ -22,15 +22,17 @@ import Data.Char (toLower)

22import qualified System.IO

23import qualified Data.String as String

24import Data.Monoid (mconcat, mempty)

25−import Blaze.ByteString.Builder (fromByteString, toLazyByteString)

25+import Blaze.ByteString.Builder (fromByteString, toLazyByteString, flush)

26import Blaze.ByteString.Builder.Char8 (fromChar, fromString)

27−import Control.Monad.IO.Class (liftIO)

28import Data.ByteString.Lazy.Internal (defaultChunkSize)

27import Data.ByteString.Lazy.Internal (defaultChunkSize)

29import System.IO (Handle)

28import System.IO (Handle)

30import Network.HTTP.Types (Status (..))

29import Network.HTTP.Types (Status (..))

31import qualified Network.HTTP.Types as H

30import qualified Network.HTTP.Types as H

32import qualified Data.CaseInsensitive as CI

31import qualified Data.CaseInsensitive as CI

33import Data.Monoid (mappend)

32import Data.Monoid (mappend)

33+import qualified Data.Streaming.Blaze as Blaze

34+import Data.Function (fix)

35+import Control.Monad (unless, void)

35#if WINDOWS

37#if WINDOWS

36import System.Environment (getEnvironment)

38import System.Environment (getEnvironment)

@@ -74,7 +76,7 @@ runSendfile sf app = do

74-- stick with 'run' or 'runSendfile'.

76-- stick with 'run' or 'runSendfile'.

75runGeneric

77runGeneric

76 :: [(String, String)] -- ^ all variables

78 :: [(String, String)] -- ^ all variables

77− -> (Int -> Source IO B.ByteString) -- ^ responseBody of input

79+ -> (Int -> IO (IO B.ByteString)) -- ^ responseBody of input

78 -> (B.ByteString -> IO ()) -- ^ destination for output

80 -> (B.ByteString -> IO ()) -- ^ destination for output

79 -> Maybe B.ByteString -- ^ does the server support the X-Sendfile header?

81 -> Maybe B.ByteString -- ^ does the server support the X-Sendfile header?

80 -> Application

82 -> Application

@@ -96,40 +98,48 @@ runGeneric vars inputH outputH xsendfile app = do

96 "https" -> True

98 "https" -> True

97 _ -> False

99 _ -> False

98 addrs <- getAddrInfo Nothing (Just remoteHost') Nothing

100 addrs <- getAddrInfo Nothing (Just remoteHost') Nothing

101+ requestBody' <- inputH contentLength

99 let addr =

102 let addr =

100 case addrs of

103 case addrs of

101 a:_ -> addrAddress a

104 a:_ -> addrAddress a

102 [] -> error $ "Invalid REMOTE_ADDR or REMOTE_HOST: " ++ remoteHost'

105 [] -> error $ "Invalid REMOTE_ADDR or REMOTE_HOST: " ++ remoteHost'

103− mask $ \restore -> do

104− let reqHeaders = map (cleanupVarName *** B.pack) vars

106+ reqHeaders = map (cleanupVarName *** B.pack) vars

105− env = Request

107+ env = Request

106− { requestMethod = rmethod

108+ { requestMethod = rmethod

107− , rawPathInfo = B.pack pinfo

109+ , rawPathInfo = B.pack pinfo

108− , pathInfo = H.decodePathSegments $ B.pack pinfo

110+ , pathInfo = H.decodePathSegments $ B.pack pinfo

109− , rawQueryString = B.pack qstring

111+ , rawQueryString = B.pack qstring

110− , queryString = H.parseQuery $ B.pack qstring

112+ , queryString = H.parseQuery $ B.pack qstring

111− , requestHeaders = reqHeaders

113+ , requestHeaders = reqHeaders

112− , isSecure = isSecure'

114+ , isSecure = isSecure'

113− , remoteHost = addr

115+ , remoteHost = addr

114− , httpVersion = H.http11 -- FIXME

116+ , httpVersion = H.http11 -- FIXME

115− , requestBody = inputH contentLength

117+ , requestBody = requestBody'

116− , vault = mempty

118+ , vault = mempty

117− , requestBodyLength = KnownLength $ fromIntegral contentLength

119+ , requestBodyLength = KnownLength $ fromIntegral contentLength

118− , requestHeaderHost = lookup "host" reqHeaders

120+ , requestHeaderHost = lookup "host" reqHeaders

119− , requestHeaderRange = lookup "range" reqHeaders

121+ , requestHeaderRange = lookup "range" reqHeaders

120− }

122+ }

121− -- FIXME worry about exception?

123+ void $ app env $ \res ->

122− res <- restore $ app env

123 case (xsendfile, res) of

124 case (xsendfile, res) of

124− (Just sf, ResponseFile s hs fp Nothing) ->

125+ (Just sf, ResponseFile s hs fp Nothing) -> do

125− restore $ mapM_ outputH $ L.toChunks $ toLazyByteString $ sfBuilder s hs sf fp

126+ mapM_ outputH $ L.toChunks $ toLazyByteString $ sfBuilder s hs sf fp

127+ return ResponseReceived

126 _ -> do

128 _ -> do

127− let (s, hs, wb) = responseToSource res

129+ let (s, hs, wb) = responseToStream res

130+ (blazeRecv, blazeFinish) <- Blaze.newBlazeRecv Blaze.defaultStrategy

128− wb $ \b ->

131+ wb $ \b -> do

129− let src = do

132+ let sendBuilder builder = do

133+ popper <- blazeRecv builder

134+ fix $ \loop -> do

135+ bs <- popper

136+ unless (B.null bs) $ do

137+ outputH bs

138+ loop

130− yield (Chunk $ headers s hs `mappend` fromChar '\n')

139+ sendBuilder $ headers s hs `mappend` fromChar '\n'

131− b

140+ b sendBuilder (sendBuilder flush)

132− in src $$ builderSink

141+ blazeFinish >>= maybe (return ()) outputH

142+ return ResponseReceived

133 where

143 where

134 headers s hs = mconcat (map header $ status s : map header' (fixHeaders hs))

144 headers s hs = mconcat (map header $ status s : map header' (fixHeaders hs))

135 status (Status i m) = (fromByteString "Status", mconcat

145 status (Status i m) = (fromByteString "Status", mconcat

@@ -151,13 +161,6 @@ runGeneric vars inputH outputH xsendfile app = do

151 , fromByteString sf

161 , fromByteString sf

152 , fromByteString " not supported"

162 , fromByteString " not supported"

153 ]

163 ]

154− bsSink = await >>= maybe (return ()) push

155− push (Chunk bs) = do

156− liftIO $ outputH bs

157− bsSink

158− -- FIXME actually flush?

159− push Flush = bsSink

160− builderSink = builderToByteStringFlush =$ bsSink

161 fixHeaders h =

164 fixHeaders h =

162 case lookup "content-type" h of

165 case lookup "content-type" h of

163 Nothing -> ("Content-Type", "text/html; charset=utf-8") : h

166 Nothing -> ("Content-Type", "text/html; charset=utf-8") : h

@@ -176,19 +179,19 @@ cleanupVarName s =

176 helper' (x:rest) = toLower x : helper' rest

179 helper' (x:rest) = toLower x : helper' rest

177 helper' [] = []

180 helper' [] = []

178

181

179−requestBodyHandle :: Handle -> Int -> Source IO B.ByteString

182+requestBodyHandle :: Handle -> Int -> IO (IO B.ByteString)

180requestBodyHandle h = requestBodyFunc $ \i -> do

183requestBodyHandle h = requestBodyFunc $ \i -> do

181 bs <- B.hGet h i

184 bs <- B.hGet h i

182 return $ if B.null bs then Nothing else Just bs

185 return $ if B.null bs then Nothing else Just bs

183

186

184−requestBodyFunc :: (Int -> IO (Maybe B.ByteString)) -> Int -> Source IO B.ByteString

187+requestBodyFunc :: (Int -> IO (Maybe B.ByteString)) -> Int -> IO (IO B.ByteString)

185−requestBodyFunc get =

188+requestBodyFunc get count0 = do

186− loop

189+ ref <- newIORef count0

187− where

190+ return $ do

188− loop 0 = return ()

191+ count <- readIORef ref

189− loop count = do

192+ if count <= 0

193+ then return B.empty

194+ else do

190− mbs <- liftIO $ get $ min count defaultChunkSize

195+ mbs <- get $ min count defaultChunkSize

191− let count' = count - maybe 0 B.length mbs

196+ writeIORef ref $ count - maybe 0 B.length mbs

192− case mbs of

197+ return $ fromMaybe B.empty mbs

193− Nothing -> return ()

194− Just bs -> yield bs >> loop count'

wai-extra/Network/Wai/Middleware/Autohead.hs+5−10

@@ -4,17 +4,12 @@

4module Network.Wai.Middleware.Autohead (autohead) where

6import Network.Wai

7−import Network.Wai.Internal

8import Data.Monoid (mempty)

7import Data.Monoid (mempty)

10autohead :: Middleware

9autohead :: Middleware

11−autohead app req

10+autohead app req sendResponse

12− | requestMethod req == "HEAD" = do

13− res <- app req { requestMethod = "GET" }

11+ | requestMethod req == "HEAD" = app req { requestMethod = "GET" } $ \res -> do

14− let go (ResponseFile s hs _ _) = ResponseBuilder s hs mempty

12+ let (s, hs, _) = responseToStream res

15− go (ResponseBuilder s hs _) = ResponseBuilder s hs mempty

13+ sendResponse $ responseBuilder s hs mempty

16− go (ResponseSource s hs _) = ResponseBuilder s hs mempty

17− go (ResponseRaw raw r) = ResponseRaw raw (go r)

18− return (go res)

19− | otherwise = app req

14+ | otherwise = app req sendResponse

wai-extra/Network/Wai/Middleware/CleanPath.hs+3−3

@@ -14,10 +14,10 @@ cleanPath :: ([Text] -> Either B.ByteString [Text])

14 -> B.ByteString

15 -> ([Text] -> Application)

16 -> Application

17−cleanPath splitter prefix app env =

17+cleanPath splitter prefix app env sendResponse =

18 case splitter $ pathInfo env of

19− Right pieces -> app pieces env

19+ Right pieces -> app pieces env sendResponse

20− Left p -> return

20+ Left p -> sendResponse

21 $ responseLBS status301

22 [("Location", mconcat [prefix, p, suffix])]

23 $ L.empty

wai-extra/Network/Wai/Middleware/RequestLogger.hs+35−30

@@ -93,23 +93,21 @@ mkRequestLogger RequestLoggerSettings{..} = do

93 return $ customMiddleware callback getdate formatter

95apacheMiddleware :: ApacheLoggerActions -> Middleware

96−apacheMiddleware ala app req = do

96+apacheMiddleware ala app req sendResponse = app req $ \res -> do

97− res <- app req

98 let msize = lookup "content-length" (responseHeaders res) >>= readInt'

97 let msize = lookup "content-length" (responseHeaders res) >>= readInt'

99 readInt' bs =

98 readInt' bs =

100 case S8.readInteger bs of

99 case S8.readInteger bs of

101 Just (i, "") -> Just i

100 Just (i, "") -> Just i

102 _ -> Nothing

101 _ -> Nothing

103 apacheLogger ala req (responseStatus res) msize

102 apacheLogger ala req (responseStatus res) msize

104− return res

103+ sendResponse res

105

104

106customMiddleware :: Callback -> IO ZonedDate -> OutputFormatter -> Middleware

105customMiddleware :: Callback -> IO ZonedDate -> OutputFormatter -> Middleware

107−customMiddleware cb getdate formatter app req = do

106+customMiddleware cb getdate formatter app req sendResponse = app req $ \res -> do

108− res <- app req

109 date <- liftIO getdate

107 date <- liftIO getdate

110 -- We use Nothing for the response size since we generally don't know it

108 -- We use Nothing for the response size since we generally don't know it

111 liftIO $ cb $ formatter date req (responseStatus res) Nothing

109 liftIO $ cb $ formatter date req (responseStatus res) Nothing

112− return res

110+ sendResponse res

113

111

114-- | Production request logger middleware.

112-- | Production request logger middleware.

115-- Implemented on top of "logCallback", but prints to 'stdout'

113-- Implemented on top of "logCallback", but prints to 'stdout'

@@ -186,13 +184,18 @@ ansiColor color bs = [

186detailedMiddleware' :: Callback

184detailedMiddleware' :: Callback

187 -> IO (BS.ByteString -> [BS.ByteString])

185 -> IO (BS.ByteString -> [BS.ByteString])

188 -> Middleware

186 -> Middleware

189−detailedMiddleware' cb getAddColor app req = do

187+detailedMiddleware' cb getAddColor app req sendResponse = do

190 let mlen = lookup "content-length" (requestHeaders req) >>= readInt

188 let mlen = lookup "content-length" (requestHeaders req) >>= readInt

191 (req', body) <-

189 (req', body) <-

192 case mlen of

190 case mlen of

193 -- log the request body if it is small

191 -- log the request body if it is small

194 Just len | len <= 2048 -> do

192 Just len | len <= 2048 -> do

193+ let loop front = do

195− body <- requestBody req C.$$ CL.consume

194+ bs <- requestBody req

195+ if S8.null bs

196+ then return $ front []

197+ else loop $ front . (bs:)

198+ body <- loop id

196 -- logging the body here consumes it, so fill it back up

199 -- logging the body here consumes it, so fill it back up

197 -- obviously not efficient, but this is the development logger

200 -- obviously not efficient, but this is the development logger

198 --

201 --

@@ -204,14 +207,10 @@ detailedMiddleware' cb getAddColor app req = do

204 -- implementation ensures that each chunk is only returned

207 -- implementation ensures that each chunk is only returned

205 -- once.

208 -- once.

206 ichunks <- newIORef body

209 ichunks <- newIORef body

207− let rbody = do

210+ let rbody = atomicModifyIORef ichunks $ \chunks ->

208− chunks <- readIORef ichunks

209 case chunks of

211 case chunks of

210− [] -> return ()

212+ [] -> ([], S8.empty)

211− x:xs -> do

213+ x:y -> (y, x)

212− writeIORef ichunks xs

213− C.yield x

214− rbody

215 let req' = req { requestBody = rbody }

214 let req' = req { requestBody = rbody }

216 return (req', body)

215 return (req', body)

217 _ -> return (req, [])

216 _ -> return (req, [])

@@ -237,20 +236,20 @@ detailedMiddleware' cb getAddColor app req = do

237 , "\n"

236 , "\n"

238 ]

237 ]

239

238

240− rsp <- app req'

239+ app req' $ \rsp -> do

241−

240+

242− -- log the status of the response

241+ -- log the status of the response

243− -- this is color coordinated with the request logging

242+ -- this is color coordinated with the request logging

244− -- also includes the request path to connect it to the request

243+ -- also includes the request path to connect it to the request

245− liftIO $ cb $ mconcat $ map toLogStr $

244+ liftIO $ cb $ mconcat $ map toLogStr $

246− addColor "Status: " ++ statusBS rsp ++

245+ addColor "Status: " ++ statusBS rsp ++

247− [ " "

246+ [ " "

248− , msgBS rsp

247+ , msgBS rsp

249− , ". "

248+ , ". "

250− , rawPathInfo req -- if you need help matching the 2 logging statements

249+ , rawPathInfo req -- if you need help matching the 2 logging statements

251− , "\n"

250+ , "\n"

252− ]

251+ ]

253− return rsp

252+ sendResponse rsp

254 where

253 where

255 paramsToBS prefix params =

254 paramsToBS prefix params =

256 if null params then ""

255 if null params then ""

@@ -259,7 +258,13 @@ detailedMiddleware' cb getAddColor app req = do

259 allPostParams body =

258 allPostParams body =

260 case getRequestBodyType req of

259 case getRequestBodyType req of

261 Nothing -> return ([], [])

260 Nothing -> return ([], [])

261+ Just rbt -> do

262+ ichunks <- newIORef body

263+ let rbody = atomicModifyIORef ichunks $ \chunks ->

264+ case chunks of

265+ [] -> ([], S8.empty)

266+ x:y -> (y, x)

262− Just rbt -> CL.sourceList body C.$$ sinkRequestBody lbsBackEnd rbt

267+ sinkRequestBody lbsBackEnd rbt rbody

263

268

264 emptyGetParam :: (BS.ByteString, Maybe BS.ByteString) -> (BS.ByteString, BS.ByteString)

269 emptyGetParam :: (BS.ByteString, Maybe BS.ByteString) -> (BS.ByteString, BS.ByteString)

265 emptyGetParam (k, Just v) = (k,v)

270 emptyGetParam (k, Just v) = (k,v)

wai-extra/Network/Wai/Parse.hs+48−16

@@ -11,8 +11,10 @@ module Network.Wai.Parse

11 , parseRequestBody

12 , RequestBodyType (..)

13 , getRequestBodyType

14− , sinkRequestBody

14+ , sinkRequestBody -- FIXME bad name

15+ {- FIXME

15 , conduitRequestBody

16 , conduitRequestBody

17+ -}

16 , BackEnd

18 , BackEnd

17 , lbsBackEnd

19 , lbsBackEnd

18 , tempFileBackEnd

20 , tempFileBackEnd

@@ -38,7 +40,7 @@ import qualified Data.ByteString.Char8 as S8

38import Data.Word (Word8)

40import Data.Word (Word8)

39import Data.Maybe (fromMaybe)

41import Data.Maybe (fromMaybe)

40import Data.List (sortBy)

42import Data.List (sortBy)

41−import Data.Function (on)

43+import Data.Function (on, fix)

42import System.Directory (removeFile, getTemporaryDirectory)

44import System.Directory (removeFile, getTemporaryDirectory)

43import System.IO (hClose, openBinaryTempFile)

45import System.IO (hClose, openBinaryTempFile)

44import Network.Wai

46import Network.Wai

@@ -49,6 +51,7 @@ import Control.Monad (when, unless)

49import Control.Monad.Trans.Class (lift)

51import Control.Monad.Trans.Class (lift)

50import Control.Monad.Trans.Resource (allocate, release, register, InternalState, runInternalState)

52import Control.Monad.Trans.Resource (allocate, release, register, InternalState, runInternalState)

51import Data.Void (Void)

53import Data.Void (Void)

54+import Data.IORef

53breakDiscard :: Word8 -> S.ByteString -> (S.ByteString, S.ByteString)

56breakDiscard :: Word8 -> S.ByteString -> (S.ByteString, S.ByteString)

54breakDiscard w s =

57breakDiscard w s =

@@ -80,15 +83,22 @@ parseHttpAccept = map fst

80 _ -> 1.0

83 _ -> 1.0

82-- | Store uploaded files in memory

85-- | Store uploaded files in memory

83−lbsBackEnd :: Monad m => ignored1 -> ignored2 -> Sink S.ByteString m L.ByteString

86+lbsBackEnd :: Monad m => ignored1 -> ignored2 -> m S.ByteString -> m L.ByteString

84−lbsBackEnd _ _ = fmap L.fromChunks CL.consume

87+lbsBackEnd _ _ popper =

88+ loop id

89+ where

90+ loop front = do

91+ bs <- popper

92+ if S.null bs

93+ then return $ L.fromChunks $ front []

94+ else loop $ front . (bs:)

86-- | Save uploaded files on disk as temporary files

96-- | Save uploaded files on disk as temporary files

87--

97--

88-- Note: starting with version 2.0, removal of temp files is registered with

98-- Note: starting with version 2.0, removal of temp files is registered with

89-- the provided @InternalState@. It is the responsibility of the caller to

99-- the provided @InternalState@. It is the responsibility of the caller to

90-- ensure that this @InternalState@ gets cleaned up.

100-- ensure that this @InternalState@ gets cleaned up.

91−tempFileBackEnd :: InternalState -> ignored1 -> ignored2 -> Sink S.ByteString IO FilePath

101+tempFileBackEnd :: InternalState -> ignored1 -> ignored2 -> IO S.ByteString -> IO FilePath

92tempFileBackEnd = tempFileBackEndOpts getTemporaryDirectory "webenc.buf"

102tempFileBackEnd = tempFileBackEndOpts getTemporaryDirectory "webenc.buf"

103

94-- | Same as 'tempFileSink', but use configurable temp folders and patterns.

104-- | Same as 'tempFileSink', but use configurable temp folders and patterns.

@@ -97,14 +107,19 @@ tempFileBackEndOpts :: IO FilePath -- ^ get temporary directory

97 -> InternalState

107 -> InternalState

98 -> ignored1

108 -> ignored1

99 -> ignored2

109 -> ignored2

100− -> Sink S.ByteString IO FilePath

110+ -> IO S.ByteString

111+ -> IO FilePath

101−tempFileBackEndOpts getTmpDir pattern internalState _ _ = do

112+tempFileBackEndOpts getTmpDir pattern internalState _ _ popper = do

102 (key, (fp, h)) <- flip runInternalState internalState $ allocate (do

113 (key, (fp, h)) <- flip runInternalState internalState $ allocate (do

103 tempDir <- getTmpDir

114 tempDir <- getTmpDir

104 openBinaryTempFile tempDir pattern) (\(_, h) -> hClose h)

115 openBinaryTempFile tempDir pattern) (\(_, h) -> hClose h)

105 _ <- runInternalState (register $ removeFile fp) internalState

116 _ <- runInternalState (register $ removeFile fp) internalState

106− CB.sinkHandle h

117+ fix $ \loop -> do

118+ bs <- popper

119+ unless (S.null bs) $ do

120+ S.hPut h bs

121+ loop

107− lift $ release key

122+ release key

108 return fp

123 return fp

109

124

110-- | Information on an uploaded file.

125-- | Information on an uploaded file.

@@ -121,11 +136,12 @@ type Param = (S.ByteString, S.ByteString)

121-- | Post parameter name and associated file information.

136-- | Post parameter name and associated file information.

122type File y = (S.ByteString, FileInfo y)

137type File y = (S.ByteString, FileInfo y)

123

138

124−-- | A file uploading backend. Takes the parameter name, file name, and content

139+-- | A file uploading backend. Takes the parameter name, file name, and a

125−-- type, and returns a `Sink` for storing the contents.

140+-- stream of data.

126type BackEnd a = S.ByteString -- ^ parameter name

141type BackEnd a = S.ByteString -- ^ parameter name

127 -> FileInfo ()

142 -> FileInfo ()

128− -> Sink S.ByteString IO a

143+ -> IO S.ByteString

144+ -> IO a

129

145

130data RequestBodyType = UrlEncoded | Multipart S.ByteString

146data RequestBodyType = UrlEncoded | Multipart S.ByteString

131

147

@@ -168,16 +184,29 @@ parseRequestBody :: BackEnd y

168parseRequestBody s r =

184parseRequestBody s r =

169 case getRequestBodyType r of

185 case getRequestBodyType r of

170 Nothing -> return ([], [])

186 Nothing -> return ([], [])

171− Just rbt -> fmap partitionEithers $ requestBody r $$ conduitRequestBody s rbt =$ CL.consume

187+ Just rbt -> sinkRequestBody s rbt (requestBody r)

172

188

173sinkRequestBody :: BackEnd y

189sinkRequestBody :: BackEnd y

174 -> RequestBodyType

190 -> RequestBodyType

191+ -> IO S.ByteString

175− -> Sink S.ByteString IO ([Param], [File y])

192+ -> IO ([Param], [File y])

193+sinkRequestBody s r body = do

194+ ref <- newIORef (id, id)

195+ let add x = atomicModifyIORef ref $ \(y, z) ->

196+ case x of

197+ Left y' -> ((y . (y':), z), ())

198+ Right z' -> ((y, z . (z':)), ())

176−sinkRequestBody s r = fmap partitionEithers $ conduitRequestBody s r =$ CL.consume

199+ conduitRequestBody s r body add

200+ (x, y) <- readIORef ref

201+ return (x [], y [])

177

202

178conduitRequestBody :: BackEnd y

203conduitRequestBody :: BackEnd y

179 -> RequestBodyType

204 -> RequestBodyType

205+ -> IO S.ByteString

180− -> Conduit S.ByteString IO (Either Param (File y))

206+ -> (Either Param (File y) -> IO ())

207+ -> IO ()

208+conduitRequestBody = error "conduitRequestBody"

209+{-

181conduitRequestBody _ UrlEncoded = do

210conduitRequestBody _ UrlEncoded = do

182 -- NOTE: in general, url-encoded data will be in a single chunk.

211 -- NOTE: in general, url-encoded data will be in a single chunk.

183 -- Therefore, I'm optimizing for the usual case by sticking with

212 -- Therefore, I'm optimizing for the usual case by sticking with

@@ -257,6 +286,7 @@ parsePieces sink bound =

257 parsePair s =

286 parsePair s =

258 let (x, y) = breakDiscard 58 s -- colon

287 let (x, y) = breakDiscard 58 s -- colon

259 in (x, S.dropWhile (== 32) y) -- space

288 in (x, S.dropWhile (== 32) y) -- space

289+-}

260

290

261data Bound = FoundBound S.ByteString S.ByteString

291data Bound = FoundBound S.ByteString S.ByteString

262 | NoBound

292 | NoBound

@@ -286,6 +316,7 @@ findBound b bs = handleBreak $ Search.breakOn b bs

286 | S.index b x == S.index bs y = mismatch xs ys

316 | S.index b x == S.index bs y = mismatch xs ys

287 | otherwise = True

317 | otherwise = True

288

318

319+{- FIXME

289sinkTillBound' :: S.ByteString

320sinkTillBound' :: S.ByteString

290 -> S.ByteString

321 -> S.ByteString

291 -> FileInfo ()

322 -> FileInfo ()

@@ -348,6 +379,7 @@ sinkTillBound bound iter seed0 =

348 ignoreTerm = await' >>= maybe (return ()) (\x -> yield' x >> ignoreTerm)

379 ignoreTerm = await' >>= maybe (return ()) (\x -> yield' x >> ignoreTerm)

349 await' = NeedInput (return . Just) (const $ return Nothing)

380 await' = NeedInput (return . Just) (const $ return Nothing)

350 yield' = HaveOutput (return ()) (return ())

381 yield' = HaveOutput (return ()) (return ())

382+-}

351

383

352parseAttrs :: S.ByteString -> [(S.ByteString, S.ByteString)]

384parseAttrs :: S.ByteString -> [(S.ByteString, S.ByteString)]

353parseAttrs = map go . S.split 59 -- semicolon

385parseAttrs = map go . S.split 59 -- semicolon

wai-extra/test/WaiExtraTest.hs+25−22

@@ -30,9 +30,6 @@ import Network.Wai.Middleware.AcceptOverride

30import Network.Wai.Middleware.RequestLogger

31import Codec.Compression.GZip (decompress)

33−import qualified Data.Conduit as C

34−import qualified Data.Conduit.List as CL

35−import Data.Conduit.Binary (sourceHandle)

36import Control.Monad.IO.Class (liftIO)

33import Control.Monad.IO.Class (liftIO)

37import Data.Maybe (fromMaybe)

34import Data.Maybe (fromMaybe)

38import Network.HTTP.Types (parseSimpleQuery, status200)

35import Network.HTTP.Types (parseSimpleQuery, status200)

@@ -128,7 +125,13 @@ parseRequestBody' :: BackEnd file

128parseRequestBody' sink (SRequest req bod) =

125parseRequestBody' sink (SRequest req bod) =

129 case getRequestBodyType req of

126 case getRequestBodyType req of

130 Nothing -> return ([], [])

127 Nothing -> return ([], [])

128+ Just rbt -> do

129+ ref <- I.newIORef $ L.toChunks bod

130+ let rb = I.atomicModifyIORef ref $ \chunks ->

131+ case chunks of

132+ [] -> ([], S.empty)

133+ x:y -> (y, x)

131− Just rbt -> CL.sourceList (L.toChunks bod) C.$$ sinkRequestBody sink rbt

134+ sinkRequestBody sink rbt rb

132

135

133caseParseRequestBody :: Assertion

136caseParseRequestBody :: Assertion

134caseParseRequestBody =

137caseParseRequestBody =

@@ -295,7 +298,7 @@ caseTakeLine = do

295-}

298-}

296

299

297jsonpApp :: Application

300jsonpApp :: Application

298−jsonpApp = jsonp $ const $ return $ responseLBS

301+jsonpApp = jsonp $ \_ f -> f $ responseLBS

299 status200

302 status200

300 [("Content-Type", "application/json")]

303 [("Content-Type", "application/json")]

301 "{\"foo\":\"bar\"}"

304 "{\"foo\":\"bar\"}"

@@ -324,7 +327,7 @@ caseJsonp = flip runSession jsonpApp $ do

324 assertBody "{\"foo\":\"bar\"}" sres3

327 assertBody "{\"foo\":\"bar\"}" sres3

325

328

326gzipApp :: Application

329gzipApp :: Application

327−gzipApp = gzip def $ const $ return $ responseLBS status200

330+gzipApp = gzip def $ \_ f -> f $ responseLBS status200

328 [("Content-Type", "text/plain")]

331 [("Content-Type", "text/plain")]

329 "test"

332 "test"

330

333

@@ -332,7 +335,7 @@ gzipApp = gzip def $ const $ return $ responseLBS status200

332-- that the compression is skipped based on the presence of

335-- that the compression is skipped based on the presence of

333-- the Content-Encoding header.

336-- the Content-Encoding header.

334gzipPrecompressedApp :: Application

337gzipPrecompressedApp :: Application

335−gzipPrecompressedApp = gzip def $ const $ return $ responseLBS status200

338+gzipPrecompressedApp = gzip def $ \_ f -> f $ responseLBS status200

336 [("Content-Type", "text/plain"), ("Content-Encoding", "gzip")]

339 [("Content-Type", "text/plain"), ("Content-Encoding", "gzip")]

337 "test"

340 "test"

338

341

@@ -380,8 +383,8 @@ caseGzipBypassPre = flip runSession gzipPrecompressedApp $ do

380 assertBody "test" sres1 -- the body is not actually compressed

383 assertBody "test" sres1 -- the body is not actually compressed

381

384

382vhostApp1, vhostApp2, vhostApp :: Application

385vhostApp1, vhostApp2, vhostApp :: Application

383−vhostApp1 = const $ return $ responseLBS status200 [] "app1"

386+vhostApp1 _ f = f $ responseLBS status200 [] "app1"

384−vhostApp2 = const $ return $ responseLBS status200 [] "app2"

387+vhostApp2 _ f = f $ responseLBS status200 [] "app2"

385vhostApp = vhost

388vhostApp = vhost

386 [ ((== Just "foo.com") . lookup "host" . requestHeaders, vhostApp1)

389 [ ((== Just "foo.com") . lookup "host" . requestHeaders, vhostApp1)

387 ]

390 ]

@@ -400,7 +403,7 @@ caseVhost = flip runSession vhostApp $ do

400 assertBody "app2" sres2

403 assertBody "app2" sres2

401

404

402autoheadApp :: Application

405autoheadApp :: Application

403−autoheadApp = autohead $ const $ return $ responseLBS status200

406+autoheadApp = autohead $ \_ f -> f $ responseLBS status200

404 [("Foo", "Bar")] "body"

407 [("Foo", "Bar")] "body"

405

408

406caseAutohead :: Assertion

409caseAutohead :: Assertion

@@ -418,7 +421,7 @@ caseAutohead = flip runSession autoheadApp $ do

418 assertBody "" sres2

421 assertBody "" sres2

419

422

420moApp :: Application

423moApp :: Application

421−moApp = methodOverride $ \req -> return $ responseLBS status200

424+moApp = methodOverride $ \req f -> f $ responseLBS status200

422 [("Method", requestMethod req)] ""

425 [("Method", requestMethod req)] ""

423

426

424caseMethodOverride :: Assertion

427caseMethodOverride :: Assertion

@@ -442,7 +445,7 @@ caseMethodOverride = flip runSession moApp $ do

442 assertHeader "Method" "PUT" sres3

445 assertHeader "Method" "PUT" sres3

443

446

444mopApp :: Application

447mopApp :: Application

445−mopApp = methodOverridePost $ \req -> return $ responseLBS status200 [("Method", requestMethod req)] ""

448+mopApp = methodOverridePost $ \req f -> f $ responseLBS status200 [("Method", requestMethod req)] ""

446

449

447caseMethodOverridePost :: Assertion

450caseMethodOverridePost :: Assertion

448caseMethodOverridePost = flip runSession mopApp $ do

451caseMethodOverridePost = flip runSession mopApp $ do

@@ -468,7 +471,7 @@ caseMethodOverridePost = flip runSession mopApp $ do

468 assertHeader "Method" "POST" sres4

471 assertHeader "Method" "POST" sres4

469

472

470aoApp :: Application

473aoApp :: Application

471−aoApp = acceptOverride $ \req -> return $ responseLBS status200

474+aoApp = acceptOverride $ \req f -> f $ responseLBS status200

472 [("Accept", fromMaybe "" $ lookup "Accept" $ requestHeaders req)] ""

475 [("Accept", fromMaybe "" $ lookup "Accept" $ requestHeaders req)] ""

473

476

474caseAcceptOverride :: Assertion

477caseAcceptOverride :: Assertion

@@ -520,7 +523,7 @@ dalvikHelper includeLength = do

520 case getRequestBodyType request' of

523 case getRequestBodyType request' of

521 Nothing -> return ([], [])

524 Nothing -> return ([], [])

522 Just rbt -> withFile "test/requests/dalvik-request" ReadMode $ \h ->

525 Just rbt -> withFile "test/requests/dalvik-request" ReadMode $ \h ->

523− sourceHandle h C.$$ sinkRequestBody lbsBackEnd rbt

526+ sinkRequestBody lbsBackEnd rbt $ S.hGetSome h 2048

524 lookup "scannedTime" params @?= Just "1.298590056748E9"

527 lookup "scannedTime" params @?= Just "1.298590056748E9"

525 lookup "geoLong" params @?= Just "0"

528 lookup "geoLong" params @?= Just "0"

526 lookup "geoLat" params @?= Just "0"

529 lookup "geoLat" params @?= Just "0"

@@ -548,15 +551,15 @@ caseDebugRequestBody = do

548 postOutput = T.pack $ "POST / :: \nStatus: 200 OK. /\n"

551 postOutput = T.pack $ "POST / :: \nStatus: 200 OK. /\n"

549 getOutput params' = T.pack $ "GET /location :: \nGET " ++ show params' ++ "\nStatus: 200 OK. /location\n"

552 getOutput params' = T.pack $ "GET /location :: \nGET " ++ show params' ++ "\nStatus: 200 OK. /location\n"

550

553

551− debugApp output' req = do

554+ debugApp output' req send = do

552− iactual <- liftIO $ I.newIORef mempty

555+ iactual <- I.newIORef mempty

553− middleware <- liftIO $ mkRequestLogger def

556+ middleware <- mkRequestLogger def

554 { destination = Callback $ \strs -> I.modifyIORef iactual $ (`mappend` strs)

557 { destination = Callback $ \strs -> I.modifyIORef iactual $ (`mappend` strs)

555 , outputFormat = Detailed False

558 , outputFormat = Detailed False

556 }

559 }

557− res <- middleware (\_req -> return $ responseLBS status200 [ ] "") req

560+ res <- middleware (\_req f -> f $ responseLBS status200 [ ] "") req send

558− actual <- liftIO $ I.readIORef iactual

561+ actual <- I.readIORef iactual

559− liftIO $ assertEqual "debug" output $ logToBs actual

562+ assertEqual "debug" output $ logToBs actual

560 return res

563 return res

561 where

564 where

562 output = TE.encodeUtf8 $ T.toStrict output'

565 output = TE.encodeUtf8 $ T.toStrict output'

@@ -578,8 +581,8 @@ urlMapTestApp = mapUrls $

578

581

579 where

582 where

580 trivialApp :: S.ByteString -> Application

583 trivialApp :: S.ByteString -> Application

581− trivialApp name req =

584+ trivialApp name req f =

582− return $

585+ f $

583 responseLBS

586 responseLBS

584 status200

587 status200

585 [ ("content-type", "text/plain")

588 [ ("content-type", "text/plain")

wai-extra/wai-extra.cabal+1−2

@@ -78,7 +78,6 @@ test-suite tests

79 build-depends: base >= 4 && < 5

80 , wai-extra

81− , wai-test >= 1.3

82 , hspec >= 1.3

81 , hspec >= 1.3

83 , HUnit

82 , HUnit

@@ -102,7 +101,7 @@ test-suite spec

102 main-is: Spec.hs

101 main-is: Spec.hs

103 other-modules: Network.Wai.TestSpec

102 other-modules: Network.Wai.TestSpec

104 build-depends: base >= 4 && < 5

103 build-depends: base >= 4 && < 5

105− , wai-test

104+ , wai-extra

106 , wai

105 , wai

107 , hspec >= 1.3

106 , hspec >= 1.3

108 ghc-options: -Wall -Werror

107 ghc-options: -Wall -Werror