diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,2 +1,10 @@ +# wai-log-0.2 (not released) + +* Entire interface has changed: now builds a `Middleware` in a `MonadLog` + context +* Adds `Options` to control what is logged +* Currently logging behaviour is unchanged when using `defaultOptions` + # wai-log-0.1 (2019-03-07) + * Initial release (split from internal Scrive package). diff --git a/src/Network/Wai/Log.hs b/src/Network/Wai/Log.hs --- a/src/Network/Wai/Log.hs +++ b/src/Network/Wai/Log.hs @@ -1,8 +1,7 @@ -- | A simple logging middleware for WAI applications that supports the 'log-*' -- family of packages: -- --- Currently there are no logging options but contributions are welcome. --- When logging to @stdout@, the output looks like this: +-- When logging to @stdout@ using 'defaultOptions', the output looks like this: -- -- @ -- 2019-02-21 19:51:47 INFO my-server: Request received { @@ -25,50 +24,30 @@ -- } -- @ module Network.Wai.Log ( - logRequestsWith +-- * Create a Middleware + mkApplicationLogger +, mkApplicationLoggerWith +-- ** Options +, Options(..) +, defaultOptions ) where -import Data.Aeson () -import Data.String.Conversions (ConvertibleStrings, StrictText, cs) -import Data.Text (Text) -import Data.Time.Clock (UTCTime, diffUTCTime, getCurrentTime) -import Log -import Network.HTTP.Types.Status -import Network.Wai - --- | Given a logger, create a 'Middleware' that logs incoming requests, the --- response code, and how long it took to process and respond to the request. -logRequestsWith :: (LogT IO () -> IO ()) -> Middleware -logRequestsWith runLogger app req respond = do - - runLogger . logInfo "Request received" $ object - [ "method" .= ts (requestMethod req) - , "url" .= ts (rawPathInfo req) - , "remote-host" .= show (remoteHost req) - , "user-agent" .= fmap ts (requestHeaderUserAgent req) - , "body-length" .= show (requestBodyLength req) - ] - tStart <- getCurrentTime - - app req $ \resp -> do - tEnd <- getCurrentTime - runLogger $ logInfo_ "Sending response" - r <- respond resp - tFull <- getCurrentTime +import Prelude hiding (log) - runLogger . logInfo "Request complete" $ object - [ "status" .= object [ "code" .= statusCode (responseStatus resp) - , "message" .= ts (statusMessage (responseStatus resp)) - ] - , "time" .= object [ "full" .= diffSeconds tFull tStart - , "process" .= diffSeconds tEnd tStart - ] - ] +import Log (MonadLog, getLoggerIO) +import Network.Wai (Middleware) - return r +import Network.Wai.Log.Internal +import Network.Wai.Log.Options -diffSeconds :: UTCTime -> UTCTime -> Double -diffSeconds a b = realToFrac $ diffUTCTime a b +-- | Create a logging 'Middleware' using 'defaultOptions' +-- +-- Use 'mkApplicationLoggerWith' for custom 'Options' +mkApplicationLogger :: MonadLog m => m Middleware +mkApplicationLogger = mkApplicationLoggerWith defaultOptions -ts :: ConvertibleStrings a StrictText => a -> Text -ts = cs +-- | Create a logging 'Middleware' using the supplied 'Options' +mkApplicationLoggerWith :: MonadLog m => Options -> m Middleware +mkApplicationLoggerWith options = do + logIO <- getLoggerIO + return $ logRequestsWith logIO options diff --git a/src/Network/Wai/Log/Internal.hs b/src/Network/Wai/Log/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Network/Wai/Log/Internal.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE RecordWildCards #-} +module Network.Wai.Log.Internal where + +import Control.Monad (when) +import Data.Aeson.Types (Value, object, emptyObject) +import Data.Text (Text) +import Data.Time.Clock (UTCTime, diffUTCTime, getCurrentTime) +import Log (LogLevel) +import Network.Wai (Middleware) + +import Network.Wai.Log.Options (Options(..), ResponseTime(..)) + +-- | This type matches the one returned by 'getLoggerIO' +type LoggerIO = UTCTime -> LogLevel -> Text -> Value -> IO () + +-- | Create a logging 'Middleware' given a 'LoggerIO' logging function and 'Options' +logRequestsWith :: LoggerIO -> Options -> Middleware +logRequestsWith loggerIO Options{..} app req respond = do + logIO "Request received" . object . logRequest $ req + tStart <- getCurrentTime + app req $ \resp -> do + tEnd <- getCurrentTime + when logSendingResponse $ + logIO_ "Sending response" + r <- respond resp + tFull <- getCurrentTime + let processing = diffUTCTime tEnd tStart + full = diffUTCTime tFull tStart + times = ResponseTime{..} + logIO "Request complete" . object $ logResponse req resp times + return r + + where + + logIO message value = do + now <- getCurrentTime + loggerIO now logLevel message value + + logIO_ m = logIO m emptyObject diff --git a/src/Network/Wai/Log/Options.hs b/src/Network/Wai/Log/Options.hs new file mode 100644 --- /dev/null +++ b/src/Network/Wai/Log/Options.hs @@ -0,0 +1,89 @@ +module Network.Wai.Log.Options ( +-- * Options & Timing + Options(..) +, ResponseTime(..) +-- * Defaults +, defaultOptions +, defaultLogRequest +, defaultLogResponse +) where + +import Data.Aeson.Types (Pair) +import Data.String.Conversions (ConvertibleStrings, StrictText, cs) +import Data.Text (Text) +import Data.Time.Clock (NominalDiffTime) +import Log +import Network.HTTP.Types.Status +import Network.Wai + +-- | Logging options +data Options = Options { + logLevel :: LogLevel + , logRequest :: Request -> [Pair] + , logSendingResponse :: Bool + , logResponse :: Request -> Response -> ResponseTime -> [Pair] + } + +-- | Timing data +data ResponseTime = ResponseTime { + -- | Time between request received and application finished processing request + processing :: NominalDiffTime + -- | Time between request received and response sent + , full :: NominalDiffTime + } + +-- | Default 'Options' +-- +-- @ +-- { logLevel = 'LogInfo' +-- , logRequest = 'defaultLogRequest' +-- , logSendingResponse = True +-- , logResponse = 'defaultLogResponse' +-- } +-- @ +defaultOptions :: Options +defaultOptions = Options + { logLevel = LogInfo + , logRequest = defaultLogRequest + , logSendingResponse = True + , logResponse = defaultLogResponse + } + +-- | Logs the following request values: +-- +-- * method +-- * url path +-- * remote host +-- * user agent +-- * body-length +defaultLogRequest :: Request -> [Pair] +defaultLogRequest req = + [ "method" .= ts (requestMethod req) + , "url" .= ts (rawPathInfo req) + , "remote-host" .= show (remoteHost req) + , "user-agent" .= fmap ts (requestHeaderUserAgent req) + , "body-length" .= show (requestBodyLength req) + ] + +-- | Logs the following values: +-- +-- * status code +-- * status message +-- * time full +-- * time processing +-- +-- Nothing from the 'Request' is logged +-- +-- Time is in seconds as that is how 'NominalDiffTime' is treated by default +defaultLogResponse :: Request -> Response -> ResponseTime -> [Pair] +defaultLogResponse _req resp time = + [ "status" .= object [ "code" .= statusCode (responseStatus resp) + , "message" .= ts (statusMessage (responseStatus resp)) + ] + , "time" .= object [ "full" .= full time + , "process" .= processing time + ] + ] + +ts :: ConvertibleStrings a StrictText => a -> Text +ts = cs diff --git a/wai-log.cabal b/wai-log.cabal --- a/wai-log.cabal +++ b/wai-log.cabal @@ -1,5 +1,6 @@ +cabal-version: 2.0 name: wai-log -version: 0.1.0.0 +version: 0.2.0.0 synopsis: A logging middleware for WAI applications @@ -21,8 +22,9 @@ license-file: LICENSE build-type: Simple -cabal-version: 2.0 extra-source-files: CHANGELOG.md, README.md +tested-with: GHC ==7.10.3, GHC ==8.0.2, GHC ==8.2.2, GHC ==8.4.4, + GHC ==8.6.4 Source-repository head Type: git @@ -43,3 +45,5 @@ , time , wai exposed-modules: Network.Wai.Log + , Network.Wai.Log.Options + , Network.Wai.Log.Internal