{-# LANGUAGE RecordWildCards #-}
module Network.Wai.Log.Internal where

import Data.Aeson.Types (Value(..), object)
import Data.ByteString.Builder (Builder)
import Data.Text (Text)
import Data.Time.Clock (UTCTime, diffUTCTime, getCurrentTime)
import Data.UUID (UUID)
import Data.UUID.V4 (nextRandom)
import Log (LogLevel)
import Network.Wai (Application, responseToStream)

import Network.Wai.Log.Options (Options(..), ResponseTime(..), requestUUID)

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

-- | Create a logging 'Middleware' that takes request UUID
-- given a 'LoggerIO' logging function and 'Options'
logRequestsWith :: LoggerIO -> Options -> (UUID -> Application) -> Application
logRequestsWith :: LoggerIO -> Options -> (UUID -> Application) -> Application
logRequestsWith LoggerIO
loggerIO Options{Maybe
  (Request -> Status -> ResponseHeaders -> Maybe (Builder -> Value))
LogLevel
UUID -> Request -> [Pair]
UUID -> Request -> Response -> Value -> ResponseTime -> [Pair]
logBody :: Options
-> Maybe
     (Request -> Status -> ResponseHeaders -> Maybe (Builder -> Value))
logResponse :: Options
-> UUID -> Request -> Response -> Value -> ResponseTime -> [Pair]
logRequest :: Options -> UUID -> Request -> [Pair]
logLevel :: Options -> LogLevel
logBody :: Maybe
  (Request -> Status -> ResponseHeaders -> Maybe (Builder -> Value))
logResponse :: UUID -> Request -> Response -> Value -> ResponseTime -> [Pair]
logRequest :: UUID -> Request -> [Pair]
logLevel :: LogLevel
..} UUID -> Application
mkApp Request
req Response -> IO ResponseReceived
respond = do
  UUID
uuid <- IO UUID
nextRandom
  Text -> [Pair] -> IO ()
logIO Text
"Request received" ([Pair] -> IO ()) -> [Pair] -> IO ()
forall a b. (a -> b) -> a -> b
$ UUID -> Request -> [Pair]
logRequest UUID
uuid Request
req
  UTCTime
tStart <- IO UTCTime
getCurrentTime
  UUID -> Application
mkApp UUID
uuid Request
req ((Response -> IO ResponseReceived) -> IO ResponseReceived)
-> (Response -> IO ResponseReceived) -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ \Response
resp -> do
    UTCTime
tEnd <- IO UTCTime
getCurrentTime
    Text -> [Pair] -> IO ()
logIO Text
"Sending response" ([Pair] -> IO ()) -> (UUID -> [Pair]) -> UUID -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UUID -> [Pair]
requestUUID (UUID -> IO ()) -> UUID -> IO ()
forall a b. (a -> b) -> a -> b
$ UUID
uuid
    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 -> NominalDiffTime -> ResponseTime
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" ([Pair] -> IO ()) -> [Pair] -> IO ()
forall a b. (a -> b) -> a -> b
$ UUID -> Request -> Response -> Value -> ResponseTime -> [Pair]
logResponse UUID
uuid 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) = Response
-> (Status, ResponseHeaders, (StreamingBody -> IO a) -> IO a)
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" ([Pair] -> IO ()) -> [Pair] -> IO ()
forall a b. (a -> b) -> a -> b
$ UUID -> Request -> Response -> Value -> ResponseTime -> [Pair]
logResponse UUID
uuid Request
req Response
resp Value
Null ResponseTime
times
          Just Builder -> Value
bodyLogValueConstructor ->
            (StreamingBody -> IO ()) -> IO ()
forall a. (StreamingBody -> IO a) -> IO a
bodyToIO ((StreamingBody -> IO ()) -> IO ())
-> (StreamingBody -> IO ()) -> IO ()
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" ([Pair] -> IO ()) -> [Pair] -> IO ()
forall a b. (a -> b) -> a -> b
$
                    UUID -> Request -> Response -> Value -> ResponseTime -> [Pair]
logResponse UUID
uuid Request
req Response
resp (Builder -> Value
bodyLogValueConstructor Builder
b) ResponseTime
times

              in StreamingBody
streamingBodyToIO Builder -> IO ()
logWithBuilder (() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
    ResponseReceived -> IO ResponseReceived
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)