wai-extra 1.2.0.6 → 1.3.0

raw patch · 6 files changed

+265/−201 lines, 6 filesdep +voiddep +wai-loggerdep ~blaze-builder-conduitdep ~conduitdep ~data-defaultPVP ok

version bump matches the API change (PVP)

Dependencies added: void, wai-logger

Dependency ranges changed: blaze-builder-conduit, conduit, data-default, fast-logger, hspec, http-types, wai, wai-test, zlib-conduit

API changes (from Hackage documentation)

Files

• Network/Wai/Handler/CGI.hs +19/−19
• Network/Wai/Middleware/RequestLogger.hs +101/−57
• Network/Wai/Parse.hs +107/−106
• test/WaiExtraTest.hs +23/−8
• tests.hs +1/−1
• wai-extra.cabal +14/−10

@@ -30,7 +30,7 @@ import qualified Network.HTTP.Types as H import qualified Data.CaseInsensitive as CI import Data.Monoid (mappend)-import qualified Data.Conduit as C+import Data.Conduit import qualified Data.Conduit.List as CL  safeRead :: Read a => a -> String -> a@@ -66,7 +66,7 @@ -- stick with 'run' or 'runSendfile'. runGeneric      :: [(String, String)] -- ^ all variables-     -> (Int -> C.Source (C.ResourceT IO) B.ByteString) -- ^ responseBody of input+     -> (Int -> Source (ResourceT IO) B.ByteString) -- ^ responseBody of input      -> (B.ByteString -> IO ()) -- ^ destination for output      -> Maybe B.ByteString -- ^ does the server support the X-Sendfile header?      -> Application@@ -94,7 +94,7 @@             case addrs of                 a:_ -> addrAddress a                 [] -> error $ "Invalid REMOTE_ADDR or REMOTE_HOST: " ++ remoteHost'-    C.runResourceT $ do+    runResourceT $ do         let env = Request                 { requestMethod = rmethod                 , rawPathInfo = B.pack pinfo@@ -117,9 +117,9 @@                 liftIO $ mapM_ outputH $ L.toChunks $ toLazyByteString $ sfBuilder s hs sf fp             _ -> do                 let (s, hs, b) = responseSource res-                    src = CL.sourceList [C.Chunk $ headers s hs `mappend` fromChar '\n']+                    src = CL.sourceList [Chunk $ headers s hs `mappend` fromChar '\n']                           `mappend` b-                src C.$$ builderSink+                src $$ builderSink   where     headers s hs = mconcat (map header $ status s : map header' (fixHeaders hs))     status (Status i m) = (fromByteString "Status", mconcat@@ -141,13 +141,13 @@         , fromByteString sf         , fromByteString " not supported"         ]-    bsSink = C.NeedInput push (return ())-    push (C.Chunk bs) = C.PipeM (do+    bsSink = awaitE >>= either return push+    push (Chunk bs) = do         liftIO $ outputH bs-        return bsSink) (return ())+        bsSink     -- FIXME actually flush?-    push C.Flush = bsSink-    builderSink = builderToByteStringFlush C.=$ bsSink+    push Flush = bsSink+    builderSink = builderToByteStringFlush =$ bsSink     fixHeaders h =         case lookup "content-type" h of             Nothing -> ("Content-Type", "text/html; charset=utf-8") : h@@ -166,19 +166,19 @@     helper' (x:rest) = toLower x : helper' rest     helper' [] = [] -requestBodyHandle :: Handle -> Int -> C.Source (C.ResourceT IO) B.ByteString+requestBodyHandle :: Handle -> Int -> Source (ResourceT 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 -> C.Source (C.ResourceT IO) B.ByteString-requestBodyFunc get count0 =-    C.sourceState count0 pull+requestBodyFunc :: (Int -> IO (Maybe B.ByteString)) -> Int -> Source (ResourceT IO) B.ByteString+requestBodyFunc get =+    loop   where-    pull 0 = return C.StateClosed-    pull count = do+    loop 0 = return ()+    loop count = do         mbs <- liftIO $ get $ min count defaultChunkSize         let count' = count - maybe 0 B.length mbs-        return $ case mbs of-            Nothing -> C.StateClosed-            Just bs -> C.StateOpen count' bs+        case mbs of+            Nothing -> return ()+            Just bs -> yield bs >> loop count'

