wai-extra 2.1.1.3 → 3.0.0

raw patch · 19 files changed

+788/−326 lines, 19 filesdep +data-default-classdep +deepseqdep +streaming-commonsdep −blaze-builder-conduitdep −conduitdep −conduit-extradep ~http-typesdep ~waiPVP ok

version bump matches the API change (PVP)

Dependencies added: data-default-class, deepseq, streaming-commons

Dependencies removed: blaze-builder-conduit, conduit, conduit-extra, wai-test, zlib-bindings, zlib-conduit

Dependency ranges changed: http-types, wai

API changes (from Hackage documentation)

Files

• Network/Wai/EventSource.hs +38/−0
• Network/Wai/EventSource/EventStream.hs +75/−0
• Network/Wai/Handler/CGI.hs +54/−53
• Network/Wai/Middleware/Autohead.hs +5/−10
• Network/Wai/Middleware/CleanPath.hs +3/−3
• Network/Wai/Middleware/Gzip.hs +72/−30
• Network/Wai/Middleware/HttpAuth.hs +4/−4
• Network/Wai/Middleware/Jsonp.hs +13/−19
• Network/Wai/Middleware/MethodOverridePost.hs +13/−10
• Network/Wai/Middleware/RequestLogger.hs +39/−40
• Network/Wai/Middleware/Rewrite.hs +2/−2
• Network/Wai/Middleware/Vhost.hs +3/−3
• Network/Wai/Parse.hs +162/−105
• Network/Wai/Test.hs +214/−0
• Network/Wai/UrlMap.hs +6/−5
• test/Network/Wai/TestSpec.hs +36/−0
• test/Spec.hs +1/−0
• test/WaiExtraTest.hs +29/−31
• wai-extra.cabal +19/−11

