@@ -13,9 +13,10 @@ import System.IO (stdout, hFlush)
1313import qualified Data.ByteString as BS
1414import Data.ByteString.Char8 (pack, unpack)
1515import Control.Monad.IO.Class (liftIO)
16−import Network.Wai (Request(..), Middleware, responseStatus)
16+import Network.Wai (Request(..), Middleware, responseStatus, Response)
1717import System.Log.FastLogger
1818import Network.HTTP.Types as H
19+import Data.Maybe (fromMaybe)
1920
2021import Network.Wai.Parse (sinkRequestBody, lbsBackEnd, fileName, Param, File, getRequestBodyType)
2122import qualified Data.ByteString.Lazy as LBS
@@ -37,7 +38,7 @@ logHandleDev = logCallbackDev
3738-- | Production request logger middleware.
3839-- Implemented on top of "logCallback", but prints to 'stdout'
3940logStdout :: Middleware
40−logStdout = logHandle $ \bs -> hPutLogStr stdout [LB bs]
41+logStdout = logCallback $ \bs -> hPutLogStr stdout [LB bs]
4142
4243-- | Development request logger middleware.
4344-- Implemented on top of "logCallbackDev", but prints to 'stdout'
@@ -45,7 +46,7 @@ logStdout = logHandle $ \bs -> hPutLogStr stdout [LB bs]
4546-- Flushes 'stdout' on each request, which would be inefficient in production use.
4647-- Use "logStdout" in production.
4748logStdoutDev :: Middleware
48−logStdoutDev = logHandleDev $ \bs -> hPutLogStr stdout [LB bs] >> hFlush stdout
49+logStdoutDev = logCallbackDev $ \bs -> hPutLogStr stdout [LB bs] >> hFlush stdout
4950
5051-- | Prints a message using the given callback function for each request.
5152-- Designed for fast production use at the expense of convenience.
@@ -55,6 +56,7 @@ logStdoutDev = logHandleDev $ \bs -> hPutLogStr stdout [LB bs] >> hFlush stdout
5556logCallback :: (BS.ByteString -> IO ()) -- ^ A function that logs the ByteString log message.
5657 -> Middleware
5758logCallback cb app req = do
59+ rsp <- app req
5860 liftIO $ cb $ BS.concat
5961 [ requestMethod req
6062 , " "
@@ -64,15 +66,19 @@ logCallback cb app req = do
6466 , "Accept: "
6567 , maybe "" toBS $ lookup "Accept" $ requestHeaders req
6668 , "\n"
69+ , "Status: "
70+ , statusBS rsp
71+ , " "
72+ , msgBS rsp
6773 ]
68− app req
74+ return rsp
6975
7076toBS :: H.Ascii -> BS.ByteString
7177toBS = id
7278
7379-- no black or white which are expected to be existing terminal colors.
7480colors :: IORef [Color]
75−colors = unsafePerformIO $ newIORef $ [
81+colors = unsafePerformIO $ newIORef [
7682 Red
7783 , Green
7884 , Yellow
@@ -124,7 +130,7 @@ logCallbackDev cb app req = do
124130 return (req', body)
125131 _ -> return (req, [])
126132
127− postParams <- if any (requestMethod req ==) ["GET", "HEAD"]
133+ postParams <- if requestMethod req `elem` ["GET", "HEAD"]
128134 then return []
129135 else do postParams <- liftIO $ allPostParams body
130136 return $ collectPostParams postParams
@@ -139,7 +145,7 @@ logCallbackDev cb app req = do
139145 , rawPathInfo req
140146 , "\n"
141147 , "Accept: "
142− , maybe "" id $ lookup "Accept" $ requestHeaders req
148+ , fromMaybe "" $ lookup "Accept" $ requestHeaders req
143149 , paramsToBS "GET " getParams
144150 , paramsToBS "POST " postParams
145151 , "\n"
@@ -151,9 +157,9 @@ logCallbackDev cb app req = do
151157 -- this is color coordinated with the request logging
152158 -- also includes the request path to connect it to the request
153159 liftIO $ cb $ BS.concat $ ansiColor color "Status: " ++ [
154− sCode rsp
160+ statusBS rsp
155161 , " "
156− , msg rsp
162+ , msgBS rsp
157163 , ". "
158164 , rawPathInfo req -- if you need help matching the 2 logging statements
159165 , "\n"
@@ -165,8 +171,6 @@ logCallbackDev cb app req = do
165171 , bs
166172 , pack $ setSGRCode [Reset]
167173 ]
168− sCode = pack . show . statusCode . responseStatus
169− msg = statusMessage . responseStatus
170174
171175 paramsToBS prefix params =
172176 if null params then ""
@@ -183,9 +187,15 @@ logCallbackDev cb app req = do
183187
184188 collectPostParams :: ([Param], [File LBS.ByteString]) -> [Param]
185189 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
187191
188192 readInt bs =
189193 case reads $ unpack bs of
190194 (i, _):_ -> Just (i :: Int)
191195 [] -> Nothing
196+
197+statusBS :: Response -> BS.ByteString
198+statusBS = pack . show . statusCode . responseStatus
199+
200+msgBS :: Response -> BS.ByteString
201+msgBS = statusMessage . responseStatus