diff --git a/Network/Wai/Middleware/Debug.hs b/Network/Wai/Middleware/Debug.hs --- a/Network/Wai/Middleware/Debug.hs +++ b/Network/Wai/Middleware/Debug.hs @@ -1,56 +1,17 @@ -{-# LANGUAGE OverloadedStrings #-} module Network.Wai.Middleware.Debug + {-# DEPRECATED "functionality has been moved to the better named Network.Wai.Middleware.RequestLogger. Network.Wai.Middleware.Debug will be removed." #-} ( debug , debugHandle ) where -import Network.Wai (Request(..), Middleware) -import Network.Wai.Parse (parseRequestBody, lbsSink, fileName, Param, File) -import Data.ByteString.Char8 (unpack) -import qualified Data.ByteString as S -import qualified Data.ByteString.Lazy as L -import System.IO (hPutStrLn, stderr) -import Control.Monad.IO.Class (liftIO) -import qualified Data.Text.Lazy as T -import Data.Enumerator (run_, ($$), enumList) -import Data.Enumerator.List (consume) +import Network.Wai.Middleware.RequestLogger (logStdoutDevLT, logHandleDevLT) +import Network.Wai (Middleware) +import qualified Data.Text.Lazy as LT --- | Prints a message to 'stderr' for each request. +-- | Deprecated. Use module Network.Wai.Middleware.RequestLogger debug :: Middleware -debug = debugHandle $ hPutStrLn stderr . T.unpack - --- | Prints a message using the given callback function for each request. --- This is not for serious production use- it is inefficient. --- It immediately consumes a POST body and fills it back in and is otherwise inefficient -debugHandle :: (T.Text -> IO ()) -> Middleware -debugHandle cb app req = do - body <- consume - postParams <- if any (requestMethod req ==) ["GET", "HEAD"] - then return [] - else do postParams <- liftIO $ allPostParams req body - return $ collectPostParams postParams - let getParams = map emptyGetParam $ queryString req - - liftIO $ cb $ T.pack $ concat - [ unpack $ requestMethod req - , " " - , unpack $ rawPathInfo req - , "\n" - , (++) "Accept: " $ maybe "" unpack $ lookup "Accept" $ requestHeaders req - , paramsToStr "GET " getParams - , paramsToStr "POST " postParams - ] - -- we just consumed the body- fill the enumerator back up so it is available again - liftIO $ run_ $ enumList 1 body $$ app req - where - paramsToStr prefix params = if null params then "" else "\n" ++ prefix ++ (show params) - - allPostParams req' body = run_ $ enumList 1 body $$ parseRequestBody lbsSink req' - - emptyGetParam :: (S.ByteString, Maybe S.ByteString) -> (S.ByteString, S.ByteString) - emptyGetParam (k, Just v) = (k,v) - emptyGetParam (k, Nothing) = (k,"") +debug = logStdoutDevLT - collectPostParams :: ([Param], [File L.ByteString]) -> [Param] - collectPostParams (postParams, files) = postParams ++ - (map (\(k,v) -> (k, S.append "FILE: " (fileName v))) files) +-- | Deprecated. Use module Network.Wai.Middleware.RequestLogger +debugHandle :: (LT.Text -> IO ()) -> Middleware +debugHandle = logHandleDevLT diff --git a/Network/Wai/Middleware/RequestLogger.hs b/Network/Wai/Middleware/RequestLogger.hs new file mode 100644 --- /dev/null +++ b/Network/Wai/Middleware/RequestLogger.hs @@ -0,0 +1,103 @@ +{-# LANGUAGE OverloadedStrings #-} +module Network.Wai.Middleware.RequestLogger + ( logStdout + , logHandle + , logStdoutDev + , logHandleDev + , logStdoutDevLT + , logHandleDevLT + ) where + +import System.IO (stdout) +import qualified Data.ByteString as BS +import Data.ByteString.Char8 (pack) +import Control.Monad.IO.Class (liftIO) +import Network.Wai (Request(..), Middleware) +import System.Log.FastLogger +import Network.HTTP.Types as H +import qualified Data.Text.Lazy as LT +import qualified Data.Text.Encoding as TE + +import Network.Wai.Parse (parseRequestBody, lbsSink, fileName, Param, File) +import qualified Data.ByteString.Lazy as LBS +import Data.Enumerator (run_, ($$), enumList) +import Data.Enumerator.List (consume) +import System.IO (hPutStrLn, stderr) + +-- | like @logHandle@, but prints to 'stdout' +logStdout :: Middleware +logStdout = logHandle $ \bs -> hPutLogStr stdout [LB bs] + +-- | like @logHandleDev@, but prints to 'stdout' +logStdoutDev :: Middleware +logStdoutDev = logHandleDev $ \bs -> hPutLogStr stdout [LB bs] + +-- | 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 +-- For something with more useful output, use Network.Wai.Middleware.Debug +logHandle :: (BS.ByteString -> IO ()) -> Middleware +logHandle cb app req = do + liftIO $ cb $ BS.concat + [ requestMethod req + , " " + , rawPathInfo req + , rawQueryString req + , " " + , "Accept: " + , maybe "" toBS $ lookup "Accept" $ requestHeaders req + ] + app req + +toBS :: H.Ascii -> BS.ByteString +toBS = id + +-- | Inefficient, but convenient Development load logger middleware +-- Prints a message to 'stderr' for each request using logHandleDevLT +logStdoutDevLT :: Middleware +logStdoutDevLT = logHandleDevLT $ hPutStrLn stderr . LT.unpack + +-- | logHandleDev, but expects Lazy Text instead of a ByteString +logHandleDevLT :: (LT.Text -> IO ()) -> Middleware +logHandleDevLT cb app req = + logHandleDev (\msg -> cb $ LT.fromStrict $ TE.decodeUtf8 msg) app req + +-- | Prints a message using the given callback function for each request. +-- This is not for serious production use- it is inefficient. +-- It immediately consumes a POST body and fills it back in and is otherwise inefficient +-- For production use use module Network.Wai.Middleware.RequestLogger +logHandleDev :: (BS.ByteString -> IO ()) -> Middleware +logHandleDev cb app req = do + body <- consume + postParams <- if any (requestMethod req ==) ["GET", "HEAD"] + then return [] + else do postParams <- liftIO $ allPostParams req body + return $ collectPostParams postParams + let getParams = map emptyGetParam $ queryString req + + liftIO $ cb $ BS.concat + [ requestMethod req + , " " + , rawPathInfo req + , "\n" + , "Accept: " + , maybe "" id $ lookup "Accept" $ requestHeaders req + , paramsToBS "GET " getParams + , paramsToBS "POST " postParams + ] + -- we just consumed the body- fill the enumerator back up so it is available again + liftIO $ run_ $ enumList 1 body $$ app req + where + paramsToBS prefix params = + if null params then "" + else BS.concat ["\n", prefix, pack (show params)] + + allPostParams req' body = run_ $ enumList 1 body $$ parseRequestBody lbsSink req' + + emptyGetParam :: (BS.ByteString, Maybe BS.ByteString) -> (BS.ByteString, BS.ByteString) + emptyGetParam (k, Just v) = (k,v) + emptyGetParam (k, Nothing) = (k,"") + + collectPostParams :: ([Param], [File LBS.ByteString]) -> [Param] + collectPostParams (postParams, files) = postParams ++ + (map (\(k,v) -> (k, BS.append "FILE: " (fileName v))) files) 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: 0.4.5.2 +Version: 0.4.6 Synopsis: Provides some basic WAI handlers and middleware. Description: The goal here is to provide common features without many dependencies. License: BSD3 @@ -37,12 +37,14 @@ , case-insensitive >= 0.2 , zlib-enum >= 0.2.1 && < 0.3 , data-default >= 0.3 && < 0.4 + , fast-logger >= 0.0.1 Exposed-modules: Network.Wai.Handler.CGI Network.Wai.Middleware.AcceptOverride Network.Wai.Middleware.Autohead Network.Wai.Middleware.CleanPath Network.Wai.Middleware.Debug + Network.Wai.Middleware.RequestLogger Network.Wai.Middleware.Gzip Network.Wai.Middleware.Jsonp Network.Wai.Middleware.MethodOverride