1fd0671 · typeable/wai

git.iko.soy/typeable/wai

on master help sign in

Some minor fixes

1fd0671Michael Snoyman13 years ago

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

compare with master

unifiedsplit

@@ -245,7 +245,7 @@ detailedMiddleware' cb getAddColor app req = do

245 allPostParams body =

246 case getRequestBodyType req of

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

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

248+ Just rbt -> CL.sourceList body C.$$ sinkRequestBody (resourceInternalState req) lbsBackEnd rbt

249

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

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

wai-extra/Network/Wai/Parse.hs+20−58

@@ -51,13 +51,9 @@ import qualified Network.HTTP.Types as H

51import Data.Either (partitionEithers)

52import Control.Monad (when, unless)

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

54−import Control.Monad.Trans.Resource (allocate, release, register)

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

55−#if MIN_VERSION_conduit(1, 0, 0)

56import Data.Conduit.Internal (Pipe (NeedInput, HaveOutput), (>+>), withUpstream, injectLeftovers, ConduitM (..))

55import Data.Conduit.Internal (Pipe (NeedInput, HaveOutput), (>+>), withUpstream, injectLeftovers, ConduitM (..))

57import Data.Void (Void)

56import Data.Void (Void)

58−#else

59−import Data.Conduit.Internal (sinkToPipe)

60−#endif

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

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

63breakDiscard w s =

59breakDiscard w s =

@@ -130,7 +126,7 @@ type File y = (S.ByteString, FileInfo y)

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

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

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

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

132 -> FileInfo ()

128 -> FileInfo ()

133− -> Sink S.ByteString IO a

129+ -> Sink S.ByteString (ResourceT IO) a

134

130

135data RequestBodyType = UrlEncoded | Multipart S.ByteString

131data RequestBodyType = UrlEncoded | Multipart S.ByteString

136

132

@@ -173,30 +169,28 @@ parseRequestBody :: BackEnd y

173parseRequestBody s r =

169parseRequestBody s r =

174 case getRequestBodyType r of

170 case getRequestBodyType r of

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

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

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

172+ Just rbt -> fmap partitionEithers $ requestBody r $$ conduitRequestBody (resourceInternalState r) s rbt =$ CL.consume

177

173

178−sinkRequestBody :: BackEnd y

174+sinkRequestBody :: InternalState

175+ -> BackEnd y

179 -> RequestBodyType

176 -> RequestBodyType

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

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

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

178+sinkRequestBody internalState s r = fmap partitionEithers $ conduitRequestBody internalState s r =$ CL.consume

182

179

183−conduitRequestBody :: BackEnd y

180+conduitRequestBody :: InternalState

181+ -> BackEnd y

184 -> RequestBodyType

182 -> RequestBodyType

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

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

186−conduitRequestBody _ UrlEncoded = do

184+conduitRequestBody _ _ UrlEncoded = do

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

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

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

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

189 -- strict byte strings here.

187 -- strict byte strings here.

190 bs <- CL.consume

188 bs <- CL.consume

191 mapM_ yield $ map Left $ H.parseSimpleQuery $ S.concat bs

189 mapM_ yield $ map Left $ H.parseSimpleQuery $ S.concat bs

192−conduitRequestBody backend (Multipart bound) =

190+conduitRequestBody internalState backend (Multipart bound) =

193− parsePieces backend $ S8.pack "--" `S.append` bound

191+ parsePieces internalState backend $ S8.pack "--" `S.append` bound

194

192

195−#if MIN_VERSION_conduit(1, 0, 0)

196takeLine :: Monad m => Consumer S.ByteString m (Maybe S.ByteString)

193takeLine :: Monad m => Consumer S.ByteString m (Maybe S.ByteString)

197−#else

198−takeLine :: Monad m => Pipe S.ByteString S.ByteString o u m (Maybe S.ByteString)

199−#endif

200takeLine =

194takeLine =

201 go id

195 go id

202 where

196 where

@@ -211,11 +205,7 @@ takeLine =

211 when (S.length y > 1) $ leftover $ S.drop 1 y

205 when (S.length y > 1) $ leftover $ S.drop 1 y

212 return $ Just $ killCR x

206 return $ Just $ killCR x

213

207

214−#if MIN_VERSION_conduit(1, 0, 0)

215takeLines :: Consumer S.ByteString IO [S.ByteString]

208takeLines :: Consumer S.ByteString IO [S.ByteString]

216−#else

217−takeLines :: Pipe S.ByteString S.ByteString o u IO [S.ByteString]

218−#endif

219takeLines = do

209takeLines = do

220 res <- takeLine

210 res <- takeLine

221 case res of

211 case res of

@@ -226,14 +216,11 @@ takeLines = do

226 ls <- takeLines

216 ls <- takeLines

227 return $ l : ls

