diff --git a/Network/Wai/Middleware/RequestLogger.hs b/Network/Wai/Middleware/RequestLogger.hs --- a/Network/Wai/Middleware/RequestLogger.hs +++ b/Network/Wai/Middleware/RequestLogger.hs @@ -261,8 +261,7 @@ allPostParams body = case getRequestBodyType req of Nothing -> return ([], []) - Just rbt -> C.runResourceT $ withInternalState $ \internalState -> - CL.sourceList body C.$$ sinkRequestBody internalState lbsBackEnd rbt + Just rbt -> CL.sourceList body C.$$ sinkRequestBody lbsBackEnd rbt emptyGetParam :: (BS.ByteString, Maybe BS.ByteString) -> (BS.ByteString, BS.ByteString) emptyGetParam (k, Just v) = (k,v) diff --git a/Network/Wai/Parse.hs b/Network/Wai/Parse.hs --- a/Network/Wai/Parse.hs +++ b/Network/Wai/Parse.hs @@ -89,21 +89,24 @@ lbsBackEnd _ _ = fmap L.fromChunks CL.consume -- | Save uploaded files on disk as temporary files -tempFileBackEnd :: MonadResource m => ignored1 -> ignored2 -> Sink S.ByteString m FilePath +-- +-- Note: starting with version 2.0, it is the responsibility of the caller to +-- remove any temp files created by using this backend. +tempFileBackEnd :: InternalState -> ignored1 -> ignored2 -> Sink S.ByteString IO FilePath tempFileBackEnd = tempFileBackEndOpts getTemporaryDirectory "webenc.buf" -- | Same as 'tempFileSink', but use configurable temp folders and patterns. -tempFileBackEndOpts :: MonadResource m - => IO FilePath -- ^ get temporary directory +tempFileBackEndOpts :: IO FilePath -- ^ get temporary directory -> String -- ^ filename pattern + -> InternalState -> ignored1 -> ignored2 - -> Sink S.ByteString m FilePath -tempFileBackEndOpts getTmpDir pattern _ _ = do - (key, (fp, h)) <- lift $ allocate (do + -> Sink S.ByteString IO FilePath +tempFileBackEndOpts getTmpDir pattern internalState _ _ = do + (key, (fp, h)) <- flip runInternalState internalState $ allocate (do tempDir <- getTmpDir openBinaryTempFile tempDir pattern) (\(_, h) -> hClose h) - _ <- lift $ register $ removeFile fp + _ <- runInternalState (register $ removeFile fp) internalState CB.sinkHandle h lift $ release key return fp @@ -126,7 +129,7 @@ -- type, and returns a `Sink` for storing the contents. type BackEnd a = S.ByteString -- ^ parameter name -> FileInfo () - -> Sink S.ByteString (ResourceT IO) a + -> Sink S.ByteString IO a data RequestBodyType = UrlEncoded | Multipart S.ByteString @@ -169,27 +172,24 @@ parseRequestBody s r = case getRequestBodyType r of Nothing -> return ([], []) - Just rbt -> runResourceT $ withInternalState $ \internalState -> - fmap partitionEithers $ requestBody r $$ conduitRequestBody internalState s rbt =$ CL.consume + Just rbt -> fmap partitionEithers $ requestBody r $$ conduitRequestBody s rbt =$ CL.consume -sinkRequestBody :: InternalState - -> BackEnd y +sinkRequestBody :: BackEnd y -> RequestBodyType -> Sink S.ByteString IO ([Param], [File y]) -sinkRequestBody internalState s r = fmap partitionEithers $ conduitRequestBody internalState s r =$ CL.consume +sinkRequestBody s r = fmap partitionEithers $ conduitRequestBody s r =$ CL.consume -conduitRequestBody :: InternalState - -> BackEnd y +conduitRequestBody :: BackEnd y -> RequestBodyType -> Conduit S.ByteString IO (Either Param (File y)) -conduitRequestBody _ _ UrlEncoded = do +conduitRequestBody _ UrlEncoded = do -- NOTE: in general, url-encoded data will be in a single chunk. -- Therefore, I'm optimizing for the usual case by sticking with -- strict byte strings here. bs <- CL.consume mapM_ yield $ map Left $ H.parseSimpleQuery $ S.concat bs -conduitRequestBody internalState backend (Multipart bound) = - parsePieces internalState backend $ S8.pack "--" `S.append` bound +conduitRequestBody backend (Multipart bound) = + parsePieces backend $ S8.pack "--" `S.append` bound takeLine :: Monad m => Consumer S.ByteString m (Maybe S.ByteString) takeLine = @@ -217,11 +217,10 @@ ls <- takeLines return $ l : ls -parsePieces :: InternalState - -> BackEnd y +parsePieces :: BackEnd y -> S.ByteString -> ConduitM S.ByteString (Either Param (File y)) IO () -parsePieces internalState sink bound = +parsePieces sink bound = loop where loop = do @@ -239,7 +238,7 @@ Just (mct, name, Just filename) -> do let ct = fromMaybe "application/octet-stream" mct fi0 = FileInfo filename ct () - (wasFound, y) <- sinkTillBound' internalState bound name fi0 sink + (wasFound, y) <- sinkTillBound' bound name fi0 sink yield $ Right (name, fi0 { fileContent = y }) when wasFound loop Just (_ct, name, Nothing) -> do @@ -291,18 +290,17 @@ | S.index b x == S.index bs y = mismatch xs ys | otherwise = True -sinkTillBound' :: InternalState - -> S.ByteString +sinkTillBound' :: S.ByteString -> S.ByteString -> FileInfo () -> BackEnd y -> ConduitM S.ByteString o IO (Bool, y) -sinkTillBound' internalState bound name fi sink = +sinkTillBound' bound name fi sink = ConduitM $ anyOutput $ conduitTillBound bound >+> withUpstream (fix $ sink name fi) where - fix :: Sink S8.ByteString (ResourceT IO) y -> Pipe Void S8.ByteString Void Bool IO y - fix p = ignoreTerm >+> injectLeftovers (unConduitM $ transPipe (flip runInternalState internalState) p) + fix :: Sink S8.ByteString IO y -> Pipe Void S8.ByteString Void Bool IO y + fix p = ignoreTerm >+> injectLeftovers (unConduitM p) ignoreTerm = await' >>= maybe (return ()) (\x -> yield' x >> ignoreTerm) await' = NeedInput (return . Just) (const $ return Nothing) yield' = HaveOutput (return ()) (return ()) diff --git a/test/WaiExtraTest.hs b/test/WaiExtraTest.hs --- a/test/WaiExtraTest.hs +++ b/test/WaiExtraTest.hs @@ -31,11 +31,12 @@ import qualified Data.Conduit as C import qualified Data.Conduit.List as CL -import Data.Conduit.Binary (sourceFile) +import Data.Conduit.Binary (sourceHandle) import Control.Monad.IO.Class (liftIO) import Data.Maybe (fromMaybe) import Network.HTTP.Types (parseSimpleQuery, status200) import System.Log.FastLogger +import System.IO (withFile, IOMode (ReadMode)) import qualified Data.IORef as I @@ -117,14 +118,13 @@ expected = ["text/html;charset=utf-8", "text/x-c", "text/x-dvi", "text/*", "text/plain"] expected @=? parseHttpAccept input -parseRequestBody' :: BackEnd L.ByteString +parseRequestBody' :: BackEnd file -> SRequest - -> IO ([(S.ByteString, S.ByteString)], [(S.ByteString, FileInfo L.ByteString)]) + -> IO ([(S.ByteString, S.ByteString)], [(S.ByteString, FileInfo file)]) parseRequestBody' sink (SRequest req bod) = case getRequestBodyType req of Nothing -> return ([], []) - Just rbt -> runResourceT $ withInternalState $ \is -> - CL.sourceList (L.toChunks bod) C.$$ sinkRequestBody is sink rbt + Just rbt -> CL.sourceList (L.toChunks bod) C.$$ sinkRequestBody sink rbt caseParseRequestBody :: Assertion caseParseRequestBody = @@ -218,7 +218,8 @@ caseUrlEncPlus :: Assertion caseUrlEncPlus = do - result <- parseRequestBody' lbsBackEnd $ toRequest ctype content + result <- runResourceT $ withInternalState $ \state -> + parseRequestBody' (tempFileBackEnd state) $ toRequest ctype content liftIO $ result @?= ([("email", "has+plus")], []) where content = S8.pack $ "email=has%2Bplus" @@ -514,10 +515,8 @@ (params, files) <- case getRequestBodyType request' of Nothing -> return ([], []) - Just rbt -> C.runResourceT $ do - internalState <- getInternalState - sourceFile "test/requests/dalvik-request" - C.$$ C.transPipe liftIO (sinkRequestBody internalState lbsBackEnd rbt) + Just rbt -> withFile "test/requests/dalvik-request" ReadMode $ \h -> + sourceHandle h C.$$ sinkRequestBody lbsBackEnd rbt lookup "scannedTime" params @?= Just "1.298590056748E9" lookup "geoLong" params @?= Just "0" lookup "geoLat" params @?= Just "0" diff --git a/wai-extra.cabal b/wai-extra.cabal --- a/wai-extra.cabal +++ b/wai-extra.cabal @@ -1,5 +1,5 @@ Name: wai-extra -Version: 2.0.0.1 +Version: 2.0.1 Synopsis: Provides some basic WAI handlers and middleware. Description: The goal here is to provide common features without many dependencies. License: MIT