@@ -23,6 +23,10 @@ import qualified Data.ByteString.Lazy as LBS
2323import qualified Data.Conduit as C
2424import qualified Data.Conduit.List as CL
2525
26+import System.Console.ANSI
27+import Data.IORef
28+import System.IO.Unsafe
29+
2630logHandle :: (BS.ByteString -> IO ()) -> Middleware
2731logHandle = logCallback
2832{-# DEPRECATED logHandle "Please use logCallback instead." #-}
@@ -66,10 +70,25 @@ logCallback cb app req = do
6670toBS :: H.Ascii -> BS.ByteString
6771toBS = id
6872
73+-- no black or white which are expected to be used already
74+colors :: IORef [Color]
75+colors = unsafePerformIO $ newIORef $ [
76+ Red
77+ , Green
78+ , Yellow
79+ , Blue
80+ , Magenta
81+ , Cyan
82+ ]
83+
6984-- | Prints a message using the given callback function for each request.
7085-- This is not for serious production use- it is inefficient.
7186-- It immediately consumes a POST body and fills it back in and is otherwise inefficient
7287--
88+-- Note that it logs the request immediately when it is received.
89+-- This means if the app crashes you have still logged the request.
90+-- However, if you are simulating 10 simultaneous users you may find this confusing.
91+--
7392-- This is lower-level - use "logStdoutDev" unless you need this greater control
7493logCallbackDev :: (BS.ByteString -> IO ()) -- ^ A function that logs the ByteString log message.
7594 -> Middleware
@@ -88,9 +107,10 @@ logCallbackDev cb app req = do
88107 return $ collectPostParams postParams
89108 let getParams = map emptyGetParam $ queryString req
90109
91− liftIO $ cb $ BS.concat
92− [ requestMethod req
93− , " "
110+ color <- liftIO $ atomicModifyIORef colors (\(c:cs) -> (cs ++ [c], c))
111+
112+ liftIO $ cb $ BS.concat $ ansiColor color (requestMethod req) ++
113+ [ " "
94114 , rawPathInfo req
95115 , "\n"
96116 , "Accept: "
@@ -99,18 +119,26 @@ logCallbackDev cb app req = do
99119 , paramsToBS "POST " postParams
100120 , "\n"
101121 ]
122+
102123 -- The body was consumed. Fill it back up so it is available again
103124 rsp <- app req'
104− liftIO $ cb $ BS.concat [
105− "Status: "
106− , code rsp
125+
126+ liftIO $ cb $ BS.concat $ ansiColor color "Status: " ++ [
127+ sCode rsp
107128 , " "
108129 , msg rsp
130+ , ". "
131+ , rawPathInfo req -- if you need help matching the 2 logging statements
109132 , "\n"
110133 ]
111134 return rsp
112135 where
113− code = pack . show . statusCode . responseStatus
136+ ansiColor color bs = [
137+ pack $ setSGRCode [SetColor Foreground Vivid color]
138+ , bs
139+ , pack $ setSGRCode [Reset]
140+ ]
141+ sCode = pack . show . statusCode . responseStatus
114142 msg = statusMessage . responseStatus
115143 paramsToBS prefix params =
116144 if null params then ""