217 return $ l : ls

228

218

219+parsePieces :: InternalState

229−parsePieces :: BackEnd y

220+ -> BackEnd y

230 -> S.ByteString

221 -> S.ByteString

231−#if MIN_VERSION_conduit(1, 0, 0)

232 -> ConduitM S.ByteString (Either Param (File y)) IO ()

222 -> ConduitM S.ByteString (Either Param (File y)) IO ()

233−#else

234− -> Pipe S.ByteString S.ByteString (Either Param (File y)) u IO ()

235−#endif

236−parsePieces sink bound =

223+parsePieces internalState sink bound =

237 loop

224 loop

238 where

225 where

239 loop = do

226 loop = do

@@ -251,7 +238,7 @@ parsePieces sink bound =

251 Just (mct, name, Just filename) -> do

238 Just (mct, name, Just filename) -> do

252 let ct = fromMaybe "application/octet-stream" mct

239 let ct = fromMaybe "application/octet-stream" mct

253 fi0 = FileInfo filename ct ()

240 fi0 = FileInfo filename ct ()

254− (wasFound, y) <- sinkTillBound' bound name fi0 sink

241+ (wasFound, y) <- sinkTillBound' internalState bound name fi0 sink

255 yield $ Right (name, fi0 { fileContent = y })

242 yield $ Right (name, fi0 { fileContent = y })

256 when wasFound loop

243 when wasFound loop

257 Just (_ct, name, Nothing) -> do

244 Just (_ct, name, Nothing) -> do

@@ -303,45 +290,30 @@ findBound b bs = handleBreak $ Search.breakOn b bs

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

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

304 | otherwise = True

291 | otherwise = True

305

292

293+sinkTillBound' :: InternalState

306−sinkTillBound' :: S.ByteString

294+ -> S.ByteString

307 -> S.ByteString

295 -> S.ByteString

308 -> FileInfo ()

296 -> FileInfo ()

309 -> BackEnd y

297 -> BackEnd y

310−#if MIN_VERSION_conduit(1, 0, 0)

311 -> ConduitM S.ByteString o IO (Bool, y)

298 -> ConduitM S.ByteString o IO (Bool, y)

312−#else

313− -> Pipe S.ByteString S.ByteString o u IO (Bool, y)

314−#endif

315−sinkTillBound' bound name fi sink =

299+sinkTillBound' internalState bound name fi sink =

316−#if MIN_VERSION_conduit(1, 0, 0)

317 ConduitM $ anyOutput $

300 ConduitM $ anyOutput $

318−#endif

319 conduitTillBound bound >+> withUpstream (fix $ sink name fi)

301 conduitTillBound bound >+> withUpstream (fix $ sink name fi)

320 where

302 where

321−#if MIN_VERSION_conduit(1, 0, 0)

322− fix :: Sink S8.ByteString IO y -> Pipe Void S8.ByteString Void Bool IO y

303+ fix :: Sink S8.ByteString (ResourceT IO) y -> Pipe Void S8.ByteString Void Bool IO y

323− fix (ConduitM p) = ignoreTerm >+> injectLeftovers p

304+ fix p = ignoreTerm >+> injectLeftovers (unConduitM $ transPipe (flip runInternalState internalState) p)

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

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

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

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

326 yield' = HaveOutput (return ()) (return ())

307 yield' = HaveOutput (return ()) (return ())

327

308

328 anyOutput p = p >+> dropInput

309 anyOutput p = p >+> dropInput

329 dropInput = NeedInput (const dropInput) return

310 dropInput = NeedInput (const dropInput) return

330−#else

331− fix = sinkToPipe

332−#endif

333

311

334conduitTillBound :: Monad m

312conduitTillBound :: Monad m

335 => S.ByteString -- bound

313 => S.ByteString -- bound

336−#if MIN_VERSION_conduit(1, 0, 0)

337 -> Pipe S.ByteString S.ByteString S.ByteString () m Bool

314 -> Pipe S.ByteString S.ByteString S.ByteString () m Bool

338−#else

339− -> Pipe S.ByteString S.ByteString S.ByteString u m Bool

340−#endif

341conduitTillBound bound =

315conduitTillBound bound =

342−#if MIN_VERSION_conduit(1, 0, 0)

343 unConduitM $

316 unConduitM $

344−#endif

345 go id

317 go id

346 where

318 where

347 go front = await >>= maybe (close front) (push front)

319 go front = await >>= maybe (close front) (push front)

@@ -371,26 +343,16 @@ conduitTillBound bound =

371sinkTillBound :: S.ByteString

343sinkTillBound :: S.ByteString

372 -> (x -> S.ByteString -> IO x)

344 -> (x -> S.ByteString -> IO x)

373 -> x

345 -> x

374−#if MIN_VERSION_conduit(1, 0, 0)

