@@ -10,15 +10,11 @@ module Network.Wai.Parse
1010 , getRequestBodyType
1111 , sinkRequestBody
1212 , conduitRequestBody
13− , lbsBackEnd
14− , tempFileBackEnd
15− , BackEnd (..)
13+ , lbsSink
14+ , tempFileSink
1615 , Param
1716 , File
1817 , FileInfo (..)
19− -- ** Deprecated
20− , lbsSink
21− , tempFileSink
2218#if TEST
2319 , Bound (..)
2420 , findBound
@@ -42,9 +38,13 @@ import System.IO (hClose, openBinaryTempFile)
4238import Network.Wai
4339import qualified Data.Conduit as C
4440import qualified Data.Conduit.List as CL
41+import qualified Data.Conduit.Binary as CB
4542import Control.Monad.IO.Class (liftIO)
4643import qualified Network.HTTP.Types as H
4744import Data.Either (partitionEithers)
45+import Control.Monad.Trans.Class (lift)
46+import Control.Monad.Trans.Resource (allocate, release, register)
47+import Data.Void (absurd)
4848
4949uncons :: S.ByteString -> Maybe (Word8, S.ByteString)
5050uncons s
@@ -96,47 +96,20 @@ parseHttpAccept = map fst
9696 _ -> 1.0
9797 trimWhite = S.dropWhile (== 32) -- space
9898
99−-- | A destination for file data, with concrete implemtations
100−-- provided by 'lbsBackEnd' and 'tempFileBackEnd'
101−data BackEnd y = forall x . BackEnd
102− { initialize :: IO x
103− , append :: x -> S.ByteString -> IO x
104− , close :: x -> IO y
105− , finalize :: y -> IO ()
106− }
107−
10899-- | Store uploaded files in memory
109−lbsBackEnd :: BackEnd L.ByteString
110−lbsBackEnd = BackEnd
111− { initialize = return id
112− , append = \front bs -> return $ front . (:) bs
113− , close = \front -> return $ L.fromChunks $ front []
114− , finalize = \_ -> return ()
115− }
100+lbsSink :: Monad m => C.Sink S.ByteString m L.ByteString
101+lbsSink = fmap L.fromChunks CL.consume
116102
117103-- | Save uploaded files on disk as temporary files
118−tempFileBackEnd :: BackEnd FilePath
119−tempFileBackEnd = BackEnd
120− { initialize = do
104+tempFileSink :: C.MonadResource m => C.Sink S.ByteString m FilePath
105+tempFileSink = do
106+ (key, (fp, h)) <- lift $ allocate (do
121107 tempDir <- getTemporaryDirectory
122− openBinaryTempFile tempDir "webenc.buf"
123− , append = \(fp, h) bs -> S.hPut h bs >> return (fp, h)
124− , close = \(fp, h) -> do
125− hClose h
126− return fp
127− , finalize = \fp -> removeFile fp
128− }
129−
130−-- | This function has been renamed to 'lbsBackEnd'
131−lbsSink :: BackEnd L.ByteString
132−lbsSink = lbsBackEnd
133−
134−-- | This function has been renamed to 'tempFileBackEnd'
135−tempFileSink :: BackEnd FilePath
136−tempFileSink = tempFileBackEnd
137−
138−{-# DEPRECATED lbsSink "Please use 'lbsBackEnd'" #-}
139−{-# DEPRECATED tempFileSink "Please use 'tempFileBackEnd'" #-}
108+ openBinaryTempFile tempDir "webenc.buf") (\(_, h) -> hClose h)
109+ _ <- lift $ register $ removeFile fp
110+ CB.sinkHandle h
111+ lift $ release key
112+ return fp
140113
141114-- | Information on an uploaded file.
142115data FileInfo c = FileInfo
@@ -172,7 +145,7 @@ getRequestBodyType req = do
172145 else Nothing
173146 else Nothing
174147
175−parseRequestBody :: BackEnd y
148+parseRequestBody :: C.Sink S.ByteString (C.ResourceT IO) y
176149 -> Request
177150 -> C.ResourceT IO ([Param], [File y])
178151parseRequestBody s r =
@@ -180,12 +153,12 @@ parseRequestBody s r =
180153 Nothing -> return ([], [])
181154 Just rbt -> fmap partitionEithers $ requestBody r C.$$ conduitRequestBody s rbt C.=$ CL.consume
182155
183−sinkRequestBody :: BackEnd y
156+sinkRequestBody :: C.Sink S.ByteString (C.ResourceT IO) y
184157 -> RequestBodyType
185158 -> C.Sink S.ByteString (C.ResourceT IO) ([Param], [File y])
186159sinkRequestBody s r = fmap partitionEithers $ conduitRequestBody s r C.=$ CL.consume
187160
188−conduitRequestBody :: BackEnd y
161+conduitRequestBody :: C.Sink S.ByteString (C.ResourceT IO) y
189162 -> RequestBodyType
190163 -> C.Conduit S.ByteString (C.ResourceT IO) (Either Param (File y))
191164conduitRequestBody _ UrlEncoded = C.sequenceSink () $ \() -> do -- url-encoded
@@ -221,16 +194,15 @@ takeLines = do
221194 ls <- takeLines
222195 return $ l : ls
223196
224−parsePieces :: BackEnd y -> S.ByteString
197+parsePieces :: C.Sink S.ByteString (C.ResourceT IO) y -> S.ByteString
225198 -> C.Conduit S.ByteString (C.ResourceT IO) (Either Param (File y))
226199parsePieces sink bound = C.sequenceSink True (parsePiecesSink sink bound)
227200
228−parsePiecesSink :: BackEnd y
201+parsePiecesSink :: C.Sink S.ByteString (C.ResourceT IO) y
229202 -> S.ByteString
230203 -> C.SequencedSink Bool S.ByteString (C.ResourceT IO) (Either Param (File y))
231204parsePiecesSink _ _ False = return C.Stop
232−parsePiecesSink BackEnd{initialize=initialize',append=append',close=close'}
233− bound True = do
205+parsePiecesSink sink bound True = do
234206 _boundLine <- takeLine
235207 res' <- takeLines
236208 case res' of
@@ -246,10 +218,7 @@ parsePiecesSink BackEnd{initialize=initialize',append=append',close=close'}
246218 case x of
247219 Just (mct, name, Just filename) -> do
248220 let ct = fromMaybe "application/octet-stream" mct
249− seed <- liftIO initialize'
250− (seed', wasFound) <-
251− sinkTillBound bound append' seed
252− y <- liftIO $ close' seed'
221+ (y, wasFound) <- sinkTillBound' Nothing bound sink
253222 let fi = FileInfo filename ct y
254223 let y' = (name, fi)
255224 return $ C.Emit wasFound [Right y']
@@ -296,6 +265,31 @@ findBound b bs = go [0..S.length bs - 1]
296265 | S.index b x == S.index bs y = mismatch xs ys
297266 | otherwise = True
298267
268+sinkTillBound' :: Maybe S.ByteString -> S.ByteString -> C.Sink S.ByteString (C.ResourceT IO) y -> C.Sink S.ByteString (C.ResourceT IO) (y, Bool)
269+sinkTillBound' mfront _ (C.Done _ y) = C.Done mfront (y, False)
270+sinkTillBound' _ _ (C.HaveOutput _ _ o) = absurd o
271+sinkTillBound' mfront bound (C.PipeM mp mc) = C.PipeM (fmap (sinkTillBound' mfront bound) mp) (fmap (\y -> (y, False)) mc)
272+sinkTillBound' mfront bound (C.NeedInput pushI closeI) =
273+ C.NeedInput push close
274+ where
275+ push bs' = do
276+ let bs = maybe id S.append mfront $ bs'
277+ case findBound bound bs of
278+ FoundBound before after -> do
279+ let before' = killCRLF before
280+ res <- lift $ return () C.$$ pushI before'
281+ C.Done (Just after) (res, True)
282+ NoBound -> do
283+ -- don't emit newlines, in case it's part of a bound
284+ let (toEmit, front') =
285+ if not (S8.null bs) && S8.last bs `elem` "\r\n"
286+ then let (x, y) = S.splitAt (S.length bs - 2) bs
287+ in (x, Just y)
288+ else (bs, Nothing)
289+ sinkTillBound' front' bound (pushI toEmit)
290+ PartialBound -> sinkTillBound' (Just bs) bound (C.NeedInput pushI closeI)
291+ close = fmap (\y -> (y, False)) closeI
292+
299293sinkTillBound :: S.ByteString
300294 -> (x -> S.ByteString -> IO x)
301295 -> x