@@ -0,0 +1,38 @@+{-# LANGUAGE OverloadedStrings #-}+{-|+    A WAI adapter to the HTML5 Server-Sent Events API.+-}+module Network.Wai.EventSource (+    ServerEvent(..),+    eventSourceAppChan,+    eventSourceAppIO+    ) where++import           Blaze.ByteString.Builder (Builder)+import           Data.Function (fix)+import           Control.Concurrent.Chan (Chan, dupChan, readChan)+import           Control.Monad.IO.Class (liftIO)+import           Network.HTTP.Types (status200)+import           Network.Wai (Application, Response, responseStream)++import Network.Wai.EventSource.EventStream++-- | Make a new WAI EventSource application reading events from+-- the given channel.+eventSourceAppChan :: Chan ServerEvent -> Application+eventSourceAppChan chan req sendResponse = do+    chan' <- liftIO $ dupChan chan+    eventSourceAppIO (readChan chan') req sendResponse++-- | Make a new WAI EventSource application reading events from+-- the given IO action.+eventSourceAppIO :: IO ServerEvent -> Application+eventSourceAppIO src _ sendResponse =+    sendResponse $ responseStream+        status200+        [("Content-Type", "text/event-stream")]+        $ \sendChunk flush -> fix $ \loop -> do+            se <- src+            case eventToBuilder se of+                Nothing -> return ()+                Just b  -> sendChunk b >> flush >> loop

@@ -0,0 +1,75 @@+{-# LANGUAGE OverloadedStrings #-}+{- code adapted by Mathias Billman originaly from Chris Smith https://github.com/cdsmith/gloss-web -}++{-|+    Internal module, usually you don't need to use it.+-}+module Network.Wai.EventSource.EventStream (+    ServerEvent(..),+    eventToBuilder+    ) where++import Blaze.ByteString.Builder+import Blaze.ByteString.Builder.Char8+import Data.Monoid++{-|+    Type representing a communication over an event stream.  This can be an+    actual event, a comment, a modification to the retry timer, or a special+    "close" event indicating the server should close the connection.+-}+data ServerEvent+    = ServerEvent {+        eventName :: Maybe Builder,+        eventId   :: Maybe Builder,+        eventData :: [Builder]+        }+    | CommentEvent {+        eventComment :: Builder+        }+    | RetryEvent {+        eventRetry :: Int+        }+    | CloseEvent+++{-|+    Newline as a Builder.+-}+nl :: Builder+nl = fromChar '\n'+++{-|+    Field names as Builder+-}+nameField, idField, dataField, retryField, commentField :: Builder+nameField = fromString "event:"+idField = fromString "id:"+dataField = fromString "data:"+retryField = fromString "retry:"+commentField = fromChar ':'+++{-|+    Wraps the text as a labeled field of an event stream.+-}+field :: Builder -> Builder -> Builder+field l b = l `mappend` b `mappend` nl+++{-|+    Converts a 'ServerEvent' to its wire representation as specified by the+    @text/event-stream@ content type.+-}+eventToBuilder :: ServerEvent -> Maybe Builder+eventToBuilder (CommentEvent txt) = Just $ field commentField txt+eventToBuilder (RetryEvent   n)   = Just $ field retryField (fromShow n)+eventToBuilder (CloseEvent)       = Nothing+eventToBuilder (ServerEvent n i d)= Just $+    (name n $ evid i $ mconcat (map (field dataField) d)) `mappend` nl+  where+    name Nothing  = id+    name (Just n') = mappend (field nameField n')+    evid Nothing  = id+    evid (Just i') = mappend (field idField   i')

@@ -13,8 +13,8 @@ import Network.Wai import Network.Wai.Internal import Network.Socket (getAddrInfo, addrAddress)+import Data.IORef 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 ((***))@@ -22,17 +22,17 @@ import qualified System.IO import qualified Data.String as String import Data.Monoid (mconcat, mempty)-import Blaze.ByteString.Builder (fromByteString, toLazyByteString)+import Blaze.ByteString.Builder (fromByteString, toLazyByteString, flush) import Blaze.ByteString.Builder.Char8 (fromChar, fromString)-import Data.Conduit.Blaze (builderToByteStringFlush)-import Control.Monad.IO.Class (liftIO) import Data.ByteString.Lazy.Internal (defaultChunkSize) import System.IO (Handle) import Network.HTTP.Types (Status (..)) import qualified Network.HTTP.Types as H import qualified Data.CaseInsensitive as CI import Data.Monoid (mappend)-import Data.Conduit+import qualified Data.Streaming.Blaze as Blaze+import Data.Function (fix)+import Control.Monad (unless, void)  #if WINDOWS import System.Environment (getEnvironment)@@ -76,7 +76,7 @@ -- stick with 'run' or 'runSendfile'. runGeneric      :: [(String, String)] -- ^ all variables-     -> (Int -> Source IO B.ByteString) -- ^ responseBody of input+     -> (Int -> IO (IO B.ByteString)) -- ^ responseBody of input      -> (B.ByteString -> IO ()) -- ^ destination for output      -> Maybe B.ByteString -- ^ does the server support the X-Sendfile header?      -> Application@@ -98,40 +98,48 @@                 "https" -> True                 _ -> False     addrs <- getAddrInfo Nothing (Just remoteHost') Nothing+    requestBody' <- inputH contentLength     let addr =             case addrs of                 a:_ -> addrAddress a                 [] -> error $ "Invalid REMOTE_ADDR or REMOTE_HOST: " ++ remoteHost'-    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-                , requestHeaders = reqHeaders-                , isSecure = isSecure'-                , remoteHost = addr-                , httpVersion = H.http11 -- FIXME-                , requestBody = inputH contentLength-                , vault = mempty-                , requestBodyLength = KnownLength $ fromIntegral contentLength-                , requestHeaderHost = lookup "host" reqHeaders-                , requestHeaderRange = lookup "range" reqHeaders-                }-        -- FIXME worry about exception?-        res <- restore $ app env+        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+            , requestHeaders = reqHeaders+            , isSecure = isSecure'+            , remoteHost = addr+            , httpVersion = H.http11 -- FIXME+            , requestBody = requestBody'+            , vault = mempty+            , requestBodyLength = KnownLength $ fromIntegral contentLength+            , requestHeaderHost = lookup "host" reqHeaders+            , requestHeaderRange = lookup "range" reqHeaders+            }+    void $ app env $ \res ->         case (xsendfile, res) of-            (Just sf, ResponseFile s hs fp Nothing) ->-                restore $ mapM_ outputH $ L.toChunks $ toLazyByteString $ sfBuilder s hs sf fp+            (Just sf, ResponseFile s hs fp Nothing) -> do+                mapM_ outputH $ L.toChunks $ toLazyByteString $ sfBuilder s hs sf fp+                return ResponseReceived             _ -> do-                let (s, hs, wb) = responseToSource res-                wb $ \b ->-                    let src = do-                            yield (Chunk $ headers s hs `mappend` fromChar '\n')-                            b-                     in src $$ builderSink+                let (s, hs, wb) = responseToStream res+                (blazeRecv, blazeFinish) <- Blaze.newBlazeRecv Blaze.defaultStrategy+                wb $ \b -> do+                    let sendBuilder builder = do+                            popper <- blazeRecv builder+                            fix $ \loop -> do+                                bs <- popper+                                unless (B.null bs) $ do+                                    outputH bs+                                    loop+                    sendBuilder $ headers s hs `mappend` fromChar '\n'+                    b sendBuilder (sendBuilder flush)+                blazeFinish >>= maybe (return ()) outputH+                return ResponseReceived   where     headers s hs = mconcat (map header $ status s : map header' (fixHeaders hs))     status (Status i m) = (fromByteString "Status", mconcat@@ -153,13 +161,6 @@         , fromByteString sf         , fromByteString " not supported"         ]-    bsSink = await >>= maybe (return ()) push-    push (Chunk bs) = do-        liftIO $ outputH bs-        bsSink-    -- FIXME actually flush?-    push Flush = bsSink-    builderSink = builderToByteStringFlush =$ bsSink     fixHeaders h =         case lookup "content-type" h of             Nothing -> ("Content-Type", "text/html; charset=utf-8") : h@@ -178,19 +179,19 @@     helper' (x:rest) = toLower x : helper' rest     helper' [] = [] -requestBodyHandle :: Handle -> Int -> Source IO B.ByteString+requestBodyHandle :: Handle -> Int -> IO (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 IO B.ByteString-requestBodyFunc get =-    loop-  where-    loop 0 = return ()-    loop count = do-        mbs <- liftIO $ get $ min count defaultChunkSize-        let count' = count - maybe 0 B.length mbs-        case mbs of-            Nothing -> return ()-            Just bs -> yield bs >> loop count'+requestBodyFunc :: (Int -> IO (Maybe B.ByteString)) -> Int -> IO (IO B.ByteString)+requestBodyFunc get count0 = do+    ref <- newIORef count0+    return $ do+        count <- readIORef ref+        if count <= 0+            then return B.empty+            else do+                mbs <- get $ min count defaultChunkSize+                writeIORef ref $ count - maybe 0 B.length mbs+                return $ fromMaybe B.empty mbs

@@ -4,17 +4,12 @@ module Network.Wai.Middleware.Autohead (autohead) where  import Network.Wai-import Network.Wai.Internal import Data.Monoid (mempty)  autohead :: Middleware-autohead app req-    | requestMethod req == "HEAD" = do-        res <- app req { requestMethod = "GET" }-        let go (ResponseFile s hs _ _) = ResponseBuilder s hs mempty-            go (ResponseBuilder s hs _) = ResponseBuilder s hs mempty-            go (ResponseSource s hs _) = ResponseBuilder s hs mempty-            go (ResponseRaw raw r) = ResponseRaw raw (go r)-        return (go res)-    | otherwise = app req+autohead app req sendResponse+    | requestMethod req == "HEAD" = app req { requestMethod = "GET" } $ \res -> do+        let (s, hs, _) = responseToStream res+        sendResponse $ responseBuilder s hs mempty+    | otherwise = app req sendResponse 

@@ -14,10 +14,10 @@           -> B.ByteString           -> ([Text] -> Application)           -> Application-cleanPath splitter prefix app env =+cleanPath splitter prefix app env sendResponse =     case splitter $ pathInfo env of-        Right pieces -> app pieces env-        Left p -> return+        Right pieces -> app pieces env sendResponse+        Left p -> sendResponse                 $ responseLBS status301                   [("Location", mconcat [prefix, p, suffix])]                 $ L.empty

@@ -28,20 +28,23 @@ import Data.Maybe (fromMaybe, isJust) import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString as S-import Data.Default+import Data.Default.Class import Network.HTTP.Types (Status, Header) import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.Resource (runResourceT) import System.Directory (doesFileExist, createDirectoryIfMissing)-import qualified Data.Conduit as C-import qualified Data.Conduit.Zlib as CZ-import qualified Data.Conduit.Binary as CB-import qualified Data.Conduit.List as CL-import Data.Conduit.Blaze (builderToByteStringFlush) import Blaze.ByteString.Builder (fromByteString) import Control.Exception (try, SomeException) import qualified Data.Set as Set import Network.Wai.Internal+import qualified Data.Streaming.Blaze as B+import qualified Data.Streaming.Zlib as Z+import qualified Blaze.ByteString.Builder as Blaze+import Control.Monad (unless)+import Data.Function (fix)+import Control.Exception (throwIO)+import qualified System.IO as IO+import Data.ByteString.Lazy.Internal (defaultChunkSize)  data GzipSettings = GzipSettings     { gzipFiles :: GzipFiles@@ -74,20 +77,19 @@ -- -- * Only compress if the response is above a certain size. gzip :: GzipSettings -> Middleware-gzip set app env = do-    res <- app env+gzip set app env sendResponse = app env $ \res ->     case res of-        ResponseFile{} | gzipFiles set == GzipIgnore -> return res+        ResponseFile{} | gzipFiles set == GzipIgnore -> sendResponse res         _ -> if "gzip" `elem` enc && not isMSIE6 && not (isEncoded res)                 then                     case (res, gzipFiles set) of                         (ResponseFile s hs file Nothing, GzipCacheFolder cache) ->                             case lookup "content-type" hs of                                 Just m-                                    | gzipCheckMime set m -> liftIO $ compressFile s hs file cache-                                _ -> return res-                        _ -> return $ compressE set res-                else return res+                                    | gzipCheckMime set m -> compressFile s hs file cache sendResponse+                                _ -> sendResponse res+                        _ -> compressE set res sendResponse+                else sendResponse res   where     enc = fromMaybe [] $ (splitCommas . S8.unpack)                     `fmap` lookup "Accept-Encoding" (requestHeaders env)@@ -95,22 +97,38 @@     isMSIE6 = "MSIE 6" `S.isInfixOf` ua     isEncoded res = isJust $ lookup "Content-Encoding" $ responseHeaders res -compressFile :: Status -> [Header] -> FilePath -> FilePath -> IO Response-compressFile s hs file cache = do+compressFile :: Status -> [Header] -> FilePath -> FilePath -> (Response -> IO a) -> IO a+compressFile s hs file cache sendResponse = do     e <- doesFileExist tmpfile     if e         then onSucc         else do             createDirectoryIfMissing True cache-            x <--               try $ runResourceT $ CB.sourceFile file-                C.$$ CZ.gzip C.=$ CB.sinkFile tmpfile-            either onErr (const onSucc) x+            x <- try $+                 IO.withBinaryFile file IO.ReadMode $ \inH ->+                 IO.withBinaryFile tmpfile IO.WriteMode $ \outH -> do+                    deflate <- Z.initDeflate 7 $ Z.WindowBits 31+                    -- FIXME this code should write to a temporary file, then+                    -- rename to the final file+                    let goPopper popper = fix $ \loop -> do+                            res <- popper+                            case res of+                                Z.PRDone -> return ()+                                Z.PRNext bs -> do+                                    S.hPut outH bs+                                    loop+                                Z.PRError e -> throwIO e+                    fix $ \loop -> do+                        bs <- S.hGetSome inH defaultChunkSize+                        unless (S.null bs) $ do+                            Z.feedDeflate deflate bs >>= goPopper+                            loop+                    goPopper $ Z.finishDeflate deflate+            either onErr (const onSucc) (x :: Either SomeException ()) -- FIXME bad! don't catch all exceptions like that!   where-    onSucc = return $ ResponseFile s (fixHeaders hs) tmpfile Nothing+    onSucc = sendResponse $ responseFile s (fixHeaders hs) tmpfile Nothing -    onErr :: SomeException -> IO Response-    onErr = const $ return $ ResponseFile s hs file Nothing -- FIXME log the error message+    onErr _ = sendResponse $ responseFile s hs file Nothing -- FIXME log the error message      tmpfile = cache ++ '/' : map safe file     safe c@@ -123,18 +141,42 @@  compressE :: GzipSettings           -> Response-          -> Response-compressE set res =+          -> (Response -> IO a)+          -> IO a+compressE set res sendResponse =     case lookup "content-type" hs of         Just m | gzipCheckMime set m ->             let hs' = fixHeaders hs-             in ResponseSource s hs' $ \f -> wb $ \b -> f $-                                       b C.$= builderToByteStringFlush-                                         C.$= CZ.compressFlush 1 (CZ.WindowBits 31)-                                         C.$= CL.map (fmap fromByteString)-        _ -> res+             in wb $ \body -> sendResponse $ responseStream s hs' $ \sendChunk flush -> do+                    (blazeRecv, blazeFinish) <- B.newBlazeRecv B.defaultStrategy+                    deflate <- Z.initDeflate 1 (Z.WindowBits 31)+                    let sendBuilder builder = do+                            popper <- blazeRecv builder+                            fix $ \loop -> do+                                bs <- popper+                                unless (S.null bs) $ do+                                    sendBS bs+                                    loop+                        sendBS bs = Z.feedDeflate deflate bs >>= deflatePopper+                        flushBuilder = do+                            sendBuilder Blaze.flush+                            deflatePopper $ Z.flushDeflate deflate+                            flush+                        deflatePopper popper = fix $ \loop -> do+                            res <- popper+                            case res of+                                Z.PRDone -> return ()+                                Z.PRNext bs' -> do+                                    sendChunk $ fromByteString bs'+                                    loop+                                Z.PRError e -> throwIO e++                    body sendBuilder flushBuilder+                    sendBuilder Blaze.flush+                    deflatePopper $ Z.finishDeflate deflate+        _ -> sendResponse res   where-    (s, hs, wb) = responseToSource res+    (s, hs, wb) = responseToStream res  -- Remove Content-Length header, since we will certainly have a -- different length after gzip compression.

@@ -32,12 +32,12 @@ basicAuth :: CheckCreds           -> AuthSettings           -> Middleware-basicAuth checkCreds AuthSettings {..} app req = do+basicAuth checkCreds AuthSettings {..} app req sendResponse = do     isProtected <- authIsProtected req     allowed <- if isProtected then check else return True     if allowed-        then app req-        else authOnNoAuth authRealm req+        then app req sendResponse+        else authOnNoAuth authRealm req sendResponse   where     check =         case lookup "Authorization" $ requestHeaders req of@@ -83,7 +83,7 @@ instance IsString AuthSettings where     fromString s = AuthSettings         { authRealm = fromString s-        , authOnNoAuth = \realm _req -> return $ responseLBS+        , authOnNoAuth = \realm _req f -> f $ responseLBS             status401             [ ("Content-Type", "text/plain")             , ("WWW-Authenticate", S.concat

@@ -25,7 +25,6 @@ import Control.Monad (join) import Data.Maybe (fromMaybe) import qualified Data.ByteString as S-import qualified Data.Conduit as C import Data.CaseInsensitive (CI) import Network.HTTP.Types (Status) @@ -37,7 +36,7 @@ -- having a content type of \"text\/javascript\" and calling the specified -- callback function. jsonp :: Middleware-jsonp app env = do+jsonp app env sendResponse = do     let accept = fromMaybe B8.empty $ lookup "Accept" $ requestHeaders env     let callback :: Maybe B8.ByteString         callback =@@ -52,15 +51,15 @@                                            "application/json"                                            $ requestHeaders env                         }-    res <- app env'-    return $ case callback of-        Nothing -> res-        Just c -> go c res+    app env' $ \res ->+        case callback of+            Nothing -> sendResponse res+            Just c -> go c res   where     go c r@(ResponseBuilder s hs b) =-        case checkJSON hs of+        sendResponse $ case checkJSON hs of             Nothing -> r-            Just hs' -> ResponseBuilder s hs' $+            Just hs' -> responseBuilder s hs' $                 copyByteString c                 `mappend` fromChar '('                 `mappend` b@@ -68,9 +67,9 @@     go c r =         case checkJSON hs of             Just hs' -> addCallback c s hs' wb-            Nothing -> r+            Nothing -> sendResponse r       where-        (s, hs, wb) = responseToSource r+        (s, hs, wb) = responseToStream r      checkJSON hs =         case lookup "Content-Type" hs of@@ -80,16 +79,11 @@             _ -> Nothing     fixHeaders = changeVal "Content-Type" "text/javascript" -    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` C.yield (C.Chunk $ fromChar ')')+        wb $ \body -> sendResponse $ responseStream s hs $ \sendChunk flush -> do+            sendChunk $ copyByteString cb `mappend` fromChar '('+            body sendChunk flush+            sendChunk $ fromChar ')'  changeVal :: Eq a           => a

@@ -10,9 +10,9 @@  import Network.Wai import Network.HTTP.Types           (parseQuery)-import Data.Monoid                  (mconcat)-import Data.Conduit.Lazy            (lazyConsume)-import Data.Conduit.List            (sourceList)+import Data.Monoid                  (mconcat, mempty)+import Data.IORef+import Data.ByteString.Lazy (toChunks)  -- | Allows overriding of the HTTP request method via the _method post string parameter. --@@ -26,13 +26,16 @@ -- * This middleware only applies when the initial request method is POST. -- methodOverridePost :: Middleware-methodOverridePost app req = case (requestMethod req, lookup "Content-Type" (requestHeaders req)) of-  ("POST", Just "application/x-www-form-urlencoded") -> setPost req >>= app-  _                                                  -> app req+methodOverridePost app req send =+    case (requestMethod req, lookup "Content-Type" (requestHeaders req)) of+      ("POST", Just "application/x-www-form-urlencoded") -> setPost req >>= flip app send+      _                                                  -> app req send  setPost :: Request -> IO Request setPost req = do-  body <- lazyConsume (requestBody req)-  case parseQuery (mconcat body) of-    (("_method", Just newmethod):_) -> return $ req {requestBody = sourceList body, requestMethod = newmethod}-    _                               -> return $ req {requestBody = sourceList body}+  body <- (mconcat . toChunks) `fmap` lazyRequestBody req+  ref <- newIORef body+  let rb = atomicModifyIORef ref $ \bs -> (mempty, bs)+  case parseQuery body of+    (("_method", Just newmethod):_) -> return $ req {requestBody = rb, requestMethod = newmethod}+    _                               -> return $ req {requestBody = rb}

@@ -29,20 +29,16 @@ import Network.HTTP.Types as H import Data.Maybe (fromMaybe) import Data.Monoid (mconcat)-import Data.Time (getCurrentTime, diffUTCTime)  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- import System.Console.ANSI import Data.IORef.Lifted import System.IO.Unsafe -import Data.Default (Default (def))+import Data.Default.Class (Default (def)) import Network.Wai.Logger import Network.Wai.Middleware.RequestLogger.Internal @@ -97,23 +93,21 @@             return $ customMiddleware callback getdate formatter  apacheMiddleware :: ApacheLoggerActions -> Middleware-apacheMiddleware ala app req = do-    res <- app req+apacheMiddleware ala app req sendResponse = app req $ \res -> do     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+    sendResponse res  customMiddleware :: Callback -> IO ZonedDate -> OutputFormatter -> Middleware-customMiddleware cb getdate formatter app req = do-    res <- app req+customMiddleware cb getdate formatter app req sendResponse = app req $ \res -> do     date <- liftIO getdate     -- We use Nothing for the response size since we generally don't know it     liftIO $ cb $ formatter date req (responseStatus res) Nothing-    return res+    sendResponse res  -- | Production request logger middleware. -- Implemented on top of "logCallback", but prints to 'stdout'@@ -156,11 +150,13 @@ -- -- Example ouput: ----- > GET search :: text/html,application/xhtml+xml,application/xml;q=0.9,*/*;q=0.8+-- > GET search+-- > Accept: text/html,application/xhtml+xml,application/xml;q=0.9,*/*;q=0.8 -- > -- > Status: 200 OK. search -- >--- > GET static/css/normalize.css :: text/css,*/*;q=0.1+-- > GET static/css/normalize.css+-- > Accept: text/css,*/*;q=0.1 -- > GET [("LXwioiBG","")] -- > -- > Status: 304 Not Modified. static/css/normalize.css@@ -185,13 +181,18 @@ detailedMiddleware' :: Callback                     -> IO (BS.ByteString -> [BS.ByteString])                     -> Middleware-detailedMiddleware' cb getAddColor app req = do+detailedMiddleware' cb getAddColor app req sendResponse = do     let mlen = lookup "content-length" (requestHeaders req) >>= readInt     (req', body) <-         case mlen of             -- log the request body if it is small             Just len | len <= 2048 -> do-                 body <- requestBody req C.$$ CL.consume+                 let loop front = do+                        bs <- requestBody req+                        if S8.null bs+                            then return $ front []+                            else loop $ front . (bs:)+                 body <- loop id                  -- logging the body here consumes it, so fill it back up                  -- obviously not efficient, but this is the development logger                  --@@ -203,14 +204,10 @@                  -- implementation ensures that each chunk is only returned                  -- once.                  ichunks <- newIORef body-                 let rbody = do-                        chunks <- readIORef ichunks+                 let rbody = atomicModifyIORef ichunks $ \chunks ->                         case chunks of-                            [] -> return ()-                            x:xs -> do-                                writeIORef ichunks xs-                                C.yield x-                                rbody+                            [] -> ([], S8.empty)+                            x:y -> (y, x)                  let req' = req { requestBody = rbody }                  return (req', body)             _ -> return (req, [])@@ -236,24 +233,20 @@         , "\n"         ] -    t0 <- getCurrentTime-    rsp <- app req'-    t1 <- getCurrentTime+    app req' $ \rsp -> do -    -- 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 $ mconcat $ map toLogStr $-        addColor "Status: " ++ statusBS rsp ++-        [ " "-        , msgBS rsp-        , ". "-        , pack $ show $ diffUTCTime t1 t0-        , ". "-        , rawPathInfo req -- if you need help matching the 2 logging statements-        , "\n"-        ]-    return rsp+        -- 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 $ mconcat $ map toLogStr $+            addColor "Status: " ++ statusBS rsp +++            [ " "+            , msgBS rsp+            , ". "+            , rawPathInfo req -- if you need help matching the 2 logging statements+            , "\n"+            ]+        sendResponse rsp   where     paramsToBS prefix params =       if null params then ""@@ -262,7 +255,13 @@     allPostParams body =         case getRequestBodyType req of             Nothing -> return ([], [])-            Just rbt -> CL.sourceList body C.$$ sinkRequestBody lbsBackEnd rbt+            Just rbt -> do+                ichunks <- newIORef body+                let rbody = atomicModifyIORef ichunks $ \chunks ->+                        case chunks of+                            [] -> ([], S8.empty)+                            x:y -> (y, x)+                sinkRequestBody lbsBackEnd rbt rbody      emptyGetParam :: (BS.ByteString, Maybe BS.ByteString) -> (BS.ByteString, BS.ByteString)     emptyGetParam (k, Just v) = (k,v)

@@ -13,10 +13,10 @@  -- | rewrite based on your own conversion rules rewrite :: ([Text] -> H.RequestHeaders -> IO [Text]) -> Middleware-rewrite convert app req = do+rewrite convert app req sendResponse = do   newPathInfo <- liftIO $ convert (pathInfo req) (requestHeaders req)   let rawPInfo = TE.encodeUtf8 $ T.intercalate "/" newPathInfo-  app req { pathInfo = newPathInfo, rawPathInfo =  rawPInfo }+  app req { pathInfo = newPathInfo, rawPathInfo =  rawPInfo } sendResponse  -- | rewrite based on your own conversion rules -- Example convert function:

@@ -20,10 +20,10 @@   redirectIf home (maybe True (BS.isPrefixOf "www") . lookup "host" . requestHeaders)  redirectIf :: Text -> (Request -> Bool) -> Application -> Application-redirectIf home cond app req =+redirectIf home cond app req sendResponse =   if cond req-    then return $ redirectTo $ TE.encodeUtf8 home-    else app req+    then sendResponse $ redirectTo $ TE.encodeUtf8 home+    else app req sendResponse  redirectTo :: BS.ByteString -> Response redirectTo location = responseLBS H.status301

@@ -12,7 +12,6 @@     , RequestBodyType (..)     , getRequestBodyType     , sinkRequestBody-    , conduitRequestBody     , BackEnd     , lbsBackEnd     , tempFileBackEnd@@ -38,22 +37,14 @@ import Data.Word (Word8) import Data.Maybe (fromMaybe) import Data.List (sortBy)-import Data.Function (on)+import Data.Function (on, fix) import System.Directory (removeFile, getTemporaryDirectory) import System.IO (hClose, openBinaryTempFile) import Network.Wai-import Data.Conduit-import Data.Conduit.Internal ()-import qualified Data.Conduit.List as CL-import qualified Data.Conduit.Binary as CB-import Control.Monad.IO.Class (liftIO) import qualified Network.HTTP.Types as H-import Data.Either (partitionEithers) import Control.Monad (when, unless)-import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Resource (allocate, release, register, InternalState, runInternalState)-import Data.Conduit.Internal (Pipe (NeedInput, HaveOutput), (>+>), withUpstream, injectLeftovers, ConduitM (..))-import Data.Void (Void)+import Data.IORef  breakDiscard :: Word8 -> S.ByteString -> (S.ByteString, S.ByteString) breakDiscard w s =@@ -85,15 +76,22 @@                 _ -> 1.0  -- | Store uploaded files in memory-lbsBackEnd :: Monad m => ignored1 -> ignored2 -> Sink S.ByteString m L.ByteString-lbsBackEnd _ _ = fmap L.fromChunks CL.consume+lbsBackEnd :: Monad m => ignored1 -> ignored2 -> m S.ByteString -> m L.ByteString+lbsBackEnd _ _ popper =+    loop id+  where+    loop front = do+        bs <- popper+        if S.null bs+            then return $ L.fromChunks $ front []+            else loop $ front . (bs:)  -- | Save uploaded files on disk as temporary files -- -- Note: starting with version 2.0, removal of temp files is registered with -- the provided @InternalState@. It is the responsibility of the caller to -- ensure that this @InternalState@ gets cleaned up.-tempFileBackEnd :: InternalState -> ignored1 -> ignored2 -> Sink S.ByteString IO FilePath+tempFileBackEnd :: InternalState -> ignored1 -> ignored2 -> IO S.ByteString -> IO FilePath tempFileBackEnd = tempFileBackEndOpts getTemporaryDirectory "webenc.buf"  -- | Same as 'tempFileSink', but use configurable temp folders and patterns.@@ -102,14 +100,19 @@                     -> InternalState                     -> ignored1                     -> ignored2-                    -> Sink S.ByteString IO FilePath-tempFileBackEndOpts getTmpDir pattern internalState _ _ = do+                    -> IO S.ByteString+                    -> IO FilePath+tempFileBackEndOpts getTmpDir pattern internalState _ _ popper = do     (key, (fp, h)) <- flip runInternalState internalState $ allocate (do         tempDir <- getTmpDir         openBinaryTempFile tempDir pattern) (\(_, h) -> hClose h)     _ <- runInternalState (register $ removeFile fp) internalState-    CB.sinkHandle h-    lift $ release key+    fix $ \loop -> do+        bs <- popper+        unless (S.null bs) $ do+            S.hPut h bs+            loop+    release key     return fp  -- | Information on an uploaded file.@@ -126,11 +129,12 @@ -- | Post parameter name and associated file information. type File y = (S.ByteString, FileInfo y) --- | A file uploading backend. Takes the parameter name, file name, and content--- type, and returns a `Sink` for storing the contents.+-- | A file uploading backend. Takes the parameter name, file name, and a+-- stream of data. type BackEnd a = S.ByteString -- ^ parameter name               -> FileInfo ()-              -> Sink S.ByteString IO a+              -> IO S.ByteString+              -> IO a  data RequestBodyType = UrlEncoded | Multipart S.ByteString @@ -173,60 +177,99 @@ parseRequestBody s r =     case getRequestBodyType r of         Nothing -> return ([], [])-        Just rbt -> fmap partitionEithers $ requestBody r $$ conduitRequestBody s rbt =$ CL.consume+        Just rbt -> sinkRequestBody s rbt (requestBody r)  sinkRequestBody :: BackEnd y                 -> RequestBodyType-                -> Sink S.ByteString IO ([Param], [File y])-sinkRequestBody s r = fmap partitionEithers $ conduitRequestBody s r =$ CL.consume+                -> IO S.ByteString+                -> IO ([Param], [File y])+sinkRequestBody s r body = do+    ref <- newIORef (id, id)+    let add x = atomicModifyIORef ref $ \(y, z) ->+            case x of+                Left y' -> ((y . (y':), z), ())+                Right z' -> ((y, z . (z':)), ())+    conduitRequestBody s r body add+    (x, y) <- readIORef ref+    return (x [], y [])  conduitRequestBody :: BackEnd y                    -> RequestBodyType-                   -> Conduit S.ByteString IO (Either Param (File y))-conduitRequestBody _ UrlEncoded = do+                   -> IO S.ByteString+                   -> (Either Param (File y) -> IO ())+                   -> IO ()+conduitRequestBody _ UrlEncoded rbody add = 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+    let loop front = do+            bs <- rbody+            if S.null bs+                then return $ S.concat $ front []+                else loop $ front . (bs:)+    bs <- loop id+    mapM_ (add . Left) $ H.parseSimpleQuery bs+conduitRequestBody backend (Multipart bound) rbody add =+    parsePieces backend (S8.pack "--" `S.append` bound) rbody add -takeLine :: Monad m => Consumer S.ByteString m (Maybe S.ByteString)-takeLine =+takeLine :: Source -> IO (Maybe S.ByteString)+takeLine src =     go id   where-    go front = await >>= maybe (close front) (push front)+    go front = do+        bs <- readSource src+        if S.null bs+            then close front+            else push front bs -    close front = leftover (front S.empty) >> return Nothing+    close front = leftover src (front S.empty) >> return Nothing     push front bs = do         let (x, y) = S.break (== 10) $ front bs -- LF          in if S.null y                 then go $ S.append x                 else do-                    when (S.length y > 1) $ leftover $ S.drop 1 y+                    when (S.length y > 1) $ leftover src $ S.drop 1 y                     return $ Just $ killCR x -takeLines :: Consumer S.ByteString IO [S.ByteString]-takeLines = do-    res <- takeLine+takeLines :: Source -> IO [S.ByteString]+takeLines src = do+    res <- takeLine src     case res of         Nothing -> return []         Just l             | S.null l -> return []             | otherwise -> do-                ls <- takeLines+                ls <- takeLines src                 return $ l : ls +data Source = Source (IO S.ByteString) (IORef S.ByteString)++mkSource :: IO S.ByteString -> IO Source+mkSource f = do+    ref <- newIORef S.empty+    return $ Source f ref++readSource :: Source -> IO S.ByteString+readSource (Source f ref) = do+    bs <- atomicModifyIORef ref $ \bs -> (S.empty, bs)+    if S.null bs+        then f+        else return bs++leftover :: Source -> S.ByteString -> IO ()+leftover (Source _ ref) bs = writeIORef ref bs+ parsePieces :: BackEnd y             -> S.ByteString-            -> ConduitM S.ByteString (Either Param (File y)) IO ()-parsePieces sink bound =-    loop+            -> IO S.ByteString+            -> (Either Param (File y) -> IO ())+            -> IO ()+parsePieces sink bound rbody add =+    mkSource rbody >>= loop   where-    loop = do-        _boundLine <- takeLine-        res' <- takeLines+    loop src = do+        _boundLine <- takeLine src+        res' <- takeLines src         unless (null res') $ do             let ls' = map parsePair res'             let x = do@@ -239,23 +282,23 @@                 Just (mct, name, Just filename) -> do                     let ct = fromMaybe "application/octet-stream" mct                         fi0 = FileInfo filename ct ()-                    (wasFound, y) <- sinkTillBound' bound name fi0 sink-                    yield $ Right (name, fi0 { fileContent = y })-                    when wasFound loop+                    (wasFound, y) <- sinkTillBound' bound name fi0 sink src+                    add $ Right (name, fi0 { fileContent = y })+                    when wasFound (loop src)                 Just (_ct, name, Nothing) -> do                     let seed = id                     let iter front bs = return $ front . (:) bs-                    (wasFound, front) <- sinkTillBound bound iter seed+                    (wasFound, front) <- sinkTillBound bound iter seed src                     let bs = S.concat $ front []                     let x' = (name, bs)-                    yield $ Left x'-                    when wasFound loop+                    add $ Left x'+                    when wasFound (loop src)                 _ -> do                     -- ignore this part                     let seed = ()                         iter () _ = return ()-                    (wasFound, ()) <- sinkTillBound bound iter seed-                    when wasFound loop+                    (wasFound, ()) <- sinkTillBound bound iter seed src+                    when wasFound (loop src)       where         contDisp = S8.pack "Content-Disposition"         contType = S8.pack "Content-Type"@@ -295,64 +338,78 @@                -> S.ByteString                -> FileInfo ()                -> BackEnd y-               -> ConduitM S.ByteString o IO (Bool, y)-sinkTillBound' bound name fi sink =-    ConduitM $ anyOutput $-    conduitTillBound bound >+> withUpstream (fix $ sink name fi)-  where-    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 ())--    anyOutput p = p >+> dropInput-    dropInput = NeedInput (const dropInput) return+               -> Source+               -> IO (Bool, y)+sinkTillBound' bound name fi sink src = do+    (next, final) <- wrapTillBound bound src+    y <- sink name fi next+    b <- final+    return (b, y) -conduitTillBound :: Monad m-                 => S.ByteString -- bound-                 -> Pipe S.ByteString S.ByteString S.ByteString () m Bool-conduitTillBound bound =-    unConduitM $-    go id+data WTB = WTBWorking (S.ByteString -> S.ByteString)+         | WTBDone Bool+wrapTillBound :: S.ByteString -- ^ bound+              -> Source+              -> IO (IO S.ByteString, IO Bool) -- ^ Bool indicates if the bound was found+wrapTillBound bound src = do+    ref <- newIORef $ WTBWorking id+    return (go ref, final ref)   where-    go front = await >>= maybe (close front) (push front)-    close front = do-        let bs = front S.empty-        unless (S.null bs) $ yield bs-        return False-    push front bs' = do-        let bs = front bs'-        case findBound bound bs of-            FoundBound before after -> do-                let before' = killCRLF before-                yield before'-                leftover after-                return True-            NoBound -> do-                -- don't emit newlines, in case it's part of a bound-                let (toEmit, front') =-                        if not (S8.null bs) && S8.last bs `elem` "\r\n"-                            then let (x, y) = S.splitAt (S.length bs - 2) bs-                                  in (x, S.append y)-                            else (bs, id)-                yield toEmit-                go front'-            PartialBound -> go $ S.append bs+    final ref = do+        x <- readIORef ref+        case x of+            WTBWorking _ -> error "wrapTillBound did not finish"+            WTBDone y -> return y +    go ref = do+        state <- readIORef ref+        case state of+            WTBDone _ -> return S.empty+            WTBWorking front -> do+                bs <- readSource src+                if S.null bs+                    then do+                        writeIORef ref $ WTBDone False+                        return $ front bs+                    else push $ front bs+      where+        push bs =+            case findBound bound bs of+                FoundBound before after -> do+                    let before' = killCRLF before+                    leftover src after+                    writeIORef ref $ WTBDone True+                    return before'+                NoBound -> do+                    -- don't emit newlines, in case it's part of a bound+                    let (toEmit, front') =+                            if not (S8.null bs) && S8.last bs `elem` "\r\n"+                                then let (x, y) = S.splitAt (S.length bs - 2) bs+                                      in (x, S.append y)+                                else (bs, id)+                    writeIORef ref $ WTBWorking front'+                    if S.null toEmit+                        then go ref+                        else return toEmit+                PartialBound -> do+                    writeIORef ref $ WTBWorking $ S.append bs+                    go ref+ sinkTillBound :: S.ByteString               -> (x -> S.ByteString -> IO x)               -> x-              -> Consumer S.ByteString IO (Bool, x)-sinkTillBound bound iter seed0 =-    ConduitM $-    (conduitTillBound bound >+> (withUpstream $ ij $ CL.foldM iter' seed0))-  where-    iter' a b = liftIO $ iter a b-    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 ())+              -> Source+              -> IO (Bool, x)+sinkTillBound bound iter seed0 src = do+    (next, final) <- wrapTillBound bound src+    let loop seed = do+            bs <- next+            if S.null bs+                then return seed+                else iter seed bs >>= loop+    seed <- loop seed0+    b <- final+    return (b, seed)  parseAttrs :: S.ByteString -> [(S.ByteString, S.ByteString)] parseAttrs = map go . S.split 59 -- semicolon

@@ -0,0 +1,214 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+module Network.Wai.Test+    ( -- * Session+      Session+    , runSession+      -- * Requests+    , request+    , srequest+    , SRequest (..)+    , SResponse (..)+    , defaultRequest+    , setPath+    , setRawPathInfo+      -- * Assertions+    , assertStatus+    , assertContentType+    , assertBody+    , assertBodyContains+    , assertHeader+    , assertNoHeader+    , WaiTestFailure (..)+    ) where++import Network.Wai+import Network.Wai.Internal (ResponseReceived (ResponseReceived))+import Control.Monad.IO.Class (liftIO)+import Control.Monad.Trans.State (StateT, evalStateT)+import Control.Monad.Trans.Reader (ReaderT, runReaderT, ask)+import Control.Monad (unless)+import Control.DeepSeq (deepseq)+import Control.Exception (throwIO, Exception)+import Data.Typeable (Typeable)+import Data.Map (Map)+import qualified Data.Map as Map+import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as S8+import Blaze.ByteString.Builder (toLazyByteString)+import qualified Blaze.ByteString.Builder as B+import qualified Data.ByteString.Lazy as L+import qualified Data.ByteString.Lazy.Char8 as L8+import qualified Network.HTTP.Types as H+import Data.CaseInsensitive (CI)+import qualified Data.ByteString as S+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import Data.IORef+import Data.Monoid (mempty, mappend)++type Session = ReaderT Application (StateT ClientState IO)++data ClientState = ClientState+    { _clientCookies :: Map ByteString ByteString+    }++initState :: ClientState+initState = ClientState Map.empty++runSession :: Session a -> Application -> IO a+runSession session app = evalStateT (runReaderT session app) initState++data SRequest = SRequest+    { simpleRequest :: Request+    , simpleRequestBody :: L.ByteString+    }+data SResponse = SResponse+    { simpleStatus :: H.Status+    , simpleHeaders :: H.ResponseHeaders+    , simpleBody :: L.ByteString+    }+    deriving (Show, Eq)+request :: Request -> Session SResponse+request = srequest . flip SRequest L.empty++-- | Set whole path (request path + query string).+setPath :: Request -> S8.ByteString -> Request+setPath req path = req {+    pathInfo = segments+  , rawPathInfo = B.toByteString (H.encodePathSegments segments)+  , queryString = query+  , rawQueryString = (H.renderQuery True query)+  }+  where+    (segments, query) = H.decodePath path++setRawPathInfo :: Request -> S8.ByteString -> Request+setRawPathInfo r rawPinfo =+    let pInfo = dropFrontSlash $ T.split (== '/') $ TE.decodeUtf8 rawPinfo+    in  r { rawPathInfo = rawPinfo, pathInfo = pInfo }+  where+    dropFrontSlash ("":"":[]) = [] -- homepage, a single slash+    dropFrontSlash ("":path) = path+    dropFrontSlash path = path++srequest :: SRequest -> Session SResponse+srequest (SRequest req bod) = do+    app <- ask+    refChunks <- liftIO $ newIORef $ L.toChunks bod+    let req' = req+            { requestBody = atomicModifyIORef refChunks $ \bss ->+                case bss of+                    [] -> ([], S.empty)+                    x:y -> (y, x)+            }+    liftIO $ do+        ref <- newIORef $ error "runResponse gave no result"+        ResponseReceived <- app req' (runResponse ref)+        readIORef ref+    -- FIXME cookie processing+    --return sres++runResponse :: IORef SResponse -> Response -> IO ResponseReceived+runResponse ref res = do+    refBuilder <- newIORef mempty+    let add y = atomicModifyIORef refBuilder $ \x -> (x `mappend` y, ())+    withBody $ \body -> body add (return ())+    builder <- readIORef refBuilder+    let lbs = toLazyByteString builder+        len = L.length lbs+    -- Force evaluation of the body to have exceptions thrown at the right+    -- time.+    seq len $ writeIORef ref $ SResponse s h $ toLazyByteString builder+    return ResponseReceived+  where+    (s, h, withBody) = responseToStream res++assertBool :: String -> Bool -> Session ()+assertBool s b = unless b $ assertFailure s++assertString :: String -> Session ()+assertString s = unless (null s) $ assertFailure s++assertFailure :: String -> Session ()+assertFailure msg = msg `deepseq` liftIO (throwIO (WaiTestFailure msg))++data WaiTestFailure = WaiTestFailure String+    deriving (Show, Eq, Typeable)+instance Exception WaiTestFailure++assertContentType :: ByteString -> SResponse -> Session ()+assertContentType ct SResponse{simpleHeaders = h} =+    case lookup "content-type" h of+        Nothing -> assertString $ concat+            [ "Expected content type "+            , show ct+            , ", but no content type provided"+            ]+        Just ct' -> assertBool (concat+            [ "Expected content type "+            , show ct+            , ", but received "+            , show ct'+            ]) (go ct == go ct')+  where+    go = S8.takeWhile (/= ';')++assertStatus :: Int -> SResponse -> Session ()+assertStatus i SResponse{simpleStatus = s} = assertBool (concat+    [ "Expected status code "+    , show i+    , ", but received "+    , show sc+    ]) $ i == sc+  where+    sc = H.statusCode s++assertBody :: L.ByteString -> SResponse -> Session ()+assertBody lbs SResponse{simpleBody = lbs'} = assertBool (concat+    [ "Expected response body "+    , show $ L8.unpack lbs+    , ", but received "+    , show $ L8.unpack lbs'+    ]) $ lbs == lbs'++assertBodyContains :: L.ByteString -> SResponse -> Session ()+assertBodyContains lbs SResponse{simpleBody = lbs'} = assertBool (concat+    [ "Expected response body to contain "+    , show $ L8.unpack lbs+    , ", but received "+    , show $ L8.unpack lbs'+    ]) $ strict lbs `S.isInfixOf` strict lbs'+  where+    strict = S.concat . L.toChunks++assertHeader :: CI ByteString -> ByteString -> SResponse -> Session ()+assertHeader header value SResponse{simpleHeaders = h} =+    case lookup header h of+        Nothing -> assertString $ concat+            [ "Expected header "+            , show header+            , " to be "+            , show value+            , ", but it was not present"+            ]+        Just value' -> assertBool (concat+            [ "Expected header "+            , show header+            , " to be "+            , show value+            , ", but received "+            , show value'+            ]) (value == value')++assertNoHeader :: CI ByteString -> SResponse -> Session ()+assertNoHeader header SResponse{simpleHeaders = h} =+    case lookup header h of+        Nothing -> return ()+        Just s -> assertString $ concat+            [ "Unexpected header "+            , show header+            , " containing "+            , show s+            ]

@@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings, TypeSynonymInstances, FlexibleInstances #-}+{-# LANGUAGE ExistentialQuantification #-} {- | This module gives you a way to mount applications under sub-URIs. For example: @@ -83,14 +84,14 @@     toApplication = id  instance ToApplication UrlMap where-    toApplication urlMap = \req ->+    toApplication urlMap req sendResponse =         case try (pathInfo req) (unUrlMap urlMap) of             Just (newPath, app) ->-                app $ req { pathInfo = newPath-                          , rawPathInfo = makeRaw newPath-                          }+                app (req { pathInfo = newPath+                         , rawPathInfo = makeRaw newPath+                         }) sendResponse             Nothing ->-                return $ responseLBS+                sendResponse $ responseLBS                     status404                     [("content-type", "text/plain")]                     "Not found\n"

@@ -0,0 +1,36 @@+{-# LANGUAGE OverloadedStrings #-}+module Network.Wai.TestSpec (main, spec) where++import           Test.Hspec++import           Network.Wai+import           Network.Wai.Test++main :: IO ()+main = hspec spec++spec :: Spec+spec = do+  describe "setPath" $ do++    let req = setPath defaultRequest "/foo/bar/baz?foo=23&bar=42&baz"++    it "sets pathInfo" $ do+      pathInfo req `shouldBe` ["foo", "bar", "baz"]++    it "utf8 path" $+      pathInfo (setPath defaultRequest "/foo/%D7%A9%D7%9C%D7%95%D7%9D/bar") `shouldBe`+        ["foo", "שלום", "bar"]++    it "sets rawPathInfo" $ do+      rawPathInfo req `shouldBe` "/foo/bar/baz"++    it "sets queryString" $ do+      queryString req `shouldBe` [("foo", Just "23"), ("bar", Just "42"), ("baz", Nothing)]++    it "sets rawQueryString" $ do+      rawQueryString req `shouldBe` "?foo=23&bar=42&baz"++    context "when path has no query string" $ do+      it "sets rawQueryString to empty string" $ do+        rawQueryString (setPath defaultRequest "/foo/bar/baz") `shouldBe` ""

@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}

@@ -3,7 +3,7 @@  import Test.Hspec import Test.HUnit hiding (Test)-import Data.Monoid (mappend, mempty, (<>))+import Data.Monoid (mappend, mempty)  import Network.Wai import Network.Wai.Test@@ -30,9 +30,6 @@ import Network.Wai.Middleware.RequestLogger import Codec.Compression.GZip (decompress) -import qualified Data.Conduit as C-import qualified Data.Conduit.List as CL-import Data.Conduit.Binary (sourceHandle) import Control.Monad.IO.Class (liftIO) import Data.Maybe (fromMaybe) import Network.HTTP.Types (parseSimpleQuery, status200)@@ -128,7 +125,13 @@ parseRequestBody' sink (SRequest req bod) =     case getRequestBodyType req of         Nothing -> return ([], [])-        Just rbt -> CL.sourceList (L.toChunks bod) C.$$ sinkRequestBody sink rbt+        Just rbt -> do+            ref <- I.newIORef $ L.toChunks bod+            let rb = I.atomicModifyIORef ref $ \chunks ->+                        case chunks of+                            [] -> ([], S.empty)+                            x:y -> (y, x)+            sinkRequestBody sink rbt rb  caseParseRequestBody :: Assertion caseParseRequestBody =@@ -295,7 +298,7 @@ -}  jsonpApp :: Application-jsonpApp = jsonp $ const $ return $ responseLBS+jsonpApp = jsonp $ \_ f -> f $ responseLBS     status200     [("Content-Type", "application/json")]     "{\"foo\":\"bar\"}"@@ -324,7 +327,7 @@     assertBody "{\"foo\":\"bar\"}" sres3  gzipApp :: Application-gzipApp = gzip def $ const $ return $ responseLBS status200+gzipApp = gzip def $ \_ f -> f $ responseLBS status200     [("Content-Type", "text/plain")]     "test" @@ -332,7 +335,7 @@ -- that the compression is skipped based on the presence of -- the Content-Encoding header. gzipPrecompressedApp :: Application-gzipPrecompressedApp = gzip def $ const $ return $ responseLBS status200+gzipPrecompressedApp = gzip def $ \_ f -> f $ responseLBS status200     [("Content-Type", "text/plain"), ("Content-Encoding", "gzip")]     "test" @@ -380,8 +383,8 @@     assertBody "test" sres1 -- the body is not actually compressed  vhostApp1, vhostApp2, vhostApp :: Application-vhostApp1 = const $ return $ responseLBS status200 [] "app1"-vhostApp2 = const $ return $ responseLBS status200 [] "app2"+vhostApp1 _ f = f $ responseLBS status200 [] "app1"+vhostApp2 _ f = f $ responseLBS status200 [] "app2" vhostApp = vhost     [ ((== Just "foo.com") . lookup "host" . requestHeaders, vhostApp1)     ]@@ -400,7 +403,7 @@     assertBody "app2" sres2  autoheadApp :: Application-autoheadApp = autohead $ const $ return $ responseLBS status200+autoheadApp = autohead $ \_ f -> f $ responseLBS status200     [("Foo", "Bar")] "body"  caseAutohead :: Assertion@@ -418,7 +421,7 @@     assertBody "" sres2  moApp :: Application-moApp = methodOverride $ \req -> return $ responseLBS status200+moApp = methodOverride $ \req f -> f $ responseLBS status200     [("Method", requestMethod req)] ""  caseMethodOverride :: Assertion@@ -442,7 +445,7 @@     assertHeader "Method" "PUT" sres3  mopApp :: Application-mopApp = methodOverridePost $ \req -> return $ responseLBS status200 [("Method", requestMethod req)] ""+mopApp = methodOverridePost $ \req f -> f $ responseLBS status200 [("Method", requestMethod req)] ""  caseMethodOverridePost :: Assertion caseMethodOverridePost = flip runSession mopApp $ do@@ -468,7 +471,7 @@     assertHeader "Method" "POST" sres4  aoApp :: Application-aoApp = acceptOverride $ \req -> return $ responseLBS status200+aoApp = acceptOverride $ \req f -> f $ responseLBS status200     [("Accept", fromMaybe "" $ lookup "Accept" $ requestHeaders req)] ""  caseAcceptOverride :: Assertion@@ -520,7 +523,7 @@         case getRequestBodyType request' of             Nothing -> return ([], [])             Just rbt -> withFile "test/requests/dalvik-request" ReadMode $ \h ->-                sourceHandle h C.$$ sinkRequestBody lbsBackEnd rbt+                sinkRequestBody lbsBackEnd rbt $ S.hGetSome h 2048     lookup "scannedTime" params @?= Just "1.298590056748E9"     lookup "geoLong" params @?= Just "0"     lookup "geoLat" params @?= Just "0"@@ -545,26 +548,21 @@   where     params = [("foo", "bar"), ("baz", "bin")]     -- FIXME change back once we include post parameter output in logging postOutput = T.pack $ "POST \nAccept: \nPOST " ++ (show params)-    -- the time cannot be known, so match around it-    postOutput = ("POST / :: \nStatus: 200 OK. 0", "s. /\n")-    getOutput params' = ("GET /location :: \nGET " <> T.pack (show params') <> "\nStatus: 200 OK. 0", "s. /location\n")+    postOutput = T.pack $ "POST / :: \nStatus: 200 OK. /\n"+    getOutput params' = T.pack $ "GET /location :: \nGET " ++ show params' ++ "\nStatus: 200 OK. /location\n" -    debugApp (beginning, ending) req = do-        iactual <- liftIO $ I.newIORef mempty-        middleware <- liftIO $ mkRequestLogger def+    debugApp output' req send = do+        iactual <- I.newIORef mempty+        middleware <- mkRequestLogger def             { destination = Callback $ \strs -> I.modifyIORef iactual $ (`mappend` strs)             , outputFormat = Detailed False             }-        res <- middleware (\_req -> return $ responseLBS status200 [ ] "") req-        actual <- logToBs <$> liftIO (I.readIORef iactual)-        liftIO $ do-          actual `shouldSatisfy` S.isPrefixOf begin-          actual `shouldSatisfy` S.isSuffixOf end-+        res <- middleware (\_req f -> f $ responseLBS status200 [ ] "") req send+        actual <- I.readIORef iactual+        assertEqual "debug" output $ logToBs actual         return res       where-        begin = TE.encodeUtf8 $ T.toStrict beginning-        end   = TE.encodeUtf8 $ T.toStrict ending+        output = TE.encodeUtf8 $ T.toStrict output'          logToBs = fromLogStr @@ -583,8 +581,8 @@    where   trivialApp :: S.ByteString -> Application-  trivialApp name req =-    return $+  trivialApp name req f =+    f $       responseLBS         status200         [ ("content-type", "text/plain")

@@ -1,5 +1,5 @@ Name:                wai-extra-Version:             2.1.1.3+Version:             3.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                       >= 2.1      && < 2.2+                   , wai                       >= 3.0      && < 3.1                    , old-locale                >= 1.0.0.2  && < 1.1                    , time                      >= 1.1.4                    , network                   >= 2.2.1.5@@ -32,13 +32,9 @@                    , http-types                >= 0.7                    , text                      >= 0.7                    , case-insensitive          >= 0.2-                   , data-default+                   , data-default-class                    , fast-logger               >= 2.1      && < 2.2                    , wai-logger                >= 2.0      && < 2.2-                   , conduit                   >= 1.0      && < 1.2-                   , conduit-extra             >= 0.1      && < 1.2-                   , zlib-conduit              >= 0.5      && < 1.2-                   , blaze-builder-conduit     >= 0.5      && < 1.2                    , ansi-terminal                    , resourcet                 >= 0.4.6    && < 1.2                    , void                      >= 0.5@@ -47,6 +43,8 @@                    , base64-bytestring                    , word8                    , lifted-base               >= 0.1.2+                   , deepseq+                   , streaming-commons    if os(windows)       cpp-options:   -DWINDOWS@@ -68,6 +66,9 @@                      Network.Wai.Middleware.HttpAuth                      Network.Wai.Parse                      Network.Wai.UrlMap+                     Network.Wai.Test+                     Network.Wai.EventSource+                     Network.Wai.EventSource.EventStream   other-modules:     Network.Wai.Middleware.RequestLogger.Internal   ghc-options:       -Wall @@ -79,7 +80,6 @@      build-depends:   base                      >= 4        && < 5                    , wai-extra-                   , wai-test                  >= 1.3                    , hspec                     >= 1.3                    , HUnit @@ -90,14 +90,22 @@                    , text                    , bytestring                    , directory-                   , zlib-bindings                    , blaze-builder             >= 0.2.1.4  && < 0.4                    , data-default-                   , conduit                    , fast-logger               >= 2.1                    , resourcet-                   , conduit-extra     ghc-options:       -Wall++test-suite spec+    type:            exitcode-stdio-1.0+    hs-source-dirs:  test+    main-is:         Spec.hs+    other-modules:   Network.Wai.TestSpec+    build-depends:   base                      >= 4        && < 5+                   , wai-extra+                   , wai+                   , hspec >= 1.3+    ghc-options:     -Wall -Werror  source-repository head   type:     git