← Back to branch summary

~ubuntu-branches/ubuntu/raring/haskell-wai-extra/raring

« back to all changes in this revision

Viewing changes to Network/Wai/Middleware/RequestLogger.hs

  • Committer: Package Import Robot
  • Author(s): Joachim Breitner
  • Date: 2013-02-13 17:55:10 UTC
  • mfrom: (2.1.11 experimental)
  • Revision ID: package-import@ubuntu.com-20130213175510-ty5pd3iftubyyv9k
Tags: 1.3.2.1-2
Remove upper bound on hspec

Show diffs side-by-side

added added

removed removed

Lines of Context:
Network/Wai/Middleware/RequestLogger.hs
1
1
{-# LANGUAGE OverloadedStrings #-}
 
2
{-# LANGUAGE RecordWildCards #-}
 
3
{-# LANGUAGE CPP #-}
2
4
module Network.Wai.Middleware.RequestLogger
3
 
    ( logStdout
4
 
    , logCallback
 
5
    ( -- * Basic stdout logging
 
6
      logStdout
5
7
    , logStdoutDev
6
 
    , logCallbackDev
7
 
    -- * Deprecated
8
 
    , logHandle
9
 
    , logHandleDev
 
8
      -- * Create more versions
 
9
    , mkRequestLogger
 
10
    , RequestLoggerSettings
 
11
    , outputFormat
 
12
    , autoFlush
 
13
    , destination
 
14
    , OutputFormat (..)
 
15
    , OutputFormatter
 
16
    , Destination (..)
 
17
    , Callback
 
18
    , IPAddrSource (..)
10
19
    ) where
11
20
 
12
 
import System.IO (stdout, hFlush)
 
21
import System.IO (Handle, stdout)
13
22
import qualified Data.ByteString as BS
14
23
import Data.ByteString.Char8 (pack, unpack)
15
24
import Control.Monad.IO.Class (liftIO)
28
37
import Data.IORef
29
38
import System.IO.Unsafe
30
39
 
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." #-}
 
40
import Data.Default (Default (def))
 
41
import Network.Wai.Logger.Format (apacheFormat, IPAddrSource (..))
 
42
#if MIN_VERSION_fast_logger(0,3,0)
 
43
import System.Date.Cache (ondemandDateCacher)
 
44
#else
 
45
import System.Log.FastLogger.Date (getDate, dateInit, ZonedDate)
 
46
#endif
 
47
 
 
48
data OutputFormat = Apache IPAddrSource
 
49
                  | Detailed Bool -- ^ use colors?
 
50
                  | CustomOutputFormat OutputFormatter
 
51
 
 
52
type OutputFormatter = ZonedDate -> Request -> Status -> Maybe Integer -> [LogStr]
 
53
 
 
54
data Destination = Handle Handle
 
55
                 | Logger Logger
 
56
                 | Callback Callback
 
57
 
 
58
type Callback = [LogStr] -> IO ()
 
59
 
 
60
data RequestLoggerSettings = RequestLoggerSettings
 
61
    {
 
62
      -- | Default value: @Detailed@ @True@.
 
63
      outputFormat :: OutputFormat
 
64
      -- | Only applies when using the @Handle@ constructor for @destination@.
 
65
      --
 
66
      -- Default value: @True@.
 
67
    , autoFlush :: Bool
 
68
      -- | Default: @Handle@ @stdout@.
 
69
    , destination :: Destination
 
70
    }
 
71
 
 
72
instance Default RequestLoggerSettings where
 
73
    def = RequestLoggerSettings
 
74
        { outputFormat = Detailed True
 
75
        , autoFlush = True
 
76
        , destination = Handle stdout
 
77
        }
 
78
 
 
79
mkRequestLogger :: RequestLoggerSettings -> IO Middleware
 
80
mkRequestLogger RequestLoggerSettings{..} = do
 
81
    (callback, mgetdate) <-
 
82
        case destination of
 
83
            Handle h -> fmap fromLogger $ mkLogger autoFlush h
 
84
            Logger l -> return $ fromLogger l
 
85
            Callback c -> return (c, Nothing)
 
86
    case outputFormat of
 
87
        Apache ipsrc -> do
 
88
            getdate <- dateHelper mgetdate
 
89
            return $ apacheMiddleware callback ipsrc getdate
 
90
        Detailed useColors -> detailedMiddleware callback useColors
 
91
        CustomOutputFormat formatter -> do
 
92
            getdate <- dateHelper mgetdate
 
93
            return $ customMiddleware callback getdate formatter
 
94
  where
 
95
    fromLogger l = (loggerPutStr l, Just $ loggerDate l)
 
96
    dateHelper mgetdate = do
 
97
        case mgetdate of
 
98
            Just x -> return x
 
99
#if MIN_VERSION_fast_logger(0, 3, 0)
 
100
            Nothing -> do
 
101
                (getter,_) <- ondemandDateCacher zonedDateCacheConf
 
102
                return getter
 
103
#else
 
104
            Nothing -> fmap getDate dateInit
 
105
#endif
 
106
 
 
107
apacheMiddleware :: Callback -> IPAddrSource -> IO ZonedDate -> Middleware
 
108
apacheMiddleware cb ipsrc getdate = customMiddleware cb getdate $ apacheFormat ipsrc
 
109
 
 
110
customMiddleware :: Callback -> IO ZonedDate -> OutputFormatter -> Middleware
 
111
customMiddleware cb getdate formatter app req = do
 
112
    res <- app req
 
113
    date <- liftIO getdate
 
114
    -- We use Nothing for the response size since we generally don't know it
 
115
    liftIO $ cb $ formatter date req (responseStatus res) Nothing
 
116
    return res
37
117
 
38
118
-- | Production request logger middleware.
39
119
-- Implemented on top of "logCallback", but prints to 'stdout'
40
120
logStdout :: Middleware
41
 
logStdout = logCallback $ \bs -> hPutLogStr stdout [LB bs]
 
121
logStdout = unsafePerformIO $ mkRequestLogger def { outputFormat = Apache FromSocket }
42
122
 
43
123
-- | Development request logger middleware.
44
124
-- Implemented on top of "logCallbackDev", but prints to 'stdout'
46
126
-- Flushes 'stdout' on each request, which would be inefficient in production use.
47
127
-- Use "logStdout" in production.
48
128
logStdoutDev :: Middleware
49
 
logStdoutDev = logCallbackDev $ \bs -> hPutLogStr stdout [LB bs] >> hFlush stdout
50
 
 
51
 
--
52
 
logCallback :: (BS.ByteString -> IO ()) -- ^ A function that logs the ByteString log message.
53
 
            -> Middleware
54
 
logCallback cb app req = do
55
 
    rsp <- app req
56
 
    liftIO $ cb $ BS.concat
57
 
        [ requestMethod req
58
 
        , " "
59
 
        , rawPathInfo req
60
 
        , rawQueryString req
61
 
        , " "
62
 
        , "Accept: "
63
 
        , maybe "" toBS $ lookup "Accept" $ requestHeaders req
64
 
        , "\n"
65
 
        , "Status: "
66
 
        , statusBS rsp
67
 
        , " "
68
 
        , msgBS rsp
69
 
        ]
70
 
    return rsp
71
 
 
72
 
toBS :: H.Ascii -> BS.ByteString
73
 
toBS = id
 
129
logStdoutDev = unsafePerformIO $ mkRequestLogger def
74
130
 
75
131
-- no black or white which are expected to be existing terminal colors.
76
 
colors :: IORef [Color]
77
 
colors = unsafePerformIO $ newIORef [
 
132
colors0 :: [Color]
 
133
colors0 = [
78
134
    Red 
79
135
  , Green 
80
136
  , Yellow 
115
167
-- > GET [("LXwioiBG","")]
116
168
-- >
117
169
-- > 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
 
170
 
 
171
detailedMiddleware :: Callback -> Bool -> IO Middleware
 
172
detailedMiddleware cb useColors = do
 
173
    getAddColor <-
 
174
        if useColors
 
175
            then do
 
176
                icolors <- newIORef colors0
 
177
                return $ do
 
178
                    color <- liftIO $ atomicModifyIORef icolors rotateColors
 
179
                    return $ ansiColor color
 
180
            else return (return return)
 
181
    return $ detailedMiddleware' cb getAddColor
 
182
  where
 
183
    ansiColor color bs = [
 
184
        pack $ setSGRCode [SetColor Foreground Vivid color]
 
185
      , bs
 
186
      , pack $ setSGRCode [Reset]
 
187
      ]
 
188
 
 
189
detailedMiddleware' :: Callback
 
190
                    -> (C.ResourceT IO (BS.ByteString -> [BS.ByteString]))
 
191
                    -> Middleware
 
192
detailedMiddleware' cb getAddColor app req = do
121
193
    let mlen = lookup "content-length" (requestHeaders req) >>= readInt
122
194
    (req', body) <-
123
195
        case mlen of
137
209
 
138
210
    let getParams = map emptyGetParam $ queryString req
139
211
 
140
 
    color <- liftIO $ atomicModifyIORef colors rotateColors
 
212
    addColor <- getAddColor
141
213
 
142
214
    -- log the request immediately.
143
 
    liftIO $ cb $ BS.concat $ ansiColor color (requestMethod req) ++
 
215
    liftIO $ cb $ map LB $ addColor (requestMethod req) ++
144
216
        [ " "
145
217
        , rawPathInfo req
146
218
        , "\n"
156
228
    -- log the status of the response
157
229
    -- this is color coordinated with the request logging
158
230
    -- also includes the request path to connect it to the request
159
 
    liftIO $ cb $ BS.concat $ ansiColor color "Status: " ++ [
 
231
    liftIO $ cb $ map LB $ addColor "Status: " ++ [
160
232
          statusBS rsp
161
233
        , " "
162
234
        , msgBS rsp
166
238
      ]
167
239
    return rsp
168
240
  where
169
 
    ansiColor color bs = [
170
 
        pack $ setSGRCode [SetColor Foreground Vivid color]
171
 
      , bs
172
 
      , pack $ setSGRCode [Reset]
173
 
      ]
174
 
 
175
241
    paramsToBS prefix params =
176
242
      if null params then ""
177
243
        else BS.concat ["\n", prefix, pack (show params)]