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)
logStdout :: Middleware
logStdout = logHandle $ \bs -> hPutLogStr stdout [LB bs]
logStdoutDev :: Middleware
logStdoutDev = logHandleDev $ \bs -> hPutLogStr stdout [LB bs]
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
logStdoutDevLT :: Middleware
logStdoutDevLT = logHandleDevLT $ hPutStrLn stderr . LT.unpack
logHandleDevLT :: (LT.Text -> IO ()) -> Middleware
logHandleDevLT cb app req =
logHandleDev (\msg -> cb $ LT.fromStrict $ TE.decodeUtf8 msg) app req
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
]
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)