375 -> Consumer S.ByteString IO (Bool, x)

346 -> Consumer S.ByteString IO (Bool, x)

376−#else

377− -> Pipe S.ByteString S.ByteString o u IO (Bool, x)

378−#endif

379sinkTillBound bound iter seed0 =

347sinkTillBound bound iter seed0 =

380−#if MIN_VERSION_conduit(1, 0, 0)

381 ConduitM $

348 ConduitM $

382−#endif

383 (conduitTillBound bound >+> (withUpstream $ ij $ CL.foldM iter' seed0))

349 (conduitTillBound bound >+> (withUpstream $ ij $ CL.foldM iter' seed0))

384 where

350 where

385 iter' a b = liftIO $ iter a b

351 iter' a b = liftIO $ iter a b

386−#if MIN_VERSION_conduit(1, 0, 0)

387 ij (ConduitM p) = ignoreTerm >+> injectLeftovers p

352 ij (ConduitM p) = ignoreTerm >+> injectLeftovers p

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

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

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

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

390 yield' = HaveOutput (return ()) (return ())

355 yield' = HaveOutput (return ()) (return ())

391−#else

392− ij = id

393−#endif

394

356

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

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

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

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

wai-extra/test/WaiExtraTest.hs+6−3

@@ -15,6 +15,7 @@ import qualified Data.Text.Lazy as T

15import qualified Data.Text as TS

16import qualified Data.Text.Encoding as TE

17import Control.Arrow

18+import Control.Monad.Trans.Resource (getInternalState)

19import Network.Wai.Middleware.Jsonp

20import Network.Wai.Middleware.Jsonp

20import Network.Wai.Middleware.Gzip

21import Network.Wai.Middleware.Gzip

@@ -119,7 +120,7 @@ parseRequestBody' :: BackEnd L.ByteString

119parseRequestBody' sink (SRequest req bod) =

120parseRequestBody' sink (SRequest req bod) =

120 case getRequestBodyType req of

121 case getRequestBodyType req of

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

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

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

123+ Just rbt -> CL.sourceList (L.toChunks bod) C.$$ sinkRequestBody (resourceInternalState req) sink rbt

123

124

124caseParseRequestBody :: Assertion

125caseParseRequestBody :: Assertion

125caseParseRequestBody =

126caseParseRequestBody =

@@ -493,8 +494,10 @@ dalvikHelper includeLength = do

493 (params, files) <-

494 (params, files) <-

494 case getRequestBodyType request' of

495 case getRequestBodyType request' of

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

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

497+ Just rbt -> C.runResourceT $ do

498+ internalState <- getInternalState

496− Just rbt -> C.runResourceT $ sourceFile "test/requests/dalvik-request"

499+ sourceFile "test/requests/dalvik-request"

497− C.$$ C.transPipe liftIO (sinkRequestBody lbsBackEnd rbt)

500+ C.$$ C.transPipe liftIO (sinkRequestBody internalState lbsBackEnd rbt)

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

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

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

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

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

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

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

@@ -36,7 +36,7 @@ Library

36 , date-cache >= 0.3 && < 0.4

37 , fast-logger >= 0.2 && < 0.4

38 , wai-logger >= 0.2 && < 0.4

39− , conduit >= 0.5 && < 1.1

39+ , conduit >= 1.0 && < 1.1

40 , zlib-conduit >= 0.5 && < 1.1

41 , blaze-builder-conduit >= 0.5 && < 1.1

42 , ansi-terminal

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

86 , data-default

87 , conduit

88 , fast-logger

89+ , resourcet

89 ghc-options: -Wall

90 ghc-options: -Wall

91source-repository head

92source-repository head

warp/warp.cabal+1−1

@@ -51,6 +51,7 @@ Library

51 else

52 Build-Depends: network >= 2.3

53 Exposed-modules: Network.Wai.Handler.Warp

54+ Network.Wai.Handler.Warp.Timeout

54 Other-modules: Network.Wai.Handler.Warp.Conduit

55 Other-modules: Network.Wai.Handler.Warp.Conduit

55 Network.Wai.Handler.Warp.ReadInt

56 Network.Wai.Handler.Warp.ReadInt

56 Network.Wai.Handler.Warp.Request

57 Network.Wai.Handler.Warp.Request

@@ -58,7 +59,6 @@ Library

58 Network.Wai.Handler.Warp.ResponseHeader

59 Network.Wai.Handler.Warp.ResponseHeader

59 Network.Wai.Handler.Warp.Run

60 Network.Wai.Handler.Warp.Run

60 Network.Wai.Handler.Warp.Settings

61 Network.Wai.Handler.Warp.Settings

61− Network.Wai.Handler.Warp.Timeout

62 Network.Wai.Handler.Warp.Types

63 Paths_warp

64 Ghc-Options: -Wall