wai-extra 2.0.0.1 → 2.0.1
raw patch · 4 files changed
+36/−40 lines, 4 files
Files
- Network/Wai/Middleware/RequestLogger.hs +1/−2
- Network/Wai/Parse.hs +25/−27
- test/WaiExtraTest.hs +9/−10
- wai-extra.cabal +1/−1
Network/Wai/Middleware/RequestLogger.hs view
@@ -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)
Network/Wai/Parse.hs view
@@ -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 ())
test/WaiExtraTest.hs view
@@ -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"
wai-extra.cabal view
@@ -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