{-# 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)

-- | This type matches the one returned by 'getLoggerIO'
type LoggerIO = UTCTime -> LogLevel -> Text -> Value -> IO ()

-- | Create a logging 'Middleware' that takes request id
-- given a 'LoggerIO' logging function and 'Options'
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)