{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Network.Wai.Middleware.RequestLogger
(
logStdout
, logStdoutDev
, mkRequestLogger
, RequestLoggerSettings
, outputFormat
, autoFlush
, destination
, OutputFormat (..)
, OutputFormatter
, Destination (..)
, Callback
, IPAddrSource (..)
) where
import System.IO (Handle, stdout)
import qualified Data.ByteString as BS
import Data.ByteString.Char8 (pack, unpack)
import Control.Monad.IO.Class (liftIO)
import Network.Wai (Request(..), Middleware, responseStatus, Response, responseHeaders)
import System.Log.FastLogger
import Network.HTTP.Types as H
import Data.Maybe (fromMaybe)
import Data.Monoid (mconcat)
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 System.Console.ANSI
import Data.IORef.Lifted
import System.IO.Unsafe
import Control.Monad (unless)
import Network.Wai.Internal (Response (ResponseRaw))
import Data.Default.Class (Default (def))
import Network.Wai.Logger
import Network.Wai.Middleware.RequestLogger.Internal
data OutputFormat = Apache IPAddrSource
| Detailed Bool
| CustomOutputFormat OutputFormatter
type OutputFormatter = ZonedDate -> Request -> Status -> Maybe Integer -> LogStr
data Destination = Handle Handle
| Logger LoggerSet
| Callback Callback
type Callback = LogStr -> IO ()
data RequestLoggerSettings = RequestLoggerSettings
{
outputFormat :: OutputFormat
, autoFlush :: Bool
, destination :: Destination
}
instance Default RequestLoggerSettings where
def = RequestLoggerSettings
{ outputFormat = Detailed True
, autoFlush = True
, destination = Handle stdout
}
mkRequestLogger :: RequestLoggerSettings -> IO Middleware
mkRequestLogger RequestLoggerSettings{..} = do
let (callback, flusher) =
case destination of
Handle h -> (BS.hPutStr h . logToByteString, return ())
Logger l -> (pushLogStr l, flushLogStr l)
Callback c -> (c, return ())
case outputFormat of
Apache ipsrc -> do
getdate <- getDateGetter flusher
apache <- initLogger ipsrc (LogCallback callback (return ())) getdate
return $ apacheMiddleware apache
Detailed useColors -> detailedMiddleware
(\str -> callback str >> flusher)
useColors
CustomOutputFormat formatter -> do
getdate <- getDateGetter flusher
return $ customMiddleware callback getdate formatter
apacheMiddleware :: ApacheLoggerActions -> Middleware
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
sendResponse res
customMiddleware :: Callback -> IO ZonedDate -> OutputFormatter -> Middleware
customMiddleware cb getdate formatter app req sendResponse = app req $ \res -> do
date <- liftIO getdate
liftIO $ cb $ formatter date req (responseStatus res) Nothing
sendResponse res
logStdout :: Middleware
logStdout = unsafePerformIO $ mkRequestLogger def { outputFormat = Apache FromSocket }
logStdoutDev :: Middleware
logStdoutDev = unsafePerformIO $ mkRequestLogger def
colors0 :: [Color]
colors0 = [
Green
, Yellow
, Blue
, Magenta
, Cyan
]
rotateColors :: [Color] -> ([Color], Color)
rotateColors [] = error "Impossible! There must be colors!"
rotateColors (c:cs) = (cs ++ [c], c)
detailedMiddleware :: Callback -> Bool -> IO Middleware
detailedMiddleware cb useColors = do
getAddColor <-
if not useColors then return (return return) else do
icolors <- newIORef colors0
return $ do
color <- liftIO $ atomicModifyIORef icolors rotateColors
return $ ansiColor color
return $ detailedMiddleware' cb getAddColor
ansiColor :: Color -> BS.ByteString -> [BS.ByteString]
ansiColor color bs = [
pack $ setSGRCode [SetColor Foreground Vivid color]
, bs
, pack $ setSGRCode [Reset]
]
detailedMiddleware' :: Callback
-> IO (BS.ByteString -> [BS.ByteString])
-> Middleware
detailedMiddleware' cb getAddColor app req sendResponse = do
let mlen = lookup "content-length" (requestHeaders req) >>= readInt
(req', body) <-
case mlen of
Just len | len <= 2048 -> do
let loop front = do
bs <- requestBody req
if S8.null bs
then return $ front []
else loop $ front . (bs:)
body <- loop id
ichunks <- newIORef body
let rbody = atomicModifyIORef ichunks $ \chunks ->
case chunks of
[] -> ([], S8.empty)
x:y -> (y, x)
let req' = req { requestBody = rbody }
return (req', body)
_ -> return (req, [])
postParams <- if requestMethod req `elem` ["GET", "HEAD"]
then return []
else do postParams <- liftIO $ allPostParams body
return $ collectPostParams postParams
let getParams = map emptyGetParam $ queryString req
addColor <- getAddColor
let accept = fromMaybe "" $ lookup "Accept" $ requestHeaders req
liftIO $ cb $ mconcat $ map toLogStr $ addColor (requestMethod req) ++
[ " "
, rawPathInfo req
, " :: "
, accept
, paramsToBS "GET " getParams
, paramsToBS "POST " postParams
, "\n"
]
app req' $ \rsp -> do
let isRaw =
case rsp of
ResponseRaw{} -> True
_ -> False
unless isRaw $ cb $ mconcat $ map toLogStr $
addColor "Status: " ++ statusBS rsp ++
[ " "
, msgBS rsp
, ". "
, rawPathInfo req
, "\n"
]
sendResponse rsp
where
paramsToBS prefix params =
if null params then ""
else BS.concat ["\n", prefix, pack (show params)]
allPostParams body =
case getRequestBodyType req of
Nothing -> return ([], [])
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)
emptyGetParam (k, Nothing) = (k,"")
collectPostParams :: ([Param], [File LBS.ByteString]) -> [Param]
collectPostParams (postParams, files) = postParams ++
map (\(k,v) -> (k, BS.append "FILE: " (fileName v))) files
readInt bs =
case reads $ unpack bs of
(i, _):_ -> Just (i :: Int)
[] -> Nothing
statusBS :: Response -> [BS.ByteString]
statusBS rsp =
if status >= 400 then ansiColor Red bs else [bs]
where
bs = pack $ show status
status = statusCode $ responseStatus rsp
msgBS :: Response -> BS.ByteString
msgBS = statusMessage . responseStatus