fast-logger/wai-logger 2.0

This commit is contained in:
Michael Snoyman 2013-12-02 09:09:01 +02:00
parent 622d8ee0d0
commit 441a1d776c
4 changed files with 38 additions and 42 deletions

View File

@ -24,14 +24,17 @@ import System.IO (Handle, stdout)
import qualified Data.ByteString as BS
import Data.ByteString.Char8 (pack, unpack)
import Control.Monad.IO.Class (liftIO)
import Network.Wai (Request(..), Middleware, responseStatus, Response)
import Network.Wai (Request(..), Middleware, responseStatus, Response, responseHeaders)
import System.Log.FastLogger
import Network.HTTP.Types as H
import Data.Maybe (fromMaybe)
import Control.Monad.Trans.Resource (withInternalState)
import Data.Monoid (mconcat)
import Blaze.ByteString.Builder (toByteString)
import Network.Wai.Parse (sinkRequestBody, lbsBackEnd, fileName, Param, File, getRequestBodyType)
import qualified Data.ByteString.Lazy as LBS
import qualified Data.ByteString.Char8 as S8
import qualified Data.Conduit as C
import qualified Data.Conduit.List as CL
@ -41,20 +44,20 @@ import Data.IORef.Lifted
import System.IO.Unsafe
import Data.Default (Default (def))
import Network.Wai.Logger.Format (apacheFormat, IPAddrSource (..))
import Network.Wai.Logger
import Network.Wai.Middleware.RequestLogger.Internal
data OutputFormat = Apache IPAddrSource
| Detailed Bool -- ^ use colors?
| CustomOutputFormat OutputFormatter
type OutputFormatter = ZonedDate -> Request -> Status -> Maybe Integer -> [LogStr]
type OutputFormatter = ZonedDate -> Request -> Status -> Maybe Integer -> LogStr
data Destination = Handle Handle
| Logger Logger
| Logger LoggerSet
| Callback Callback
type Callback = [LogStr] -> IO ()
type Callback = LogStr -> IO ()
data RequestLoggerSettings = RequestLoggerSettings
{
@ -77,28 +80,31 @@ instance Default RequestLoggerSettings where
mkRequestLogger :: RequestLoggerSettings -> IO Middleware
mkRequestLogger RequestLoggerSettings{..} = do
(callback, mgetdate) <-
callback <-
case destination of
Handle h -> fmap fromLogger $ mkLogger autoFlush h
Logger l -> return $ fromLogger l
Callback c -> return (c, Nothing)
Handle h -> return $ BS.hPutStr h . toByteString . logStrBuilder
Logger l -> return $ pushLogStr l
Callback c -> return c
case outputFormat of
Apache ipsrc -> do
getdate <- dateHelper mgetdate
return $ apacheMiddleware callback ipsrc getdate
getdate <- getDateGetter
apache <- initLogger ipsrc (LogCallback callback (return ())) getdate
return $ apacheMiddleware apache
Detailed useColors -> detailedMiddleware callback useColors
CustomOutputFormat formatter -> do
getdate <- dateHelper mgetdate
getdate <- getDateGetter
return $ customMiddleware callback getdate formatter
where
fromLogger l = (loggerPutStr l, Just $ loggerDate l)
dateHelper mgetdate = do
case mgetdate of
Just x -> return x
Nothing -> getDateGetter
apacheMiddleware :: Callback -> IPAddrSource -> IO ZonedDate -> Middleware
apacheMiddleware cb ipsrc getdate = customMiddleware cb getdate $ apacheFormat ipsrc
apacheMiddleware :: ApacheLoggerActions -> Middleware
apacheMiddleware ala app req = do
res <- app req
let msize = lookup "content-length" (responseHeaders res) >>= readInt'
readInt' bs =
case S8.readInteger bs of
Just (i, "") -> Just i
_ -> Nothing
apacheLogger ala req (responseStatus res) msize
return res
customMiddleware :: Callback -> IO ZonedDate -> OutputFormatter -> Middleware
customMiddleware cb getdate formatter app req = do
@ -222,7 +228,7 @@ detailedMiddleware' cb getAddColor app req = do
addColor <- getAddColor
-- log the request immediately.
liftIO $ cb $ map LB $ addColor (requestMethod req) ++
liftIO $ cb $ mconcat $ map toLogStr $ addColor (requestMethod req) ++
[ " "
, rawPathInfo req
, "\n"
@ -238,7 +244,7 @@ detailedMiddleware' cb getAddColor app req = do
-- log the status of the response
-- this is color coordinated with the request logging
-- also includes the request path to connect it to the request
liftIO $ cb $ map LB $ addColor "Status: " ++ [
liftIO $ cb $ mconcat $ map toLogStr $ addColor "Status: " ++ [
statusBS rsp
, " "
, msgBS rsp

View File

@ -5,16 +5,7 @@
module Network.Wai.Middleware.RequestLogger.Internal where
import Data.ByteString (ByteString)
import System.Log.FastLogger
#if MIN_VERSION_fast_logger(0,3,0)
import System.Date.Cache (ondemandDateCacher)
#else
import System.Log.FastLogger.Date (getDate, dateInit, ZonedDate)
#endif
import Network.Wai.Logger (clockDateCacher)
getDateGetter :: IO (IO ByteString)
#if MIN_VERSION_fast_logger(0, 3, 0)
getDateGetter = fmap fst $ ondemandDateCacher zonedDateCacheConf
#else
getDateGetter = fmap getDate dateInit
#endif
getDateGetter = fmap fst clockDateCacher

View File

@ -3,6 +3,8 @@ module WaiExtraTest (specs) where
import Test.Hspec
import Test.HUnit hiding (Test)
import Data.Monoid (mappend, mempty)
import Blaze.ByteString.Builder (toByteString)
import Network.Wai
import Network.Wai.Test
@ -544,21 +546,19 @@ caseDebugRequestBody = do
getOutput params' = T.pack $ "GET /location\nAccept: \nGET " ++ show params' ++ "\nStatus: 200 OK. /location\n"
debugApp output' req = do
iactual <- liftIO $ I.newIORef []
iactual <- liftIO $ I.newIORef mempty
middleware <- liftIO $ mkRequestLogger def
{ destination = Callback $ \strs -> I.modifyIORef iactual $ (++ strs)
{ destination = Callback $ \strs -> I.modifyIORef iactual $ (`mappend` strs)
, outputFormat = Detailed False
}
res <- middleware (\_req -> return $ responseLBS status200 [ ] "") req
actual <- liftIO $ I.readIORef iactual
liftIO $ assertEqual "debug" output $ logsToBs actual
liftIO $ assertEqual "debug" output $ logToBs actual
return res
where
output = TE.encodeUtf8 $ T.toStrict output'
logsToBs = S.concat . map logToBs
logToBs (LB bs) = bs
logToBs (LS s) = S8.pack s
logToBs = toByteString . logStrBuilder
{-debugApp = debug $ \req -> do-}
{-return $ responseLBS status200 [ ] ""-}

View File

@ -33,9 +33,8 @@ Library
, text >= 0.7 && < 0.12
, case-insensitive >= 0.2
, data-default
, date-cache >= 0.3 && < 0.4
, fast-logger >= 0.2 && < 0.4
, wai-logger >= 0.2 && < 0.4
, fast-logger >= 2.0 && < 2.1
, wai-logger >= 2.0 && < 2.1
, conduit >= 1.0 && < 1.1
, zlib-conduit >= 0.5 && < 1.1
, blaze-builder-conduit >= 0.5 && < 1.1