@@ -13,9 +13,10 @@ import System.IO (stdout, hFlush)
13import qualified Data.ByteString as BS
13import qualified Data.ByteString as BS
14import Data.ByteString.Char8 (pack, unpack)
14import Data.ByteString.Char8 (pack, unpack)
15import Control.Monad.IO.Class (liftIO)
15import Control.Monad.IO.Class (liftIO)
16−import Network.Wai (Request(..), Middleware, responseStatus)
16+import Network.Wai (Request(..), Middleware, responseStatus, Response)
17import System.Log.FastLogger
17import System.Log.FastLogger
18import Network.HTTP.Types as H
18import Network.HTTP.Types as H
19+import Data.Maybe (fromMaybe)
20import Network.Wai.Parse (sinkRequestBody, lbsBackEnd, fileName, Param, File, getRequestBodyType)
21import Network.Wai.Parse (sinkRequestBody, lbsBackEnd, fileName, Param, File, getRequestBodyType)
21import qualified Data.ByteString.Lazy as LBS
22import qualified Data.ByteString.Lazy as LBS
@@ -37,7 +38,7 @@ logHandleDev = logCallbackDev
37-- | Production request logger middleware.
38-- | Production request logger middleware.
38-- Implemented on top of "logCallback", but prints to 'stdout'
39-- Implemented on top of "logCallback", but prints to 'stdout'
39logStdout :: Middleware
40logStdout :: Middleware
40−logStdout = logHandle $ \bs -> hPutLogStr stdout [LB bs]
41+logStdout = logCallback $ \bs -> hPutLogStr stdout [LB bs]
42-- | Development request logger middleware.
43-- | Development request logger middleware.
43-- Implemented on top of "logCallbackDev", but prints to 'stdout'
44-- Implemented on top of "logCallbackDev", but prints to 'stdout'
@@ -45,7 +46,7 @@ logStdout = logHandle $ \bs -> hPutLogStr stdout [LB bs]
45-- Flushes 'stdout' on each request, which would be inefficient in production use.
46-- Flushes 'stdout' on each request, which would be inefficient in production use.
46-- Use "logStdout" in production.
47-- Use "logStdout" in production.
47logStdoutDev :: Middleware
48logStdoutDev :: Middleware
48−logStdoutDev = logHandleDev $ \bs -> hPutLogStr stdout [LB bs] >> hFlush stdout
49+logStdoutDev = logCallbackDev $ \bs -> hPutLogStr stdout [LB bs] >> hFlush stdout
50-- | Prints a message using the given callback function for each request.
51-- | Prints a message using the given callback function for each request.
51-- Designed for fast production use at the expense of convenience.
52-- Designed for fast production use at the expense of convenience.
@@ -55,6 +56,7 @@ logStdoutDev = logHandleDev $ \bs -> hPutLogStr stdout [LB bs] >> hFlush stdout
55logCallback :: (BS.ByteString -> IO ()) -- ^ A function that logs the ByteString log message.
56logCallback :: (BS.ByteString -> IO ()) -- ^ A function that logs the ByteString log message.
56 -> Middleware
57 -> Middleware
57logCallback cb app req = do
58logCallback cb app req = do
58 liftIO $ cb $ BS.concat
60 liftIO $ cb $ BS.concat
59 [ requestMethod req
61 [ requestMethod req
@@ -64,15 +66,19 @@ logCallback cb app req = do
64 , "Accept: "
66 , "Accept: "
65 , maybe "" toBS $ lookup "Accept" $ requestHeaders req
67 , maybe "" toBS $ lookup "Accept" $ requestHeaders req
68− app req
74+ return rsp
70toBS :: H.Ascii -> BS.ByteString
76toBS :: H.Ascii -> BS.ByteString
73-- no black or white which are expected to be existing terminal colors.
79-- no black or white which are expected to be existing terminal colors.
74colors :: IORef [Color]
80colors :: IORef [Color]
75−colors = unsafePerformIO $ newIORef $ [
81+colors = unsafePerformIO $ newIORef [
@@ -124,7 +130,7 @@ logCallbackDev cb app req = do
124 return (req', body)
130 return (req', body)
125 _ -> return (req, [])
131 _ -> return (req, [])
127− postParams <- if any (requestMethod req ==) ["GET", "HEAD"]
133+ postParams <- if requestMethod req `elem` ["GET", "HEAD"]
128 then return []
134 then return []
129 else do postParams <- liftIO $ allPostParams body
135 else do postParams <- liftIO $ allPostParams body
130 return $ collectPostParams postParams
136 return $ collectPostParams postParams
@@ -139,7 +145,7 @@ logCallbackDev cb app req = do
139 , rawPathInfo req
145 , rawPathInfo req
141 , "Accept: "
147 , "Accept: "
142− , maybe "" id $ lookup "Accept" $ requestHeaders req
148+ , fromMaybe "" $ lookup "Accept" $ requestHeaders req
143 , paramsToBS "GET " getParams
149 , paramsToBS "GET " getParams
144 , paramsToBS "POST " postParams
150 , paramsToBS "POST " postParams
@@ -151,9 +157,9 @@ logCallbackDev cb app req = do
151 -- this is color coordinated with the request logging
157 -- this is color coordinated with the request logging
152 -- also includes the request path to connect it to the request
158 -- also includes the request path to connect it to the request
153 liftIO $ cb $ BS.concat $ ansiColor color "Status: " ++ [
159 liftIO $ cb $ BS.concat $ ansiColor color "Status: " ++ [
154− sCode rsp
160+ statusBS rsp
156− , msg rsp
162+ , msgBS rsp
158 , rawPathInfo req -- if you need help matching the 2 logging statements
164 , rawPathInfo req -- if you need help matching the 2 logging statements
@@ -165,8 +171,6 @@ logCallbackDev cb app req = do
166 , pack $ setSGRCode [Reset]
172 , pack $ setSGRCode [Reset]
168− sCode = pack . show . statusCode . responseStatus
169− msg = statusMessage . responseStatus
171 paramsToBS prefix params =
175 paramsToBS prefix params =
172 if null params then ""
176 if null params then ""
@@ -183,9 +187,15 @@ logCallbackDev cb app req = do
184 collectPostParams :: ([Param], [File LBS.ByteString]) -> [Param]
188 collectPostParams :: ([Param], [File LBS.ByteString]) -> [Param]
185 collectPostParams (postParams, files) = postParams ++
189 collectPostParams (postParams, files) = postParams ++
186− (map (\(k,v) -> (k, BS.append "FILE: " (fileName v))) files)
190+ map (\(k,v) -> (k, BS.append "FILE: " (fileName v))) files
188 readInt bs =
192 readInt bs =
189 case reads $ unpack bs of
193 case reads $ unpack bs of
190 (i, _):_ -> Just (i :: Int)
194 (i, _):_ -> Just (i :: Int)
191 [] -> Nothing
195 [] -> Nothing
197+statusBS :: Response -> BS.ByteString
198+statusBS = pack . show . statusCode . responseStatus
200+msgBS :: Response -> BS.ByteString
201+msgBS = statusMessage . responseStatus