@@ -1,15 +1,22 @@
11{-# LANGUAGE OverloadedStrings #-}
2+{-# LANGUAGE RecordWildCards #-}
23module Network.Wai.Middleware.RequestLogger
3− ( logStdout
4− , logCallback
4+ ( -- * Basic stdout logging
5+ logStdout
56 , logStdoutDev
6− , logCallbackDev
7− -- * Deprecated
8− , logHandle
9− , logHandleDev
7+ -- * Create more versions
8+ , mkRequestLogger
9+ , RequestLoggerSettings
10+ , outputFormat
11+ , autoFlush
12+ , destination
13+ , OutputFormat (..)
14+ , Destination (..)
15+ , Callback
16+ , IPAddrSource (..)
1017 ) where
1118
12−import System.IO (stdout, hFlush)
19+import System.IO (Handle, stdout)
1320import qualified Data.ByteString as BS
1421import Data.ByteString.Char8 (pack, unpack)
1522import Control.Monad.IO.Class (liftIO)
@@ -28,17 +35,66 @@ import System.Console.ANSI
2835import Data.IORef
2936import System.IO.Unsafe
3037
31−logHandle :: (BS.ByteString -> IO ()) -> Middleware
32−logHandle = logCallback
33−{-# DEPRECATED logHandle "Please use logCallback instead." #-}
34−logHandleDev :: (BS.ByteString -> IO ()) -> Middleware
35−logHandleDev = logCallbackDev
36−{-# DEPRECATED logHandleDev "Please use logCallbackDev instead." #-}
38+import Data.Default (Default (def))
39+import Network.Wai.Logger.Format (apacheFormat, IPAddrSource (..))
40+import System.Log.FastLogger.Date (DateRef, getDate, dateInit)
41+
42+data OutputFormat = Apache IPAddrSource
43+ | Detailed Bool -- ^ use colors?
44+
45+data Destination = Handle Handle
46+ | Logger Logger
47+ | Callback Callback
48+
49+type Callback = [LogStr] -> IO ()
50+
51+data RequestLoggerSettings = RequestLoggerSettings
52+ {
53+ -- | Default value: @Detailed@ @True@.
54+ outputFormat :: OutputFormat
55+ -- | Only applies when using the @Handle@ constructor for @destination@.
56+ --
57+ -- Default value: @True@.
58+ , autoFlush :: Bool
59+ -- | Default: @Handle@ @stdout@.
60+ , destination :: Destination
61+ }
62+
63+instance Default RequestLoggerSettings where
64+ def = RequestLoggerSettings
65+ { outputFormat = Detailed True
66+ , autoFlush = True
67+ , destination = Handle stdout
68+ }
69+
70+mkRequestLogger :: RequestLoggerSettings -> IO Middleware
71+mkRequestLogger RequestLoggerSettings{..} = do
72+ (callback, dateref) <-
73+ case destination of
74+ Handle h -> fmap fromLogger $ mkLogger autoFlush h
75+ Logger l -> return $ fromLogger l
76+ Callback c -> do
77+ dateref <- dateInit
78+ return (c, dateref)
79+ case outputFormat of
80+ Apache ipsrc -> return $ apacheMiddleware callback ipsrc dateref
81+ Detailed useColors -> detailedMiddleware callback useColors
82+ where
83+ fromLogger :: Logger -> (Callback, DateRef)
84+ fromLogger l = (loggerPutStr l, loggerDateRef l)
85+
86+apacheMiddleware :: Callback -> IPAddrSource -> DateRef -> Middleware
87+apacheMiddleware cb ipsrc dateref app req = do
88+ res <- app req
89+ date <- liftIO $ getDate dateref
90+ -- We use Nothing for the response size since we generally don't know it
91+ liftIO $ cb $ apacheFormat ipsrc date req (responseStatus res) Nothing
92+ return res
3793
3894-- | Production request logger middleware.
3995-- Implemented on top of "logCallback", but prints to 'stdout'
4096logStdout :: Middleware
41−logStdout = logCallback $ \bs -> hPutLogStr stdout [LB bs]
97+logStdout = unsafePerformIO $ mkRequestLogger def { outputFormat = Apache FromSocket }
4298
4399-- | Development request logger middleware.
44100-- Implemented on top of "logCallbackDev", but prints to 'stdout'
@@ -46,39 +102,11 @@ logStdout = logCallback $ \bs -> hPutLogStr stdout [LB bs]
46102-- Flushes 'stdout' on each request, which would be inefficient in production use.
47103-- Use "logStdout" in production.
48104logStdoutDev :: Middleware
49−logStdoutDev = logCallbackDev $ \bs -> hPutLogStr stdout [LB bs] >> hFlush stdout
50−
51−-- | Prints a message using the given callback function for each request.
52−-- Designed for fast production use at the expense of convenience.
53−-- In particular, no POST parameter information is currently given
54−--
55−-- This is lower-level - use "logStdout" unless you need this greater control
56−logCallback :: (BS.ByteString -> IO ()) -- ^ A function that logs the ByteString log message.
57− -> Middleware
58−logCallback cb app req = do
59− rsp <- app req
60− liftIO $ cb $ BS.concat
61− [ requestMethod req
62− , " "
63− , rawPathInfo req
64− , rawQueryString req
65− , " "
66− , "Accept: "
67− , maybe "" toBS $ lookup "Accept" $ requestHeaders req
68− , "\n"
69− , "Status: "
70− , statusBS rsp
71− , " "
72− , msgBS rsp
73− ]
74− return rsp
75−
76−toBS :: H.Ascii -> BS.ByteString
77−toBS = id
105+logStdoutDev = unsafePerformIO $ mkRequestLogger def
78106
79107-- no black or white which are expected to be existing terminal colors.
80−colors :: IORef [Color]
81−colors = unsafePerformIO $ newIORef [
108+colors0 :: [Color]
109+colors0 = [
82110 Red
83111 , Green
84112 , Yellow
@@ -115,9 +143,29 @@ rotateColors (c:cs) = (cs ++ [c], c)
115143-- > GET [("LXwioiBG","")]
116144-- >
117145-- > Status: 304 Not Modified. static/css/normalize.css
118−logCallbackDev :: (BS.ByteString -> IO ()) -- ^ A function that logs the ByteString log message.
119− -> Middleware
120−logCallbackDev cb app req = do
146+
147+detailedMiddleware :: Callback -> Bool -> IO Middleware
148+detailedMiddleware cb useColors = do
149+ getAddColor <-
150+ if useColors
151+ then do
152+ icolors <- newIORef colors0
153+ return $ do
154+ color <- liftIO $ atomicModifyIORef icolors rotateColors
155+ return $ ansiColor color
156+ else return (return return)
157+ return $ detailedMiddleware' cb getAddColor
158+ where
159+ ansiColor color bs = [
160+ pack $ setSGRCode [SetColor Foreground Vivid color]
161+ , bs
162+ , pack $ setSGRCode [Reset]
163+ ]
164+
165+detailedMiddleware' :: Callback
166+ -> (C.ResourceT IO (BS.ByteString -> [BS.ByteString]))
167+ -> Middleware
168+detailedMiddleware' cb getAddColor app req = do
121169 let mlen = lookup "content-length" (requestHeaders req) >>= readInt
122170 (req', body) <-
123171 case mlen of
@@ -137,10 +185,10 @@ logCallbackDev cb app req = do
137185
138186 let getParams = map emptyGetParam $ queryString req
139187
140− color <- liftIO $ atomicModifyIORef colors rotateColors
188+ addColor <- getAddColor
141189
142190 -- log the request immediately.
143− liftIO $ cb $ BS.concat $ ansiColor color (requestMethod req) ++
191+ liftIO $ cb $ map LB $ addColor (requestMethod req) ++
144192 [ " "
145193 , rawPathInfo req
146194 , "\n"
@@ -156,7 +204,7 @@ logCallbackDev cb app req = do
156204 -- log the status of the response
157205 -- this is color coordinated with the request logging
158206 -- also includes the request path to connect it to the request
159− liftIO $ cb $ BS.concat $ ansiColor color "Status: " ++ [
207+ liftIO $ cb $ map LB $ addColor "Status: " ++ [
160208 statusBS rsp
161209 , " "
162210 , msgBS rsp
@@ -166,12 +214,6 @@ logCallbackDev cb app req = do
166214 ]
167215 return rsp
168216 where
169− ansiColor color bs = [
170− pack $ setSGRCode [SetColor Foreground Vivid color]
171− , bs
172− , pack $ setSGRCode [Reset]
173− ]
174−
175217 paramsToBS prefix params =
176218 if null params then ""
177219 else BS.concat ["\n", prefix, pack (show params)]