{-# 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 -> Middleware
logRequestsWith loggerIO :: LoggerIO
loggerIO Options{..} app :: Application
app req :: Request
req respond :: Response -> IO ResponseReceived
respond = do
  Text -> Value -> IO ()
logIO "Request received" (Value -> IO ()) -> (Request -> Value) -> Request -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Pair] -> Value
object ([Pair] -> Value) -> (Request -> [Pair]) -> Request -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> [Pair]
logRequest (Request -> IO ()) -> Request -> IO ()
forall a b. (a -> b) -> a -> b
$ Request
req
  UTCTime
tStart <- IO UTCTime
getCurrentTime
  Application
app Request
req ((Response -> IO ResponseReceived) -> IO ResponseReceived)
-> (Response -> IO ResponseReceived) -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ \resp :: Response
resp -> do
    UTCTime
tEnd <- IO UTCTime
getCurrentTime
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
logSendingResponse (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
         Text -> IO ()
logIO_ "Sending response"
    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{..}
    Text -> Value -> IO ()
logIO "Request complete" (Value -> IO ()) -> ([Pair] -> Value) -> [Pair] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Pair] -> Value
object ([Pair] -> IO ()) -> [Pair] -> IO ()
forall a b. (a -> b) -> a -> b
$ Request -> Response -> ResponseTime -> [Pair]
logResponse Request
req Response
resp ResponseTime
times
    ResponseReceived -> IO ResponseReceived
forall (m :: * -> *) a. Monad m => a -> m a
return ResponseReceived
r

  where

    logIO :: Text -> Value -> IO ()
logIO message :: Text
message value :: Value
value = do
      UTCTime
now <- IO UTCTime
getCurrentTime
      LoggerIO
loggerIO UTCTime
now LogLevel
logLevel Text
message Value
value

    logIO_ :: Text -> IO ()
logIO_ m :: Text
m = Text -> Value -> IO ()
logIO Text
m Value
emptyObject