wai-extra 1.3.4.6 → 2.0.0
raw patch · 13 files changed
+137/−167 lines, 13 filesdep −date-cachedep ~bytestringdep ~conduitdep ~fast-logger
Dependencies removed: date-cache
Dependency ranges changed: bytestring, conduit, fast-logger, resourcet, wai, wai-logger
Files
- Network/Wai/Handler/CGI.hs +19/−19
- Network/Wai/Middleware/Autohead.hs +1/−0
- Network/Wai/Middleware/Gzip.hs +4/−6
- Network/Wai/Middleware/HttpAuth.hs +2/−3
- Network/Wai/Middleware/Jsonp.hs +20/−13
- Network/Wai/Middleware/MethodOverridePost.hs +1/−2
- Network/Wai/Middleware/RequestLogger.hs +32/−24
- Network/Wai/Middleware/RequestLogger/Internal.hs +2/−11
- Network/Wai/Middleware/Vhost.hs +1/−1
- Network/Wai/Parse.hs +27/−64
- test/WaiExtraTest.hs +21/−17
- tests.hs +1/−1
- wai-extra.cabal +6/−6
Network/Wai/Handler/CGI.hs view
@@ -11,9 +11,11 @@ ) where import Network.Wai+import Network.Wai.Internal import Network.Socket (getAddrInfo, addrAddress) import System.Environment (getEnvironment) import Data.Maybe (fromMaybe)+import Control.Exception (mask) import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy as L import Control.Arrow ((***))@@ -32,7 +34,6 @@ import qualified Data.CaseInsensitive as CI import Data.Monoid (mappend) import Data.Conduit-import qualified Data.Conduit.List as CL safeRead :: Read a => a -> String -> a safeRead d s =@@ -67,7 +68,7 @@ -- stick with 'run' or 'runSendfile'. runGeneric :: [(String, String)] -- ^ all variables- -> (Int -> Source (ResourceT IO) B.ByteString) -- ^ responseBody of input+ -> (Int -> Source IO B.ByteString) -- ^ responseBody of input -> (B.ByteString -> IO ()) -- ^ destination for output -> Maybe B.ByteString -- ^ does the server support the X-Sendfile header? -> Application@@ -76,8 +77,6 @@ let rmethod = B.pack $ lookup' "REQUEST_METHOD" vars pinfo = lookup' "PATH_INFO" vars qstring = lookup' "QUERY_STRING" vars- servername = lookup' "SERVER_NAME" vars- serverport = safeRead 80 $ lookup' "SERVER_PORT" vars contentLength = safeRead 0 $ lookup' "CONTENT_LENGTH" vars remoteHost' = case lookup "REMOTE_ADDR" vars of@@ -95,35 +94,36 @@ case addrs of a:_ -> addrAddress a [] -> error $ "Invalid REMOTE_ADDR or REMOTE_HOST: " ++ remoteHost'- runResourceT $ do- let env = Request+ mask $ \restore -> do+ let reqHeaders = map (cleanupVarName *** B.pack) vars+ env = Request { requestMethod = rmethod , rawPathInfo = B.pack pinfo , pathInfo = H.decodePathSegments $ B.pack pinfo , rawQueryString = B.pack qstring , queryString = H.parseQuery $ B.pack qstring- , serverName = B.pack servername- , serverPort = serverport- , requestHeaders = map (cleanupVarName *** B.pack) vars+ , requestHeaders = reqHeaders , isSecure = isSecure' , remoteHost = addr , httpVersion = H.http11 -- FIXME , requestBody = inputH contentLength , vault = mempty-#if MIN_VERSION_wai(1, 4, 0) , requestBodyLength = KnownLength $ fromIntegral contentLength-#endif+ , requestHeaderHost = lookup "host" reqHeaders+ , requestHeaderRange = lookup "range" reqHeaders } -- FIXME worry about exception?- res <- app env+ res <- restore $ app env case (xsendfile, res) of (Just sf, ResponseFile s hs fp Nothing) ->- liftIO $ mapM_ outputH $ L.toChunks $ toLazyByteString $ sfBuilder s hs sf fp+ restore $ mapM_ outputH $ L.toChunks $ toLazyByteString $ sfBuilder s hs sf fp _ -> do- let (s, hs, b) = responseSource res- src = CL.sourceList [Chunk $ headers s hs `mappend` fromChar '\n']- `mappend` b- src $$ builderSink+ let (s, hs, wb) = responseToSource res+ wb $ \b ->+ let src = do+ yield (Chunk $ headers s hs `mappend` fromChar '\n')+ b+ in src $$ builderSink where headers s hs = mconcat (map header $ status s : map header' (fixHeaders hs)) status (Status i m) = (fromByteString "Status", mconcat@@ -170,12 +170,12 @@ helper' (x:rest) = toLower x : helper' rest helper' [] = [] -requestBodyHandle :: Handle -> Int -> Source (ResourceT IO) B.ByteString+requestBodyHandle :: Handle -> Int -> Source IO B.ByteString requestBodyHandle h = requestBodyFunc $ \i -> do bs <- B.hGet h i return $ if B.null bs then Nothing else Just bs -requestBodyFunc :: (Int -> IO (Maybe B.ByteString)) -> Int -> Source (ResourceT IO) B.ByteString+requestBodyFunc :: (Int -> IO (Maybe B.ByteString)) -> Int -> Source IO B.ByteString requestBodyFunc get = loop where
Network/Wai/Middleware/Autohead.hs view
@@ -4,6 +4,7 @@ module Network.Wai.Middleware.Autohead (autohead) where import Network.Wai+import Network.Wai.Internal import Data.Monoid (mempty) autohead :: Middleware
Network/Wai/Middleware/Gzip.hs view
@@ -40,6 +40,7 @@ import Blaze.ByteString.Builder (fromByteString) import Control.Exception (try, SomeException) import qualified Data.Set as Set+import Network.Wai.Internal data GzipSettings = GzipSettings { gzipFiles :: GzipFiles@@ -91,10 +92,6 @@ `fmap` lookup "Accept-Encoding" (requestHeaders env) ua = fromMaybe "" $ lookup "user-agent" $ requestHeaders env isMSIE6 = "MSIE 6" `S.isInfixOf` ua- responseHeaders res = case res of- ResponseFile _ h _ _ -> h- ResponseBuilder _ h _ -> h- ResponseSource _ h _ -> h isEncoded res = isJust $ lookup "Content-Encoding" $ responseHeaders res compressFile :: Status -> [Header] -> FilePath -> FilePath -> IO Response@@ -130,12 +127,13 @@ case lookup "content-type" hs of Just m | gzipCheckMime set m -> let hs' = fixHeaders hs- in ResponseSource s hs' $ b C.$= builderToByteStringFlush+ in ResponseSource s hs' $ \f -> wb $ \b -> f $+ b C.$= builderToByteStringFlush C.$= CZ.compressFlush 1 (CZ.WindowBits 31) C.$= CL.map (fmap fromByteString) _ -> res where- (s, hs, b) = responseSource res+ (s, hs, wb) = responseToSource res -- Remove Content-Length header, since we will certainly have a -- different length after gzip compression.
Network/Wai/Middleware/HttpAuth.hs view
@@ -16,14 +16,13 @@ import Data.ByteString (ByteString) import qualified Data.ByteString as S import Data.String (IsString (..))-import Control.Monad.Trans.Resource (ResourceT) import Data.Word8 (isSpace, _colon, toLower) import Data.ByteString.Base64 (decodeLenient) -- | Check if a given username and password is valid. type CheckCreds = ByteString -> ByteString- -> ResourceT IO Bool+ -> IO Bool -- | Perform basic authentication. --@@ -73,7 +72,7 @@ -- authentication is not provided. -- -- Since 1.3.4- , authIsProtected :: !(Request -> ResourceT IO Bool)+ , authIsProtected :: !(Request -> IO Bool) -- ^ Determine if access to the requested resource is restricted. -- -- Default: always returns @True@.
Network/Wai/Middleware/Jsonp.hs view
@@ -16,16 +16,18 @@ module Network.Wai.Middleware.Jsonp (jsonp) where import Network.Wai+import Network.Wai.Internal import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as B8-import Blaze.ByteString.Builder (copyByteString)+import Blaze.ByteString.Builder (Builder, copyByteString) import Blaze.ByteString.Builder.Char8 (fromChar) import Data.Monoid (mappend) import Control.Monad (join) import Data.Maybe (fromMaybe) import qualified Data.ByteString as S import qualified Data.Conduit as C-import qualified Data.Conduit.List as CL+import Data.CaseInsensitive (CI)+import Network.HTTP.Types (Status) -- | Wrap json responses in a jsonp callback. --@@ -51,24 +53,24 @@ $ requestHeaders env } res <- app env'- case callback of- Nothing -> return res+ return $ case callback of+ Nothing -> res Just c -> go c res where go c r@(ResponseBuilder s hs b) = case checkJSON hs of- Nothing -> return r- Just hs' -> return $ ResponseBuilder s hs' $+ Nothing -> r+ Just hs' -> ResponseBuilder s hs' $ copyByteString c `mappend` fromChar '(' `mappend` b `mappend` fromChar ')' go c r = case checkJSON hs of- Just hs' -> addCallback c s hs' b- Nothing -> return r+ Just hs' -> addCallback c s hs' wb+ Nothing -> r where- (s, hs, b) = responseSource r+ (s, hs, wb) = responseToSource r checkJSON hs = case lookup "Content-Type" hs of@@ -78,11 +80,16 @@ _ -> Nothing fixHeaders = changeVal "Content-Type" "text/javascript" - addCallback cb s hs b =- return $ ResponseSource s hs $- CL.sourceList [C.Chunk $ copyByteString cb `mappend` fromChar '(']+ addCallback :: ByteString+ -> Status+ -> [(CI ByteString, ByteString)]+ -> (forall b. WithSource IO (C.Flush Builder) b)+ -> Response+ addCallback cb s hs wb =+ ResponseSource s hs $ \f -> wb $ \b -> f $+ C.yield (C.Chunk $ copyByteString cb `mappend` fromChar '(') `mappend` b- `mappend` CL.sourceList [C.Chunk $ fromChar ')']+ `mappend` C.yield (C.Chunk $ fromChar ')') changeVal :: Eq a => a
Network/Wai/Middleware/MethodOverridePost.hs view
@@ -12,7 +12,6 @@ import Network.HTTP.Types (parseQuery) import Data.Monoid (mconcat) import Data.Conduit.Lazy (lazyConsume)-import Control.Monad.Trans.Resource (ResourceT) import Data.Conduit.List (sourceList) -- | Allows overriding of the HTTP request method via the _method post string parameter.@@ -31,7 +30,7 @@ ("POST", Just "application/x-www-form-urlencoded") -> setPost req >>= app _ -> app req -setPost :: Request -> ResourceT IO Request+setPost :: Request -> IO Request setPost req = do body <- lazyConsume (requestBody req) case parseQuery (mconcat body) of
Network/Wai/Middleware/RequestLogger.hs view
@@ -24,13 +24,17 @@ import qualified Data.ByteString as BS import Data.ByteString.Char8 (pack, unpack) import Control.Monad.IO.Class (liftIO)-import Network.Wai (Request(..), Middleware, responseStatus, Response)+import Network.Wai (Request(..), Middleware, responseStatus, Response, responseHeaders) import System.Log.FastLogger import Network.HTTP.Types as H import Data.Maybe (fromMaybe)+import Control.Monad.Trans.Resource (withInternalState)+import Data.Monoid (mconcat)+import Blaze.ByteString.Builder (toByteString) import Network.Wai.Parse (sinkRequestBody, lbsBackEnd, fileName, Param, File, getRequestBodyType) import qualified Data.ByteString.Lazy as LBS+import qualified Data.ByteString.Char8 as S8 import qualified Data.Conduit as C import qualified Data.Conduit.List as CL@@ -40,20 +44,20 @@ import System.IO.Unsafe import Data.Default (Default (def))-import Network.Wai.Logger.Format (apacheFormat, IPAddrSource (..))+import Network.Wai.Logger import Network.Wai.Middleware.RequestLogger.Internal data OutputFormat = Apache IPAddrSource | Detailed Bool -- ^ use colors? | CustomOutputFormat OutputFormatter -type OutputFormatter = ZonedDate -> Request -> Status -> Maybe Integer -> [LogStr]+type OutputFormatter = ZonedDate -> Request -> Status -> Maybe Integer -> LogStr data Destination = Handle Handle- | Logger Logger+ | Logger LoggerSet | Callback Callback -type Callback = [LogStr] -> IO ()+type Callback = LogStr -> IO () data RequestLoggerSettings = RequestLoggerSettings {@@ -76,28 +80,31 @@ mkRequestLogger :: RequestLoggerSettings -> IO Middleware mkRequestLogger RequestLoggerSettings{..} = do- (callback, mgetdate) <-+ callback <- case destination of- Handle h -> fmap fromLogger $ mkLogger autoFlush h- Logger l -> return $ fromLogger l- Callback c -> return (c, Nothing)+ Handle h -> return $ BS.hPutStr h . toByteString . logStrBuilder+ Logger l -> return $ pushLogStr l+ Callback c -> return c case outputFormat of Apache ipsrc -> do- getdate <- dateHelper mgetdate- return $ apacheMiddleware callback ipsrc getdate+ getdate <- getDateGetter+ apache <- initLogger ipsrc (LogCallback callback (return ())) getdate+ return $ apacheMiddleware apache Detailed useColors -> detailedMiddleware callback useColors CustomOutputFormat formatter -> do- getdate <- dateHelper mgetdate+ getdate <- getDateGetter return $ customMiddleware callback getdate formatter- where- fromLogger l = (loggerPutStr l, Just $ loggerDate l)- dateHelper mgetdate = do- case mgetdate of- Just x -> return x- Nothing -> getDateGetter -apacheMiddleware :: Callback -> IPAddrSource -> IO ZonedDate -> Middleware-apacheMiddleware cb ipsrc getdate = customMiddleware cb getdate $ apacheFormat ipsrc+apacheMiddleware :: ApacheLoggerActions -> Middleware+apacheMiddleware ala app req = do+ res <- app req+ let msize = lookup "content-length" (responseHeaders res) >>= readInt'+ readInt' bs =+ case S8.readInteger bs of+ Just (i, "") -> Just i+ _ -> Nothing+ apacheLogger ala req (responseStatus res) msize+ return res customMiddleware :: Callback -> IO ZonedDate -> OutputFormatter -> Middleware customMiddleware cb getdate formatter app req = do@@ -179,7 +186,7 @@ ] detailedMiddleware' :: Callback- -> (C.ResourceT IO (BS.ByteString -> [BS.ByteString]))+ -> IO (BS.ByteString -> [BS.ByteString]) -> Middleware detailedMiddleware' cb getAddColor app req = do let mlen = lookup "content-length" (requestHeaders req) >>= readInt@@ -221,7 +228,7 @@ addColor <- getAddColor -- log the request immediately.- liftIO $ cb $ map LB $ addColor (requestMethod req) +++ liftIO $ cb $ mconcat $ map toLogStr $ addColor (requestMethod req) ++ [ " " , rawPathInfo req , "\n"@@ -237,7 +244,7 @@ -- log the status of the response -- this is color coordinated with the request logging -- also includes the request path to connect it to the request- liftIO $ cb $ map LB $ addColor "Status: " ++ [+ liftIO $ cb $ mconcat $ map toLogStr $ addColor "Status: " ++ [ statusBS rsp , " " , msgBS rsp@@ -254,7 +261,8 @@ allPostParams body = case getRequestBodyType req of Nothing -> return ([], [])- Just rbt -> C.runResourceT $ CL.sourceList body C.$$ sinkRequestBody lbsBackEnd rbt+ Just rbt -> C.runResourceT $ withInternalState $ \internalState ->+ CL.sourceList body C.$$ sinkRequestBody internalState lbsBackEnd rbt emptyGetParam :: (BS.ByteString, Maybe BS.ByteString) -> (BS.ByteString, BS.ByteString) emptyGetParam (k, Just v) = (k,v)
Network/Wai/Middleware/RequestLogger/Internal.hs view
@@ -5,16 +5,7 @@ module Network.Wai.Middleware.RequestLogger.Internal where import Data.ByteString (ByteString)-import System.Log.FastLogger-#if MIN_VERSION_fast_logger(0,3,0)-import System.Date.Cache (ondemandDateCacher)-#else-import System.Log.FastLogger.Date (getDate, dateInit, ZonedDate)-#endif+import Network.Wai.Logger (clockDateCacher) getDateGetter :: IO (IO ByteString)-#if MIN_VERSION_fast_logger(0, 3, 0)-getDateGetter = fmap fst $ ondemandDateCacher zonedDateCacheConf-#else-getDateGetter = fmap getDate dateInit-#endif+getDateGetter = fmap fst clockDateCacher
Network/Wai/Middleware/Vhost.hs view
@@ -16,7 +16,7 @@ redirectWWW :: Text -> Application -> Application -- W.MiddleWare redirectWWW home app req =- if BS.isPrefixOf "www" $ serverName req+ if maybe True (BS.isPrefixOf "www") $ lookup "host" $ requestHeaders req then return $ responseLBS H.status301 [ ("Content-Type", "text/plain") , ("Location", TE.encodeUtf8 home) ] "Redirect" else app req
Network/Wai/Parse.hs view
@@ -51,13 +51,9 @@ import Data.Either (partitionEithers) import Control.Monad (when, unless) import Control.Monad.Trans.Class (lift)-import Control.Monad.Trans.Resource (allocate, release, register)-#if MIN_VERSION_conduit(1, 0, 0)+import Control.Monad.Trans.Resource (allocate, release, register, InternalState, withInternalState, runInternalState) import Data.Conduit.Internal (Pipe (NeedInput, HaveOutput), (>+>), withUpstream, injectLeftovers, ConduitM (..)) import Data.Void (Void)-#else-import Data.Conduit.Internal (sinkToPipe)-#endif breakDiscard :: Word8 -> S.ByteString -> (S.ByteString, S.ByteString) breakDiscard w s =@@ -169,34 +165,33 @@ parseRequestBody :: BackEnd y -> Request- -> ResourceT IO ([Param], [File y])+ -> IO ([Param], [File y]) parseRequestBody s r = case getRequestBodyType r of Nothing -> return ([], [])- Just rbt -> fmap partitionEithers $ requestBody r $$ conduitRequestBody s rbt =$ CL.consume+ Just rbt -> runResourceT $ withInternalState $ \internalState ->+ fmap partitionEithers $ requestBody r $$ conduitRequestBody internalState s rbt =$ CL.consume -sinkRequestBody :: BackEnd y+sinkRequestBody :: InternalState+ -> BackEnd y -> RequestBodyType- -> Sink S.ByteString (ResourceT IO) ([Param], [File y])-sinkRequestBody s r = fmap partitionEithers $ conduitRequestBody s r =$ CL.consume+ -> Sink S.ByteString IO ([Param], [File y])+sinkRequestBody internalState s r = fmap partitionEithers $ conduitRequestBody internalState s r =$ CL.consume -conduitRequestBody :: BackEnd y+conduitRequestBody :: InternalState+ -> BackEnd y -> RequestBodyType- -> Conduit S.ByteString (ResourceT IO) (Either Param (File y))-conduitRequestBody _ UrlEncoded = do+ -> Conduit S.ByteString IO (Either Param (File y))+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 backend (Multipart bound) =- parsePieces backend $ S8.pack "--" `S.append` bound+conduitRequestBody internalState backend (Multipart bound) =+ parsePieces internalState backend $ S8.pack "--" `S.append` bound -#if MIN_VERSION_conduit(1, 0, 0) takeLine :: Monad m => Consumer S.ByteString m (Maybe S.ByteString)-#else-takeLine :: Monad m => Pipe S.ByteString S.ByteString o u m (Maybe S.ByteString)-#endif takeLine = go id where@@ -211,11 +206,7 @@ when (S.length y > 1) $ leftover $ S.drop 1 y return $ Just $ killCR x -#if MIN_VERSION_conduit(1, 0, 0)-takeLines :: Consumer S.ByteString (ResourceT IO) [S.ByteString]-#else-takeLines :: Pipe S.ByteString S.ByteString o u (ResourceT IO) [S.ByteString]-#endif+takeLines :: Consumer S.ByteString IO [S.ByteString] takeLines = do res <- takeLine case res of@@ -226,14 +217,11 @@ ls <- takeLines return $ l : ls -parsePieces :: BackEnd y+parsePieces :: InternalState+ -> BackEnd y -> S.ByteString-#if MIN_VERSION_conduit(1, 0, 0)- -> ConduitM S.ByteString (Either Param (File y)) (ResourceT IO) ()-#else- -> Pipe S.ByteString S.ByteString (Either Param (File y)) u (ResourceT IO) ()-#endif-parsePieces sink bound =+ -> ConduitM S.ByteString (Either Param (File y)) IO ()+parsePieces internalState sink bound = loop where loop = do@@ -251,7 +239,7 @@ Just (mct, name, Just filename) -> do let ct = fromMaybe "application/octet-stream" mct fi0 = FileInfo filename ct ()- (wasFound, y) <- sinkTillBound' bound name fi0 sink+ (wasFound, y) <- sinkTillBound' internalState bound name fi0 sink yield $ Right (name, fi0 { fileContent = y }) when wasFound loop Just (_ct, name, Nothing) -> do@@ -303,45 +291,30 @@ | S.index b x == S.index bs y = mismatch xs ys | otherwise = True -sinkTillBound' :: S.ByteString+sinkTillBound' :: InternalState -> S.ByteString+ -> S.ByteString -> FileInfo () -> BackEnd y-#if MIN_VERSION_conduit(1, 0, 0)- -> ConduitM S.ByteString o (ResourceT IO) (Bool, y)-#else- -> Pipe S.ByteString S.ByteString o u (ResourceT IO) (Bool, y)-#endif-sinkTillBound' bound name fi sink =-#if MIN_VERSION_conduit(1, 0, 0)+ -> ConduitM S.ByteString o IO (Bool, y)+sinkTillBound' internalState bound name fi sink = ConduitM $ anyOutput $-#endif conduitTillBound bound >+> withUpstream (fix $ sink name fi) where-#if MIN_VERSION_conduit(1, 0, 0)- fix :: Sink S8.ByteString (ResourceT IO) y -> Pipe Void S8.ByteString Void Bool (ResourceT IO) y- fix (ConduitM p) = ignoreTerm >+> injectLeftovers p+ 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) ignoreTerm = await' >>= maybe (return ()) (\x -> yield' x >> ignoreTerm) await' = NeedInput (return . Just) (const $ return Nothing) yield' = HaveOutput (return ()) (return ()) anyOutput p = p >+> dropInput dropInput = NeedInput (const dropInput) return-#else- fix = sinkToPipe-#endif conduitTillBound :: Monad m => S.ByteString -- bound-#if MIN_VERSION_conduit(1, 0, 0) -> Pipe S.ByteString S.ByteString S.ByteString () m Bool-#else- -> Pipe S.ByteString S.ByteString S.ByteString u m Bool-#endif conduitTillBound bound =-#if MIN_VERSION_conduit(1, 0, 0) unConduitM $-#endif go id where go front = await >>= maybe (close front) (push front)@@ -371,26 +344,16 @@ sinkTillBound :: S.ByteString -> (x -> S.ByteString -> IO x) -> x-#if MIN_VERSION_conduit(1, 0, 0)- -> Consumer S.ByteString (ResourceT IO) (Bool, x)-#else- -> Pipe S.ByteString S.ByteString o u (ResourceT IO) (Bool, x)-#endif+ -> Consumer S.ByteString IO (Bool, x) sinkTillBound bound iter seed0 =-#if MIN_VERSION_conduit(1, 0, 0) ConduitM $-#endif (conduitTillBound bound >+> (withUpstream $ ij $ CL.foldM iter' seed0)) where iter' a b = liftIO $ iter a b-#if MIN_VERSION_conduit(1, 0, 0) ij (ConduitM p) = ignoreTerm >+> injectLeftovers p ignoreTerm = await' >>= maybe (return ()) (\x -> yield' x >> ignoreTerm) await' = NeedInput (return . Just) (const $ return Nothing) yield' = HaveOutput (return ()) (return ())-#else- ij = id-#endif parseAttrs :: S.ByteString -> [(S.ByteString, S.ByteString)] parseAttrs = map go . S.split 59 -- semicolon
test/WaiExtraTest.hs view
@@ -3,6 +3,8 @@ import Test.Hspec import Test.HUnit hiding (Test)+import Data.Monoid (mappend, mempty)+import Blaze.ByteString.Builder (toByteString) import Network.Wai import Network.Wai.Test@@ -15,6 +17,7 @@ import qualified Data.Text as TS import qualified Data.Text.Encoding as TE import Control.Arrow+import Control.Monad.Trans.Resource (getInternalState, withInternalState, runResourceT) import Network.Wai.Middleware.Jsonp import Network.Wai.Middleware.Gzip@@ -116,15 +119,16 @@ parseRequestBody' :: BackEnd L.ByteString -> SRequest- -> C.ResourceT IO ([(S.ByteString, S.ByteString)], [(S.ByteString, FileInfo L.ByteString)])+ -> IO ([(S.ByteString, S.ByteString)], [(S.ByteString, FileInfo L.ByteString)]) parseRequestBody' sink (SRequest req bod) = case getRequestBodyType req of Nothing -> return ([], [])- Just rbt -> CL.sourceList (L.toChunks bod) C.$$ sinkRequestBody sink rbt+ Just rbt -> runResourceT $ withInternalState $ \is ->+ CL.sourceList (L.toChunks bod) C.$$ sinkRequestBody is sink rbt caseParseRequestBody :: Assertion caseParseRequestBody =- C.runResourceT t+ t where content2 = S8.pack $ "--AaB03x\n" ++@@ -188,7 +192,7 @@ caseMultipartPlus :: Assertion caseMultipartPlus = do- result <- C.runResourceT $ parseRequestBody' lbsBackEnd $ toRequest ctype content+ result <- parseRequestBody' lbsBackEnd $ toRequest ctype content liftIO $ result @?= ([("email", "has+plus")], []) where content = S8.pack $@@ -201,7 +205,7 @@ caseMultipartAttrs :: Assertion caseMultipartAttrs = do- result <- C.runResourceT $ parseRequestBody' lbsBackEnd $ toRequest ctype content+ result <- parseRequestBody' lbsBackEnd $ toRequest ctype content liftIO $ result @?= ([("email", "has+plus")], []) where content = S8.pack $@@ -214,7 +218,7 @@ caseUrlEncPlus :: Assertion caseUrlEncPlus = do- result <- C.runResourceT $ parseRequestBody' lbsBackEnd $ toRequest ctype content+ result <- parseRequestBody' lbsBackEnd $ toRequest ctype content liftIO $ result @?= ([("email", "has+plus")], []) where content = S8.pack $ "email=has%2Bplus"@@ -374,19 +378,19 @@ vhostApp1 = const $ return $ responseLBS status200 [] "app1" vhostApp2 = const $ return $ responseLBS status200 [] "app2" vhostApp = vhost- [ ((== "foo.com") . serverName, vhostApp1)+ [ ((== Just "foo.com") . lookup "host" . requestHeaders, vhostApp1) ] vhostApp2 caseVhost :: Assertion caseVhost = flip runSession vhostApp $ do sres1 <- request defaultRequest- { serverName = "foo.com"+ { requestHeaders = [("Host", "foo.com")] } assertBody "app1" sres1 sres2 <- request defaultRequest- { serverName = "bar.com"+ { requestHeaders = [("Host", "bar.com")] } assertBody "app2" sres2 @@ -510,8 +514,10 @@ (params, files) <- case getRequestBodyType request' of Nothing -> return ([], [])- Just rbt -> C.runResourceT $ sourceFile "test/requests/dalvik-request"- C.$$ sinkRequestBody lbsBackEnd rbt+ Just rbt -> C.runResourceT $ do+ internalState <- getInternalState+ sourceFile "test/requests/dalvik-request"+ C.$$ C.transPipe liftIO (sinkRequestBody internalState lbsBackEnd rbt) lookup "scannedTime" params @?= Just "1.298590056748E9" lookup "geoLong" params @?= Just "0" lookup "geoLat" params @?= Just "0"@@ -540,21 +546,19 @@ getOutput params' = T.pack $ "GET /location\nAccept: \nGET " ++ show params' ++ "\nStatus: 200 OK. /location\n" debugApp output' req = do- iactual <- liftIO $ I.newIORef []+ iactual <- liftIO $ I.newIORef mempty middleware <- liftIO $ mkRequestLogger def- { destination = Callback $ \strs -> I.modifyIORef iactual $ (++ strs)+ { destination = Callback $ \strs -> I.modifyIORef iactual $ (`mappend` strs) , outputFormat = Detailed False } res <- middleware (\_req -> return $ responseLBS status200 [ ] "") req actual <- liftIO $ I.readIORef iactual- liftIO $ assertEqual "debug" output $ logsToBs actual+ liftIO $ assertEqual "debug" output $ logToBs actual return res where output = TE.encodeUtf8 $ T.toStrict output'- logsToBs = S.concat . map logToBs - logToBs (LB bs) = bs- logToBs (LS s) = S8.pack s+ logToBs = toByteString . logStrBuilder {-debugApp = debug $ \req -> do-} {-return $ responseLBS status200 [ ] ""-}
tests.hs view
@@ -1,4 +1,4 @@-import Test.Hspec.Monadic+import Test.Hspec import qualified WaiExtraTest main :: IO ()
wai-extra.cabal view
@@ -1,5 +1,5 @@ Name: wai-extra-Version: 1.3.4.6+Version: 2.0.0 Synopsis: Provides some basic WAI handlers and middleware. Description: The goal here is to provide common features without many dependencies. License: MIT@@ -22,7 +22,7 @@ Library Build-Depends: base >= 4 && < 5 , bytestring >= 0.9.1.4- , wai >= 1.3 && < 1.5+ , wai >= 2.0 && < 2.1 , old-locale >= 1.0.0.2 && < 1.1 , time >= 1.1.4 , network >= 2.2.1.5@@ -33,10 +33,9 @@ , text >= 0.7 && < 0.12 , case-insensitive >= 0.2 , data-default- , date-cache >= 0.3 && < 0.4- , fast-logger >= 0.2 && < 0.4- , wai-logger >= 0.2 && < 0.4- , conduit >= 0.5 && < 1.1+ , fast-logger >= 2.0 && < 2.1+ , wai-logger >= 2.0 && < 2.1+ , conduit >= 1.0 && < 1.1 , zlib-conduit >= 0.5 && < 1.1 , blaze-builder-conduit >= 0.5 && < 1.1 , ansi-terminal@@ -88,6 +87,7 @@ , data-default , conduit , fast-logger+ , resourcet ghc-options: -Wall source-repository head