{-# LANGUAGE RecordWildCards #-}
module Network.Wai.Log.Internal where
import Data.Aeson.Types (ToJSON, Value(..), object)
import Data.ByteString.Builder (Builder)
import Data.Text (Text)
import Data.Time.Clock (UTCTime, diffUTCTime, getCurrentTime)
import Log (LogLevel)
import Network.Wai (Application, responseToStream)
import Network.Wai.Log.Options (Options(..), ResponseTime(..), requestId)
type LoggerIO = UTCTime -> LogLevel -> Text -> Value -> IO ()
logRequestsWith :: ToJSON id => LoggerIO -> Options id -> (id -> Application) -> Application
logRequestsWith :: forall id.
ToJSON id =>
LoggerIO -> Options id -> (id -> Application) -> Application
logRequestsWith LoggerIO
loggerIO Options{Maybe
(Request -> Status -> ResponseHeaders -> Maybe (Builder -> Value))
LogLevel
id -> Request -> [Pair]
id -> Request -> Response -> Value -> ResponseTime -> [Pair]
Request -> IO id
logGetRequestId :: forall id. Options id -> Request -> IO id
logBody :: forall id.
Options id
-> Maybe
(Request -> Status -> ResponseHeaders -> Maybe (Builder -> Value))
logResponse :: forall id.
Options id
-> id -> Request -> Response -> Value -> ResponseTime -> [Pair]
logRequest :: forall id. Options id -> id -> Request -> [Pair]
logLevel :: forall id. Options id -> LogLevel
logGetRequestId :: Request -> IO id
logBody :: Maybe
(Request -> Status -> ResponseHeaders -> Maybe (Builder -> Value))
logResponse :: id -> Request -> Response -> Value -> ResponseTime -> [Pair]
logRequest :: id -> Request -> [Pair]
logLevel :: LogLevel
..} id -> Application
mkApp Request
req Response -> IO ResponseReceived
respond = do
id
reqId <- Request -> IO id
logGetRequestId Request
req
Text -> [Pair] -> IO ()
logIO Text
"Request received" forall a b. (a -> b) -> a -> b
$ id -> Request -> [Pair]
logRequest id
reqId Request
req
UTCTime
tStart <- IO UTCTime
getCurrentTime
id -> Application
mkApp id
reqId Request
req forall a b. (a -> b) -> a -> b
$ \Response
resp -> do
UTCTime
tEnd <- IO UTCTime
getCurrentTime
Text -> [Pair] -> IO ()
logIO Text
"Sending response" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall id. ToJSON id => id -> [Pair]
requestId forall a b. (a -> b) -> a -> b
$ id
reqId
ResponseReceived
r <- Response -> IO ResponseReceived
respond Response
resp
UTCTime
tFull <- IO UTCTime
getCurrentTime
let processing :: NominalDiffTime
processing = UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
tEnd UTCTime
tStart
full :: NominalDiffTime
full = UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
tFull UTCTime
tStart
times :: ResponseTime
times = ResponseTime{NominalDiffTime
full :: NominalDiffTime
processing :: NominalDiffTime
full :: NominalDiffTime
processing :: NominalDiffTime
..}
()
_ <- case Maybe
(Request -> Status -> ResponseHeaders -> Maybe (Builder -> Value))
logBody of
Maybe
(Request -> Status -> ResponseHeaders -> Maybe (Builder -> Value))
Nothing ->
Text -> [Pair] -> IO ()
logIO Text
"Request complete" forall a b. (a -> b) -> a -> b
$ id -> Request -> Response -> Value -> ResponseTime -> [Pair]
logResponse id
reqId Request
req Response
resp Value
Null ResponseTime
times
Just Request -> Status -> ResponseHeaders -> Maybe (Builder -> Value)
bodyLogValueConstructorFunction ->
let (Status
status, ResponseHeaders
responseHeaders, (StreamingBody -> IO a) -> IO a
bodyToIO) = forall a.
Response
-> (Status, ResponseHeaders, (StreamingBody -> IO a) -> IO a)
responseToStream Response
resp
mBodyLogValueConstructor :: Maybe (Builder -> Value)
mBodyLogValueConstructor =
Request -> Status -> ResponseHeaders -> Maybe (Builder -> Value)
bodyLogValueConstructorFunction Request
req Status
status ResponseHeaders
responseHeaders
in case Maybe (Builder -> Value)
mBodyLogValueConstructor of
Maybe (Builder -> Value)
Nothing ->
Text -> [Pair] -> IO ()
logIO Text
"Request complete" forall a b. (a -> b) -> a -> b
$ id -> Request -> Response -> Value -> ResponseTime -> [Pair]
logResponse id
reqId Request
req Response
resp Value
Null ResponseTime
times
Just Builder -> Value
bodyLogValueConstructor ->
forall {a}. (StreamingBody -> IO a) -> IO a
bodyToIO forall a b. (a -> b) -> a -> b
$ \StreamingBody
streamingBodyToIO ->
let logWithBuilder :: Builder -> IO ()
logWithBuilder :: Builder -> IO ()
logWithBuilder Builder
b = Text -> [Pair] -> IO ()
logIO Text
"Request complete" forall a b. (a -> b) -> a -> b
$
id -> Request -> Response -> Value -> ResponseTime -> [Pair]
logResponse id
reqId Request
req Response
resp (Builder -> Value
bodyLogValueConstructor Builder
b) ResponseTime
times
in StreamingBody
streamingBodyToIO Builder -> IO ()
logWithBuilder (forall (m :: * -> *) a. Monad m => a -> m a
return ())
forall (m :: * -> *) a. Monad m => a -> m a
return ResponseReceived
r
where
logIO :: Text -> [Pair] -> IO ()
logIO Text
message [Pair]
pairs = do
UTCTime
now <- IO UTCTime
getCurrentTime
LoggerIO
loggerIO UTCTime
now LogLevel
logLevel Text
message ([Pair] -> Value
object [Pair]
pairs)