@@ -2,12 +2,10 @@
22module Network.Wai.Middleware.RequestLogger
33 ( logStdout
44 , logHandle
5− , logStdoutDev
5+ , logStdoutDevLT
66 , logHandleDevLT
77 ) where
88
9−import Network.Wai.Middleware.Debug (debug, debugHandle)
10−
119import System.IO (stdout)
1210import qualified Data.ByteString as BS
1311import Control.Monad.IO.Class (liftIO)
@@ -16,13 +14,12 @@ import System.Log.FastLogger
1614import Network.HTTP.Types as H
1715import qualified Data.Text.Lazy as LT
1816
19−-- | Inefficient, but convenient Development load logger middleware
20−logStdoutDev :: Middleware
21−logStdoutDev = debug
22−
23−-- | Inefficient, but convenient Development load logger middleware
24−logHandleDevLT :: (LT.Text -> IO ()) -> Middleware
25−logHandleDevLT = debugHandle
17+import Network.Wai.Parse (parseRequestBody, lbsSink, fileName, Param, File)
18+import qualified Data.ByteString.Lazy as LBS
19+import Data.Enumerator (run_, ($$), enumList)
20+import Data.Enumerator.List (consume)
21+import System.IO (hPutStrLn, stderr)
22+import Data.ByteString.Char8 (unpack)
2623
2724-- | lik @logHandle@, but prints to 'stdout'
2825logStdout :: Middleware
@@ -47,3 +44,45 @@ logHandle cb app req = do
4744
4845toBS :: H.Ascii -> BS.ByteString
4946toBS = id
47+
48+-- | Inefficient, but convenient Development load logger middleware
49+-- Prints a message to 'stderr' for each request using logHandleDevLT
50+logStdoutDevLT :: Middleware
51+logStdoutDevLT = logHandleDevLT $ hPutStrLn stderr . LT.unpack
52+
53+-- | Prints a message using the given callback function for each request.
54+-- This is not for serious production use- it is inefficient.
55+-- It immediately consumes a POST body and fills it back in and is otherwise inefficient
56+-- For production use use module Network.Wai.Middleware.RequestLogger
57+logHandleDevLT :: (LT.Text -> IO ()) -> Middleware
58+logHandleDevLT cb app req = do
59+ body <- consume
60+ postParams <- if any (requestMethod req ==) ["GET", "HEAD"]
61+ then return []
62+ else do postParams <- liftIO $ allPostParams req body
63+ return $ collectPostParams postParams
64+ let getParams = map emptyGetParam $ queryString req
65+
66+ liftIO $ cb $ LT.pack $ concat
67+ [ unpack $ requestMethod req
68+ , " "
69+ , unpack $ rawPathInfo req
70+ , "\n"
71+ , (++) "Accept: " $ maybe "" unpack $ lookup "Accept" $ requestHeaders req
72+ , paramsToStr "GET " getParams
73+ , paramsToStr "POST " postParams
74+ ]
75+ -- we just consumed the body- fill the enumerator back up so it is available again
76+ liftIO $ run_ $ enumList 1 body $$ app req
77+ where
78+ paramsToStr prefix params = if null params then "" else "\n" ++ prefix ++ (show params)
79+
80+ allPostParams req' body = run_ $ enumList 1 body $$ parseRequestBody lbsSink req'
81+
82+ emptyGetParam :: (BS.ByteString, Maybe BS.ByteString) -> (BS.ByteString, BS.ByteString)
83+ emptyGetParam (k, Just v) = (k,v)
84+ emptyGetParam (k, Nothing) = (k,"")
85+
86+ collectPostParams :: ([Param], [File LBS.ByteString]) -> [Param]
87+ collectPostParams (postParams, files) = postParams ++
88+ (map (\(k,v) -> (k, BS.append "FILE: " (fileName v))) files)