git.iko.soy/typeable/wai
on master help sign in
conduitRequestBody (yesodweb/yesod#208)
5c56adbMichael Snoyman
wai-extra/Network/Wai/Parse.hs+26−20
compare with master
unifiedsplit
@@ -5,6 +5,7 @@
5module Network.Wai.Parse
5module Network.Wai.Parse
6 ( parseHttpAccept
6 ( parseHttpAccept
7 , parseRequestBody
7 , parseRequestBody
8+ , conduitRequestBody
8 , Sink (..)
9 , Sink (..)
9 , lbsSink
10 , lbsSink
10 , tempFileSink
11 , tempFileSink
@@ -36,6 +37,7 @@ import qualified Data.Conduit as C
36import qualified Data.Conduit.List as CL
37import qualified Data.Conduit.List as CL
37import Control.Monad.IO.Class (liftIO)
38import Control.Monad.IO.Class (liftIO)
38import qualified Network.HTTP.Types as H
39import qualified Network.HTTP.Types as H
40+import Data.Either (partitionEithers)
39
41
40uncons :: S.ByteString -> Maybe (Word8, S.ByteString)
42uncons :: S.ByteString -> Maybe (Word8, S.ByteString)
41uncons s
43uncons s
@@ -129,15 +131,23 @@ type File y = (S.ByteString, FileInfo y)
129parseRequestBody :: Sink x y
131parseRequestBody :: Sink x y
130 -> Request
132 -> Request
131 -> C.Sink S.ByteString IO ([Param], [File y])
133 -> C.Sink S.ByteString IO ([Param], [File y])
132−parseRequestBody sink req = do
134+parseRequestBody s r = fmap partitionEithers $ conduitRequestBody s r C.=$ CL.consume
135+
136+conduitRequestBody :: Sink x y
137+ -> Request
138+ -> C.Conduit S.ByteString IO (Either Param (File y))
139+conduitRequestBody sink req = do
133 case ctype of
140 case ctype of
134− Nothing -> return ([], [])
141+ Nothing -> C.Conduit $ return $ C.PreparedConduit
142+ { C.conduitPush = \bs -> return $ C.Finished (Just bs) []
143+ , C.conduitClose = return []
144+ }
135− Just Nothing -> do -- url-encoded
145+ Just Nothing -> C.sequenceSink () $ \() -> do -- url-encoded
136 -- NOTE: in general, url-encoded data will be in a single chunk.
146 -- NOTE: in general, url-encoded data will be in a single chunk.
137 -- Therefore, I'm optimizing for the usual case by sticking with
147 -- Therefore, I'm optimizing for the usual case by sticking with
138 -- strict byte strings here.
148 -- strict byte strings here.
139 bs <- CL.consume
149 bs <- CL.consume
140− return (H.parseSimpleQuery $ S.concat bs, [])
150+ return $ C.Emit () $ map Left $ H.parseSimpleQuery $ S.concat bs
141 Just (Just bound) -> -- multi-part
151 Just (Just bound) -> -- multi-part
142 let bound'' = S8.pack "--" `S.append` bound
152 let bound'' = S8.pack "--" `S.append` bound
143 in parsePieces sink bound''
153 in parsePieces sink bound''
@@ -186,12 +196,18 @@ takeLines = do
186 return $ l : ls
196 return $ l : ls
187
197
188parsePieces :: Sink x y -> S.ByteString
198parsePieces :: Sink x y -> S.ByteString
199+ -> C.Conduit S.ByteString IO (Either Param (File y))
200+parsePieces sink bound = C.sequenceSink True (parsePiecesSink sink bound)
201+
202+parsePiecesSink :: Sink x y
189− -> C.Sink S.ByteString IO ([Param], [File y])
203+ -> S.ByteString
204+ -> C.SequencedSink Bool S.ByteString IO (Either Param (File y))
205+parsePiecesSink _ _ False = return C.Stop
190−parsePieces sink bound = do
206+parsePiecesSink sink bound True = do
191 _boundLine <- takeLine
207 _boundLine <- takeLine
192 res' <- takeLines
208 res' <- takeLines
193 case res' of
209 case res' of
194− [] -> return ([], [])
210+ [] -> return C.Stop
195 _ -> do
211 _ -> do
196 let ls' = map parsePair res'
212 let ls' = map parsePair res'
197 let x = do
213 let x = do
@@ -209,11 +225,7 @@ parsePieces sink bound = do
209 y <- liftIO $ sinkClose sink seed'
225 y <- liftIO $ sinkClose sink seed'
210 let fi = FileInfo filename ct y
226 let fi = FileInfo filename ct y
211 let y' = (name, fi)
227 let y' = (name, fi)
212− (xs, ys) <-
213− if wasFound
228+ return $ C.Emit wasFound [Right y']
214− then parsePieces sink bound
215− else return ([], [])
216− return (xs, y' : ys)
217 Just (_ct, name, Nothing) -> do
229 Just (_ct, name, Nothing) -> do
218 let seed = id
230 let seed = id
219 let iter front bs = return $ front . (:) bs
231 let iter front bs = return $ front . (:) bs
@@ -221,19 +233,13 @@ parsePieces sink bound = do
221 sinkTillBound bound iter seed
233 sinkTillBound bound iter seed
222 let bs = S.concat $ front []
234 let bs = S.concat $ front []
223 let x' = (name, qsDecode bs)
235 let x' = (name, qsDecode bs)
224− (xs, ys) <-
225− if wasFound
236+ return $ C.Emit wasFound [Left x']
226− then parsePieces sink bound
227− else return ([], [])
228− return (x' : xs, ys)
229 _ -> do
237 _ -> do
230 -- ignore this part
238 -- ignore this part
231 let seed = ()
239 let seed = ()
232 iter () _ = return ()
240 iter () _ = return ()
233 ((), wasFound) <- sinkTillBound bound iter seed
241 ((), wasFound) <- sinkTillBound bound iter seed
234− if wasFound
235− then parsePieces sink bound
236− else return ([], [])
242+ return $ C.Emit wasFound []
237 where
243 where
238 contDisp = S8.pack "Content-Disposition"
244 contDisp = S8.pack "Content-Disposition"
239 contType = S8.pack "Content-Type"
245 contType = S8.pack "Content-Type"