← Back to branch summary

~ubuntu-branches/ubuntu/saucy/haskell-wai-extra/saucy-proposed

« back to all changes in this revision

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

  • Committer: Package Import Robot
  • Author(s): Clint Adams
  • Date: 2012-03-09 14:12:00 UTC
  • mfrom: (2.1.6 sid)
  • Revision ID: package-import@ubuntu.com-20120309141200-pwnlh5b9fme9ps47
Tags: 1.1.0.1-2
http://bugs.debian.org/663242
Add missing build dependencies on ansi-terminal.  closes: #663242.

Show diffs side-by-side

added added

removed removed

Lines of Context:
Network/Wai/Middleware/RequestLogger.hs
 
1
{-# LANGUAGE OverloadedStrings #-}
 
2
module Network.Wai.Middleware.RequestLogger
 
3
    ( logStdout
 
4
    , logCallback
 
5
    , logStdoutDev
 
6
    , logCallbackDev
 
7
    -- * Deprecated
 
8
    , logHandle
 
9
    , logHandleDev
 
10
    ) where
 
11
 
 
12
import System.IO (stdout, hFlush)
 
13
import qualified Data.ByteString as BS
 
14
import Data.ByteString.Char8 (pack, unpack)
 
15
import Control.Monad.IO.Class (liftIO)
 
16
import Network.Wai (Request(..), Middleware, responseStatus)
 
17
import System.Log.FastLogger
 
18
import Network.HTTP.Types as H
 
19
 
 
20
import Network.Wai.Parse (sinkRequestBody, lbsBackEnd, fileName, Param, File, getRequestBodyType)
 
21
import qualified Data.ByteString.Lazy as LBS
 
22
 
 
23
import qualified Data.Conduit as C
 
24
import qualified Data.Conduit.List as CL
 
25
 
 
26
import System.Console.ANSI
 
27
import Data.IORef
 
28
import System.IO.Unsafe
 
29
 
 
30
logHandle :: (BS.ByteString -> IO ()) -> Middleware
 
31
logHandle = logCallback
 
32
{-# DEPRECATED logHandle "Please use logCallback instead." #-}
 
33
logHandleDev :: (BS.ByteString -> IO ()) -> Middleware
 
34
logHandleDev = logCallbackDev
 
35
{-# DEPRECATED logHandleDev "Please use logCallbackDev instead." #-}
 
36
 
 
37
-- | Production request logger middleware.
 
38
-- Implemented on top of "logCallback", but prints to 'stdout'
 
39
logStdout :: Middleware
 
40
logStdout = logHandle $ \bs -> hPutLogStr stdout [LB bs]
 
41
 
 
42
-- | Development request logger middleware.
 
43
-- Implemented on top of "logCallbackDev", but prints to 'stdout'
 
44
--
 
45
-- Flushes 'stdout' on each request, which would be inefficient in production use.
 
46
-- Use "logStdout" in production.
 
47
logStdoutDev :: Middleware
 
48
logStdoutDev = logHandleDev $ \bs -> hPutLogStr stdout [LB bs] >> hFlush stdout
 
49
 
 
50
-- | Prints a message using the given callback function for each request.
 
51
-- Designed for fast production use at the expense of convenience.
 
52
-- In particular, no POST parameter information is currently given
 
53
--
 
54
-- This is lower-level - use "logStdout" unless you need this greater control
 
55
logCallback :: (BS.ByteString -> IO ()) -- ^ A function that logs the ByteString log message.
 
56
            -> Middleware
 
57
logCallback cb app req = do
 
58
    liftIO $ cb $ BS.concat
 
59
        [ requestMethod req
 
60
        , " "
 
61
        , rawPathInfo req
 
62
        , rawQueryString req
 
63
        , " "
 
64
        , "Accept: "
 
65
        , maybe "" toBS $ lookup "Accept" $ requestHeaders req
 
66
        , "\n"
 
67
        ]
 
68
    app req
 
69
 
 
70
toBS :: H.Ascii -> BS.ByteString
 
71
toBS = id
 
72
 
 
73
-- no black or white which are expected to be existing terminal colors.
 
74
colors :: IORef [Color]
 
75
colors = unsafePerformIO $ newIORef $ [
 
76
    Red 
 
77
  , Green 
 
78
  , Yellow 
 
79
  , Blue 
 
80
  , Magenta 
 
81
  , Cyan
 
82
  ]
 
83
 
 
84
rotateColors :: [Color] -> ([Color], Color)
 
85
rotateColors [] = error "Impossible! There must be colors!"
 
86
rotateColors (c:cs) = (cs ++ [c], c)
 
87
 
 
88
-- | Prints a message using the given callback function for each request.
 
89
-- This is not for serious production use- it is inefficient.
 
90
-- It immediately consumes a POST body and fills it back in and is otherwise inefficient
 
91
--
 
92
-- Note that it logs the request immediately when it is received.
 
93
-- This meanst that you can accurately see the interleaving of requests.
 
94
-- And if the app crashes you have still logged the request.
 
95
-- However, if you are simulating 10 simultaneous users you may find this confusing.
 
96
-- The request and response are connected by color on Unix and also by the request path.
 
97
--
 
98
-- This is lower-level - use "logStdoutDev" unless you need greater control.
 
99
--
 
100
-- Example ouput:
 
101
--
 
102
-- GET search
 
103
-- Accept: text/html,application/xhtml+xml,application/xml;q=0.9,*/*;q=0.8
 
104
--
 
105
-- Status: 200 OK. search
 
106
-- 
 
107
-- GET static/css/normalize.css
 
108
-- Accept: text/css,*/*;q=0.1
 
109
-- GET [("LXwioiBG","")]
 
110
--
 
111
-- Status: 304 Not Modified. static/css/normalize.css
 
112
logCallbackDev :: (BS.ByteString -> IO ()) -- ^ A function that logs the ByteString log message.
 
113
               -> Middleware
 
114
logCallbackDev cb app req = do
 
115
    let mlen = lookup "content-length" (requestHeaders req) >>= readInt
 
116
    (req', body) <-
 
117
        case mlen of
 
118
            -- log the request body if it is small
 
119
            Just len | len <= 2048 -> do
 
120
                 body <- requestBody req C.$$ CL.consume
 
121
                 -- logging the body here consumes it, so fill it back up
 
122
                 -- obviously not efficient, but this is the development logger
 
123
                 let req' = req { requestBody = CL.sourceList body }
 
124
                 return (req', body)
 
125
            _ -> return (req, [])
 
126
 
 
127
    postParams <- if any (requestMethod req ==) ["GET", "HEAD"]
 
128
      then return []
 
129
      else do postParams <- liftIO $ allPostParams body
 
130
              return $ collectPostParams postParams
 
131
 
 
132
    let getParams = map emptyGetParam $ queryString req
 
133
 
 
134
    color <- liftIO $ atomicModifyIORef colors rotateColors
 
135
 
 
136
    -- log the request immediately.
 
137
    liftIO $ cb $ BS.concat $ ansiColor color (requestMethod req) ++
 
138
        [ " "
 
139
        , rawPathInfo req
 
140
        , "\n"
 
141
        , "Accept: "
 
142
        , maybe "" id $ lookup "Accept" $ requestHeaders req
 
143
        , paramsToBS  "GET " getParams
 
144
        , paramsToBS "POST " postParams
 
145
        , "\n"
 
146
        ]
 
147
 
 
148
    rsp <- app req'
 
149
 
 
150
    -- log the status of the response
 
151
    -- this is color coordinated with the request logging
 
152
    -- also includes the request path to connect it to the request
 
153
    liftIO $ cb $ BS.concat $ ansiColor color "Status: " ++ [
 
154
          sCode rsp
 
155
        , " "
 
156
        , msg rsp
 
157
        , ". "
 
158
        , rawPathInfo req -- if you need help matching the 2 logging statements
 
159
        , "\n"
 
160
      ]
 
161
    return rsp
 
162
  where
 
163
    ansiColor color bs = [
 
164
        pack $ setSGRCode [SetColor Foreground Vivid color]
 
165
      , bs
 
166
      , pack $ setSGRCode [Reset]
 
167
      ]
 
168
    sCode = pack . show . statusCode . responseStatus
 
169
    msg = statusMessage . responseStatus
 
170
 
 
171
    paramsToBS prefix params =
 
172
      if null params then ""
 
173
        else BS.concat ["\n", prefix, pack (show params)]
 
174
 
 
175
    allPostParams body =
 
176
        case getRequestBodyType req of
 
177
            Nothing -> return ([], [])
 
178
            Just rbt -> C.runResourceT $ CL.sourceList body C.$$ sinkRequestBody lbsBackEnd rbt
 
179
 
 
180
    emptyGetParam :: (BS.ByteString, Maybe BS.ByteString) -> (BS.ByteString, BS.ByteString)
 
181
    emptyGetParam (k, Just v) = (k,v)
 
182
    emptyGetParam (k, Nothing) = (k,"")
 
183
 
 
184
    collectPostParams :: ([Param], [File LBS.ByteString]) -> [Param]
 
185
    collectPostParams (postParams, files) = postParams ++
 
186
      (map (\(k,v) -> (k, BS.append "FILE: " (fileName v))) files)
 
187
 
 
188
    readInt bs =
 
189
        case reads $ unpack bs of
 
190
            (i, _):_ -> Just (i :: Int)
 
191
            [] -> Nothing