diff --git a/Network/Wai/Handler/CGI.hs b/Network/Wai/Handler/CGI.hs --- a/Network/Wai/Handler/CGI.hs +++ b/Network/Wai/Handler/CGI.hs @@ -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' diff --git a/Network/Wai/Middleware/RequestLogger.hs b/Network/Wai/Middleware/RequestLogger.hs --- a/Network/Wai/Middleware/RequestLogger.hs +++ b/Network/Wai/Middleware/RequestLogger.hs @@ -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)] diff --git a/Network/Wai/Parse.hs b/Network/Wai/Parse.hs --- a/Network/Wai/Parse.hs +++ b/Network/Wai/Parse.hs @@ -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 diff --git a/test/WaiExtraTest.hs b/test/WaiExtraTest.hs --- a/test/WaiExtraTest.hs +++ b/test/WaiExtraTest.hs @@ -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 [ ] ""-} diff --git a/tests.hs b/tests.hs --- a/tests.hs +++ b/tests.hs @@ -2,4 +2,4 @@ import qualified WaiExtraTest main :: IO () -main = hspecX WaiExtraTest.specs +main = hspec WaiExtraTest.specs diff --git a/wai-extra.cabal b/wai-extra.cabal --- a/wai-extra.cabal +++ b/wai-extra.cabal @@ -1,5 +1,5 @@ Name: wai-extra -Version: 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