@@ -1,15 +1,22 @@ {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-} module Network.Wai.Middleware.RequestLogger-    ( logStdout-    , logCallback+    ( -- * Basic stdout logging+      logStdout     , logStdoutDev-    , logCallbackDev-    -- * Deprecated-    , logHandle-    , logHandleDev+      -- * Create more versions+    , mkRequestLogger+    , RequestLoggerSettings+    , outputFormat+    , autoFlush+    , destination+    , OutputFormat (..)+    , Destination (..)+    , Callback+    , IPAddrSource (..)     ) where -import System.IO (stdout, hFlush)+import System.IO (Handle, stdout) import qualified Data.ByteString as BS import Data.ByteString.Char8 (pack, unpack) import Control.Monad.IO.Class (liftIO)@@ -28,17 +35,68 @@ import Data.IORef import System.IO.Unsafe -logHandle :: (BS.ByteString -> IO ()) -> Middleware-logHandle = logCallback-{-# DEPRECATED logHandle "Please use logCallback instead." #-}-logHandleDev :: (BS.ByteString -> IO ()) -> Middleware-logHandleDev = logCallbackDev-{-# DEPRECATED logHandleDev "Please use logCallbackDev instead." #-}+import Data.Default (Default (def))+import Network.Wai.Logger.Format (apacheFormat, IPAddrSource (..))+import System.Log.FastLogger.Date (getDate, dateInit, ZonedDate) +data OutputFormat = Apache IPAddrSource+                  | Detailed Bool -- ^ use colors?++data Destination = Handle Handle+                 | Logger Logger+                 | Callback Callback++type Callback = [LogStr] -> IO ()++data RequestLoggerSettings = RequestLoggerSettings+    {+      -- | Default value: @Detailed@ @True@.+      outputFormat :: OutputFormat+      -- | Only applies when using the @Handle@ constructor for @destination@.+      --+      -- Default value: @True@.+    , autoFlush :: Bool+      -- | Default: @Handle@ @stdout@.+    , destination :: Destination+    }++instance Default RequestLoggerSettings where+    def = RequestLoggerSettings+        { outputFormat = Detailed True+        , autoFlush = True+        , destination = Handle stdout+        }++mkRequestLogger :: RequestLoggerSettings -> IO Middleware+mkRequestLogger RequestLoggerSettings{..} = do+    (callback, mgetdate) <-+        case destination of+            Handle h -> fmap fromLogger $ mkLogger autoFlush h+            Logger l -> return $ fromLogger l+            Callback c -> return (c, Nothing)+    case outputFormat of+        Apache ipsrc -> do+            getdate <-+                case mgetdate of+                    Just x -> return x+                    Nothing -> fmap getDate dateInit+            return $ apacheMiddleware callback ipsrc getdate+        Detailed useColors -> detailedMiddleware callback useColors+  where+    fromLogger l = (loggerPutStr l, Just $ loggerDate l)++apacheMiddleware :: Callback -> IPAddrSource -> IO ZonedDate -> Middleware+apacheMiddleware cb ipsrc getdate app req = do+    res <- app req+    date <- liftIO getdate+    -- We use Nothing for the response size since we generally don't know it+    liftIO $ cb $ apacheFormat ipsrc date req (responseStatus res) Nothing+    return res+ -- | Production request logger middleware. -- Implemented on top of "logCallback", but prints to 'stdout' logStdout :: Middleware-logStdout = logCallback $ \bs -> hPutLogStr stdout [LB bs]+logStdout = unsafePerformIO $ mkRequestLogger def { outputFormat = Apache FromSocket }  -- | Development request logger middleware. -- Implemented on top of "logCallbackDev", but prints to 'stdout'@@ -46,39 +104,11 @@ -- Flushes 'stdout' on each request, which would be inefficient in production use. -- Use "logStdout" in production. logStdoutDev :: Middleware-logStdoutDev = logCallbackDev $ \bs -> hPutLogStr stdout [LB bs] >> hFlush stdout---- | Prints a message using the given callback function for each request.--- Designed for fast production use at the expense of convenience.--- In particular, no POST parameter information is currently given------ This is lower-level - use "logStdout" unless you need this greater control-logCallback :: (BS.ByteString -> IO ()) -- ^ A function that logs the ByteString log message.-            -> Middleware-logCallback cb app req = do-    rsp <- app req-    liftIO $ cb $ BS.concat-        [ requestMethod req-        , " "-        , rawPathInfo req-        , rawQueryString req-        , " "-        , "Accept: "-        , maybe "" toBS $ lookup "Accept" $ requestHeaders req-        , "\n"-        , "Status: "-        , statusBS rsp-        , " "-        , msgBS rsp-        ]-    return rsp--toBS :: H.Ascii -> BS.ByteString-toBS = id+logStdoutDev = unsafePerformIO $ mkRequestLogger def  -- no black or white which are expected to be existing terminal colors.-colors :: IORef [Color]-colors = unsafePerformIO $ newIORef [+colors0 :: [Color]+colors0 = [     Red    , Green    , Yellow @@ -115,9 +145,29 @@ -- > GET [("LXwioiBG","")] -- > -- > Status: 304 Not Modified. static/css/normalize.css-logCallbackDev :: (BS.ByteString -> IO ()) -- ^ A function that logs the ByteString log message.-               -> Middleware-logCallbackDev cb app req = do++detailedMiddleware :: Callback -> Bool -> IO Middleware+detailedMiddleware cb useColors = do+    getAddColor <-+        if useColors+            then do+                icolors <- newIORef colors0+                return $ do+                    color <- liftIO $ atomicModifyIORef icolors rotateColors+                    return $ ansiColor color+            else return (return return)+    return $ detailedMiddleware' cb getAddColor+  where+    ansiColor color bs = [+        pack $ setSGRCode [SetColor Foreground Vivid color]+      , bs+      , pack $ setSGRCode [Reset]+      ]++detailedMiddleware' :: Callback+                    -> (C.ResourceT IO (BS.ByteString -> [BS.ByteString]))+                    -> Middleware+detailedMiddleware' cb getAddColor app req = do     let mlen = lookup "content-length" (requestHeaders req) >>= readInt     (req', body) <-         case mlen of@@ -137,10 +187,10 @@      let getParams = map emptyGetParam $ queryString req -    color <- liftIO $ atomicModifyIORef colors rotateColors+    addColor <- getAddColor      -- log the request immediately.-    liftIO $ cb $ BS.concat $ ansiColor color (requestMethod req) +++    liftIO $ cb $ map LB $ addColor (requestMethod req) ++         [ " "         , rawPathInfo req         , "\n"@@ -156,7 +206,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 $ BS.concat $ ansiColor color "Status: " ++ [+    liftIO $ cb $ map LB $ addColor "Status: " ++ [           statusBS rsp         , " "         , msgBS rsp@@ -166,12 +216,6 @@       ]     return rsp   where-    ansiColor color bs = [-        pack $ setSGRCode [SetColor Foreground Vivid color]-      , bs-      , pack $ setSGRCode [Reset]-      ]-     paramsToBS prefix params =       if null params then ""         else BS.concat ["\n", prefix, pack (show params)]

@@ -10,15 +10,13 @@     , getRequestBodyType     , sinkRequestBody     , conduitRequestBody+    , BackEnd     , lbsBackEnd     , tempFileBackEnd-    , BackEnd (..)+    , tempFileBackEndOpts     , Param     , File     , FileInfo (..)-    -- ** Deprecated-    , lbsSink-    , tempFileSink #if TEST     , Bound (..)     , findBound@@ -40,11 +38,16 @@ import System.Directory (removeFile, getTemporaryDirectory) import System.IO (hClose, openBinaryTempFile) import Network.Wai-import qualified Data.Conduit as C+import Data.Conduit+import Data.Conduit.Internal (sinkToPipe) 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)  breakDiscard :: Word8 -> S.ByteString -> (S.ByteString, S.ByteString) breakDiscard w s =@@ -69,47 +72,29 @@                 _ -> 1.0     trimWhite = S.dropWhile (== 32) -- space --- | A destination for file data, with concrete implemtations--- provided by 'lbsBackEnd' and 'tempFileBackEnd'-data BackEnd y = forall x . BackEnd-    { initialize :: IO x-    , append :: x -> S.ByteString -> IO x-    , close :: x -> IO y-    , finalize :: y -> IO ()-    }- -- | Store uploaded files in memory-lbsBackEnd :: BackEnd L.ByteString-lbsBackEnd = BackEnd-    { initialize = return id-    , append = \front bs -> return $ front . (:) bs-    , close = \front -> return $ L.fromChunks $ front []-    , finalize = \_ -> return ()-    }+lbsBackEnd :: Monad m => ignored1 -> ignored2 -> Sink S.ByteString m L.ByteString+lbsBackEnd _ _ = fmap L.fromChunks CL.consume  -- | Save uploaded files on disk as temporary files-tempFileBackEnd :: BackEnd FilePath-tempFileBackEnd = BackEnd-    { initialize = do-        tempDir <- getTemporaryDirectory-        openBinaryTempFile tempDir "webenc.buf"-    , append = \(fp, h) bs -> S.hPut h bs >> return (fp, h)-    , close = \(fp, h) -> do-        hClose h-        return fp-    , finalize = \fp -> removeFile fp-    }---- | This function has been renamed to 'lbsBackEnd'-lbsSink :: BackEnd L.ByteString-lbsSink = lbsBackEnd---- | This function has been renamed to  'tempFileBackEnd'-tempFileSink :: BackEnd FilePath-tempFileSink = tempFileBackEnd+tempFileBackEnd :: MonadResource m => ignored1 -> ignored2 -> Sink S.ByteString m FilePath+tempFileBackEnd = tempFileBackEndOpts getTemporaryDirectory "webenc.buf" -{-# DEPRECATED lbsSink "Please use 'lbsBackEnd'" #-}-{-# DEPRECATED tempFileSink "Please use 'tempFileBackEnd'" #-}+-- | Same as 'tempFileSink', but use configurable temp folders and patterns.+tempFileBackEndOpts :: MonadResource m+                    => IO FilePath -- ^ get temporary directory+                    -> String -- ^ filename pattern+                    -> ignored1+                    -> ignored2+                    -> Sink S.ByteString m FilePath+tempFileBackEndOpts getTmpDir pattern _ _ = do+    (key, (fp, h)) <- lift $ allocate (do+        tempDir <- getTmpDir+        openBinaryTempFile tempDir pattern) (\(_, h) -> hClose h)+    _ <- lift $ register $ removeFile fp+    CB.sinkHandle h+    lift $ release key+    return fp  -- | Information on an uploaded file. data FileInfo c = FileInfo@@ -122,6 +107,12 @@ type Param = (S.ByteString, S.ByteString) 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.+type BackEnd a = S.ByteString -- ^ parameter name+              -> FileInfo ()+              -> Sink S.ByteString (ResourceT IO) a+ data RequestBodyType = UrlEncoded | Multipart S.ByteString  getRequestBodyType :: Request -> Maybe RequestBodyType@@ -147,43 +138,45 @@  parseRequestBody :: BackEnd y                  -> Request-                 -> C.ResourceT IO ([Param], [File y])+                 -> ResourceT IO ([Param], [File y]) parseRequestBody s r =     case getRequestBodyType r of         Nothing -> return ([], [])-        Just rbt -> fmap partitionEithers $ requestBody r C.$$ conduitRequestBody s rbt C.=$ CL.consume+        Just rbt -> fmap partitionEithers $ requestBody r $$ conduitRequestBody s rbt =$ CL.consume  sinkRequestBody :: BackEnd y                 -> RequestBodyType-                -> C.Sink S.ByteString (C.ResourceT IO) ([Param], [File y])-sinkRequestBody s r = fmap partitionEithers $ conduitRequestBody s r C.=$ CL.consume+                -> Sink S.ByteString (ResourceT IO) ([Param], [File y])+sinkRequestBody s r = fmap partitionEithers $ conduitRequestBody s r =$ CL.consume  conduitRequestBody :: BackEnd y                    -> RequestBodyType-                   -> C.Conduit S.ByteString (C.ResourceT IO) (Either Param (File y))-conduitRequestBody _ UrlEncoded = C.sequenceSink () $ \() -> do -- url-encoded+                   -> Conduit S.ByteString (ResourceT 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-    return $ C.Emit () $ map Left $ H.parseSimpleQuery $ S.concat bs+    mapM_ yield $ map Left $ H.parseSimpleQuery $ S.concat bs conduitRequestBody backend (Multipart bound) =     parsePieces backend $ S8.pack "--" `S.append` bound -takeLine :: C.Sink S.ByteString (C.ResourceT IO) (Maybe S.ByteString)+takeLine :: Monad m => Pipe S.ByteString S.ByteString o u m (Maybe S.ByteString) takeLine =-    C.sinkState id push close'+    go id   where-    close' _ = return Nothing+    go front = await >>= maybe (close front) (push front)++    close front = leftover (front S.empty) >> return Nothing     push front bs = do         let (x, y) = S.break (== 10) $ front bs -- LF          in if S.null y-                then return $ C.StateProcessing $ S.append x+                then go $ S.append x                 else do-                    let lo = if S.length y > 1 then Just (S.drop 1 y) else Nothing-                    return $ C.StateDone lo $ Just $ killCR x+                    when (S.length y > 1) $ leftover $ S.drop 1 y+                    return $ Just $ killCR x -takeLines :: C.Sink S.ByteString (C.ResourceT IO) [S.ByteString]+takeLines :: Pipe S.ByteString S.ByteString o u (ResourceT IO) [S.ByteString] takeLines = do     res <- takeLine     case res of@@ -194,21 +187,16 @@                 ls <- takeLines                 return $ l : ls -parsePieces :: BackEnd y -> S.ByteString-            -> C.Conduit S.ByteString (C.ResourceT IO) (Either Param (File y))-parsePieces sink bound = C.sequenceSink True (parsePiecesSink sink bound)--parsePiecesSink :: BackEnd y-                -> S.ByteString-                -> C.SequencedSink Bool S.ByteString (C.ResourceT IO) (Either Param (File y))-parsePiecesSink _ _ False = return C.Stop-parsePiecesSink BackEnd{initialize=initialize',append=append',close=close'}-                bound True = do-    _boundLine <- takeLine-    res' <- takeLines-    case res' of-        [] -> return C.Stop-        _ -> do+parsePieces :: BackEnd y+            -> S.ByteString+            -> Pipe S.ByteString S.ByteString (Either Param (File y)) u (ResourceT IO) ()+parsePieces sink bound =+    loop+  where+    loop = do+        _boundLine <- takeLine+        res' <- takeLines+        unless (null res') $ do             let ls' = map parsePair res'             let x = do                     cd <- lookup contDisp ls'@@ -219,33 +207,30 @@             case x of                 Just (mct, name, Just filename) -> do                     let ct = fromMaybe "application/octet-stream" mct-                    seed <- liftIO initialize'-                    (seed', wasFound) <--                        sinkTillBound bound append' seed-                    y <- liftIO $ close' seed'-                    let fi = FileInfo filename ct y-                    let y' = (name, fi)-                    return $ C.Emit wasFound [Right y']+                        fi0 = FileInfo filename ct ()+                    (wasFound, y) <- sinkTillBound' bound name fi0 sink+                    yield $ Right (name, fi0 { fileContent = y })+                    when wasFound loop                 Just (_ct, name, Nothing) -> do                     let seed = id                     let iter front bs = return $ front . (:) bs-                    (front, wasFound) <--                        sinkTillBound bound iter seed+                    (wasFound, front) <- sinkTillBound bound iter seed                     let bs = S.concat $ front []                     let x' = (name, bs)-                    return $ C.Emit wasFound [Left x']+                    yield $ Left x'+                    when wasFound loop                 _ -> do                     -- ignore this part                     let seed = ()                         iter () _ = return ()-                    ((), wasFound) <- sinkTillBound bound iter seed-                    return $ C.Emit wasFound []-  where-    contDisp = S8.pack "Content-Disposition"-    contType = S8.pack "Content-Type"-    parsePair s =-        let (x, y) = breakDiscard 58 s -- colon-         in (x, S.dropWhile (== 32) y) -- space+                    (wasFound, ()) <- sinkTillBound bound iter seed+                    when wasFound loop+      where+        contDisp = S8.pack "Content-Disposition"+        contType = S8.pack "Content-Type"+        parsePair s =+            let (x, y) = breakDiscard 58 s -- colon+             in (x, S.dropWhile (== 32) y) -- space  data Bound = FoundBound S.ByteString S.ByteString            | NoBound@@ -275,25 +260,32 @@         | S.index b x == S.index bs y = mismatch xs ys         | otherwise = True -sinkTillBound :: S.ByteString-              -> (x -> S.ByteString -> IO x)-              -> x-              -> C.Sink S.ByteString (C.ResourceT IO) (x, Bool)-sinkTillBound bound iter seed0 = C.sinkState-    (id, seed0)-    push-    close'+sinkTillBound' :: S.ByteString+               -> S.ByteString+               -> FileInfo ()+               -> BackEnd y+               -> Pipe S.ByteString S.ByteString o u (ResourceT IO) (Bool, y)+sinkTillBound' bound name fi sink = conduitTillBound bound >+> withUpstream (sinkToPipe $ sink name fi)++conduitTillBound :: Monad m+                 => S.ByteString -- bound+                 -> Pipe S.ByteString S.ByteString S.ByteString u m Bool+conduitTillBound bound =+    go id   where-    close' (front, seed) = do-        seed' <- liftIO $ iter seed $ front S.empty-        return (seed', False)-    push (front, seed) bs' = do+    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-                seed' <- liftIO $ iter seed before'-                return $ C.StateDone (Just after) (seed', True)+                yield before'+                leftover after+                return True             NoBound -> do                 -- don't emit newlines, in case it's part of a bound                 let (toEmit, front') =@@ -301,9 +293,18 @@                             then let (x, y) = S.splitAt (S.length bs - 2) bs                                   in (x, S.append y)                             else (bs, id)-                seed' <- liftIO $ iter seed toEmit-                return $ C.StateProcessing (front', seed')-            PartialBound -> return $ C.StateProcessing (S.append bs, seed)+                yield toEmit+                go front'+            PartialBound -> go $ S.append bs++sinkTillBound :: S.ByteString+              -> (x -> S.ByteString -> IO x)+              -> x+              -> Pipe S.ByteString S.ByteString o u (ResourceT IO) (Bool, x)+sinkTillBound bound iter seed0 =+    conduitTillBound bound >+> withUpstream (CL.foldM iter' seed0)+  where+    iter' a b = liftIO $ iter a b  parseAttrs :: S.ByteString -> [(S.ByteString, S.ByteString)] parseAttrs = map go . S.split 59 -- semicolon

@@ -23,7 +23,7 @@ import Network.Wai.Middleware.MethodOverride import Network.Wai.Middleware.MethodOverridePost import Network.Wai.Middleware.AcceptOverride-import Network.Wai.Middleware.RequestLogger (logCallback)+import Network.Wai.Middleware.RequestLogger import Codec.Compression.GZip (decompress)  import qualified Data.Conduit as C@@ -32,8 +32,11 @@ import Control.Monad.IO.Class (liftIO) import Data.Maybe (fromMaybe) import Network.HTTP.Types (parseSimpleQuery, status200)+import System.Log.FastLogger -specs :: Specs+import qualified Data.IORef as I++specs :: Spec specs = do   describe "Network.Wai.Parse" $ do     it "parseQueryString" caseParseQueryString@@ -469,7 +472,7 @@         assertStatus 200 res      let qs = "?foo=bar&baz=bin"-    flip runSession (debugApp $ getOutput qs) $ do+    flip runSession (debugApp $ getOutput params) $ do         assertStatus 200 =<< request defaultRequest                 { requestMethod = "GET"                 , queryString = map (\(k,v) -> (k, Just v)) params@@ -480,13 +483,25 @@   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)-    postOutput = T.pack $ "POST / Accept: \nStatus: 200 OK"-    -- FIXME getOutput _qs = T.pack $ "GET /location" ++ "\nAccept: \nGET " ++ (show params) -- \nAccept: \n" ++ (show params)-    getOutput _qs = T.pack $ "GET /location?foo=bar&baz=bin Accept: \nStatus: 200 OK"+    postOutput = T.pack $ "POST /\nAccept: \nStatus: 200 OK. /\n"+    getOutput params' = T.pack $ "GET /location\nAccept: \nGET " ++ show params' ++ "\nStatus: 200 OK. /location\n" -    debugApp output' = logCallback (\t -> liftIO $ assertEqual "debug" output t) $ \_req -> do-        return $ responseLBS status200 [ ] ""+    debugApp output' req = do+        iactual <- liftIO $ I.newIORef []+        middleware <- liftIO $ mkRequestLogger def+            { destination = Callback $ \strs -> I.modifyIORef iactual $ (++ strs)+            , outputFormat = Detailed False+            }+        res <- middleware (\_req -> return $ responseLBS status200 [ ] "") req+        actual <- liftIO $ I.readIORef iactual+        liftIO $ assertEqual "debug" output $ logsToBs 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+     {-debugApp = debug $ \req -> do-}         {-return $ responseLBS status200 [ ] ""-}

@@ -2,4 +2,4 @@ import qualified WaiExtraTest  main :: IO ()-main = hspecX WaiExtraTest.specs+main = hspec WaiExtraTest.specs

@@ -1,5 +1,5 @@ Name:                wai-extra-Version:             1.2.0.6+Version:             1.3.0 Synopsis:            Provides some basic WAI handlers and middleware. Description:         The goal here is to provide common features without many dependencies. License:             MIT@@ -22,23 +22,25 @@ Library   Build-Depends:     base                      >= 4 && < 5                    , bytestring                >= 0.9.1.4-                   , wai                       >= 1.2      && < 1.3+                   , wai                       >= 1.3      && < 1.4                    , old-locale                >= 1.0.0.2  && < 1.1                    , time                      >= 1.1.4                    , network                   >= 2.2.1.5  && < 2.4                    , directory                 >= 1.0.1    && < 1.2                    , transformers              >= 0.2.2    && < 0.4                    , blaze-builder             >= 0.2.1.4  && < 0.4-                   , http-types                >= 0.6      && < 0.7+                   , http-types                >= 0.7      && < 0.8                    , text                      >= 0.7      && < 0.12                    , case-insensitive          >= 0.2-                   , data-default              >= 0.3      && < 0.5-                   , fast-logger               >= 0.0.2    && < 0.1-                   , conduit                   >= 0.4      && < 0.5-                   , zlib-conduit              >= 0.4      && < 0.5-                   , blaze-builder-conduit     >= 0.4      && < 0.5+                   , data-default+                   , fast-logger               >= 0.2      && < 0.3+                   , wai-logger                >= 0.2      && < 0.3+                   , conduit                   >= 0.5      && < 0.6+                   , zlib-conduit              >= 0.5      && < 0.6+                   , blaze-builder-conduit     >= 0.5      && < 0.6                    , ansi-terminal                    , resourcet                 >= 0.3      && < 0.4+                   , void                      >= 0.5      && < 0.6                    , stringsearch              >= 0.3      && < 0.4    Exposed-modules:   Network.Wai.Handler.CGI@@ -63,8 +65,8 @@      build-depends:   base                      >= 4        && < 5                    , wai-extra-                   , wai-test-                   , hspec >= 0.8 && < 1.2+                   , wai-test                  >= 1.3+                   , hspec                    , HUnit                     , wai@@ -78,6 +80,8 @@                    , blaze-builder             >= 0.2.1.4  && < 0.4                    , data-default                    , conduit+                   , fast-logger+    ghc-options:       -Wall  source-repository head   type:     git