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)
import System.Log.FastLogger
import Network.HTTP.Types as H
import Data.Maybe (fromMaybe)
import Network.Wai.Parse (sinkRequestBody, lbsBackEnd, fileName, Param, File, getRequestBodyType)
import qualified Data.ByteString.Lazy as LBS
import qualified Data.Conduit as C
import qualified Data.Conduit.List as CL
import System.Console.ANSI
import Data.IORef
import System.IO.Unsafe
import Data.Default (Default (def))
import Network.Wai.Logger.Format (apacheFormat, IPAddrSource (..))
#if MIN_VERSION_fast_logger(0,3,0)
import System.Date.Cache (ondemandDateCacher)
#else
import System.Log.FastLogger.Date (getDate, dateInit, ZonedDate)
#endif
data OutputFormat = Apache IPAddrSource
| Detailed Bool
| CustomOutputFormat OutputFormatter
type OutputFormatter = ZonedDate -> Request -> Status -> Maybe Integer -> [LogStr]
data Destination = Handle Handle
| Logger Logger
| 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
(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 <- dateHelper mgetdate
return $ apacheMiddleware callback ipsrc getdate
Detailed useColors -> detailedMiddleware callback useColors
CustomOutputFormat formatter -> do
getdate <- dateHelper mgetdate
return $ customMiddleware callback getdate formatter
where
fromLogger l = (loggerPutStr l, Just $ loggerDate l)
dateHelper mgetdate = do
case mgetdate of
Just x -> return x
#if MIN_VERSION_fast_logger(0, 3, 0)
Nothing -> do
(getter,_) <- ondemandDateCacher zonedDateCacheConf
return getter
#else
Nothing -> fmap getDate dateInit
#endif
apacheMiddleware :: Callback -> IPAddrSource -> IO ZonedDate -> Middleware
apacheMiddleware cb ipsrc getdate = customMiddleware cb getdate $ apacheFormat ipsrc
customMiddleware :: Callback -> IO ZonedDate -> OutputFormatter -> Middleware
customMiddleware cb getdate formatter app req = do
res <- app req
date <- liftIO getdate
liftIO $ cb $ formatter date req (responseStatus res) Nothing
return res
logStdout :: Middleware
logStdout = unsafePerformIO $ mkRequestLogger def { outputFormat = Apache FromSocket }
logStdoutDev :: Middleware
logStdoutDev = unsafePerformIO $ mkRequestLogger def
colors0 :: [Color]
colors0 = [
Red
, 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 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
Just len | len <= 2048 -> do
body <- requestBody req C.$$ CL.consume
let req' = req { requestBody = CL.sourceList body }
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
liftIO $ cb $ map LB $ addColor (requestMethod req) ++
[ " "
, rawPathInfo req
, "\n"
, "Accept: "
, fromMaybe "" $ lookup "Accept" $ requestHeaders req
, paramsToBS "GET " getParams
, paramsToBS "POST " postParams
, "\n"
]
rsp <- app req'
liftIO $ cb $ map LB $ addColor "Status: " ++ [
statusBS rsp
, " "
, msgBS rsp
, ". "
, rawPathInfo req
, "\n"
]
return 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 -> C.runResourceT $ CL.sourceList body C.$$ sinkRequestBody lbsBackEnd rbt
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 = pack . show . statusCode . responseStatus
msgBS :: Response -> BS.ByteString
msgBS = statusMessage . responseStatus