{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE StrictData #-}

-- |
-- Description: Middleware for logging request and response info through Katip.
--
-- Add information about 'Wai.Request', 'Wai.Response', and the elapsed time to Katip's 'Katip.LogContexts'.
--
-- The following is added to the context as \"response\":
--
--   - \"elapsedTimeInNanoSeconds\": Amount of time from receiving the request to sending the response in nano seconds.
--
--   - \"status\": The status of the response, ie. 200, 202, 204, 400, 404, 500, etc.
module Katip.Wai
  ( -- * Middleware
    defaultFormat
  , middlewareWithFormatter
  , middleware

    -- * Helpers for threading Katip's Context throughout the entire 'Wai.Application`
  , ApplicationT
  , MiddlewareT
  , runApplication
  )
where

import Control.Monad.IO.Class (MonadIO, liftIO)
import Data.Aeson ((.=))
import qualified Data.Aeson as Aeson
import Data.ByteString (ByteString)
import Data.Text (Text)
import qualified Data.Text as Text
import Data.Text.Encoding (decodeUtf8With)
import Data.Text.Encoding.Error (lenientDecode)
import Data.UUID (UUID)
import qualified Data.UUID as UUID
import qualified Data.UUID.V4 as UUID.V4
import qualified Katip
import Network.HTTP.Types (Method)
import Network.HTTP.Types.Status (Status)
import Network.HTTP.Types.URI (Query, queryToQueryText)
import Network.HTTP.Types.Version (HttpVersion)
import Network.Socket (SockAddr)
import qualified Network.Wai as Wai
import qualified System.Clock as Clock


data Request = Request
  { Request -> UUID
requestId :: UUID
  , Request -> HttpVersion
requestHttpVersion :: HttpVersion
  , Request -> SockAddr
requestRemoteHost :: SockAddr
  , Request -> Bool
requestIsSecure :: Bool
  , Request -> Method
requestMethod :: Method
  , Request -> [Text]
requestPathInfo :: [Text]
  , Request -> Query
requestQueryString :: Query
  , Request -> RequestBodyLength
requestBodyLength :: Wai.RequestBodyLength
  , Request -> Maybe Method
requestHeaderHost :: Maybe ByteString
  , Request -> Maybe Method
requestHeaderReferer :: Maybe ByteString
  , Request -> Maybe Method
requestHeaderUserAgent :: Maybe ByteString
  , Request -> Maybe Method
requestHeaderRange :: Maybe ByteString
  }

#if MIN_VERSION_aeson(2,2,0)
requestToKeyValues :: Aeson.KeyValue e kv => Request -> [kv]
#else
requestToKeyValues :: Aeson.KeyValue kv => Request -> [kv]
#endif


requestToKeyValues :: forall e kv. KeyValue e kv => Request -> [kv]
requestToKeyValues Request{Bool
Query
[Text]
Maybe Method
Method
HttpVersion
SockAddr
UUID
RequestBodyLength
requestId :: Request -> UUID
requestHttpVersion :: Request -> HttpVersion
requestRemoteHost :: Request -> SockAddr
requestIsSecure :: Request -> Bool
requestMethod :: Request -> Method
requestPathInfo :: Request -> [Text]
requestQueryString :: Request -> Query
requestBodyLength :: Request -> RequestBodyLength
requestHeaderHost :: Request -> Maybe Method
requestHeaderReferer :: Request -> Maybe Method
requestHeaderUserAgent :: Request -> Maybe Method
requestHeaderRange :: Request -> Maybe Method
requestId :: UUID
requestHttpVersion :: HttpVersion
requestRemoteHost :: SockAddr
requestIsSecure :: Bool
requestMethod :: Method
requestPathInfo :: [Text]
requestQueryString :: Query
requestBodyLength :: RequestBodyLength
requestHeaderHost :: Maybe Method
requestHeaderReferer :: Maybe Method
requestHeaderUserAgent :: Maybe Method
requestHeaderRange :: Maybe Method
..} =
  let toText :: Method -> Text
toText = OnDecodeError -> Method -> Text
decodeUtf8With OnDecodeError
lenientDecode
      headers :: Value
headers =
        [Pair] -> Value
Aeson.object
          [ Key
"host" Key -> Maybe Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (Method -> Text) -> Maybe Method -> Maybe Text
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Method -> Text
toText Maybe Method
requestHeaderHost
          , Key
"referer" Key -> Maybe Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (Method -> Text) -> Maybe Method -> Maybe Text
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Method -> Text
toText Maybe Method
requestHeaderReferer
          , Key
"userAgent" Key -> Maybe Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (Method -> Text) -> Maybe Method -> Maybe Text
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Method -> Text
toText Maybe Method
requestHeaderUserAgent
          , Key
"range" Key -> Maybe Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (Method -> Text) -> Maybe Method -> Maybe Text
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Method -> Text
toText Maybe Method
requestHeaderRange
          ]
   in [ Key
"id" Key -> Text -> kv
forall v. ToJSON v => Key -> v -> kv
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= UUID -> Text
UUID.toText UUID
requestId
      , Key
"httpVersion" Key -> String -> kv
forall v. ToJSON v => Key -> v -> kv
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= HttpVersion -> String
forall a. Show a => a -> String
show HttpVersion
requestHttpVersion
      , Key
"remoteHost" Key -> String -> kv
forall v. ToJSON v => Key -> v -> kv
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= SockAddr -> String
forall a. Show a => a -> String
show SockAddr
requestRemoteHost
      , Key
"isSecure" Key -> Bool -> kv
forall v. ToJSON v => Key -> v -> kv
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Bool
requestIsSecure
      , Key
"method" Key -> Text -> kv
forall v. ToJSON v => Key -> v -> kv
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Method -> Text
toText Method
requestMethod
      , Key
"path" Key -> Text -> kv
forall v. ToJSON v => Key -> v -> kv
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text -> [Text] -> Text
Text.intercalate Text
"/" [Text]
requestPathInfo
      , Key
"queryString" Key -> QueryText -> kv
forall v. ToJSON v => Key -> v -> kv
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Query -> QueryText
queryToQueryText Query
requestQueryString
      , Key
"bodyLength" Key -> String -> kv
forall v. ToJSON v => Key -> v -> kv
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= RequestBodyLength -> String
forall a. Show a => a -> String
show RequestBodyLength
requestBodyLength
      , Key
"headers" Key -> Value -> kv
forall v. ToJSON v => Key -> v -> kv
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Value
headers
      ]


instance Aeson.ToJSON Request where
  toJSON :: Request -> Value
toJSON = [Pair] -> Value
Aeson.object ([Pair] -> Value) -> (Request -> [Pair]) -> Request -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> [Pair]
forall e kv. KeyValue e kv => Request -> [kv]
requestToKeyValues
  toEncoding :: Request -> Encoding
toEncoding = Series -> Encoding
Aeson.pairs (Series -> Encoding) -> (Request -> Series) -> Request -> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Series] -> Series
forall a. Monoid a => [a] -> a
mconcat ([Series] -> Series) -> (Request -> [Series]) -> Request -> Series
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> [Series]
forall e kv. KeyValue e kv => Request -> [kv]
requestToKeyValues


-- | Default format for the request. The requestId will be unique every time we
-- call this function, it's an id to correlate logs generated by the request.
--
-- Current format:
--
--  - \"id\": Uniquely generated string that can be used to correlate logs to a single request.
--
--  - \"httpVersion\": Version of the request.
--
--  - \"remoteHost\": Address the request came from.
--
--  - \"isSecure\": True if the request was made over an SSL connection, otherwise false.
--
--  - \"method\": HTTP Method used for the request, ie. GET, POST, PUT, PATCH, DELETE, etc.
--
--  - \"path\": URL without a hostname, port, or querystring.
--
--  - \"queryString\": Query string of the request if one was sent.
--
--  - \"bodyLength\": Size of the body in the request.
--
--  - \"headers.host\": Value of the \"Host\" header.
--
--  - \"headers.referer\": Value of the \"Referer\" header.
--
--  - \"headers.userAgent\": Value of the \"User-Agent\" header.
--
--  - \"headers.range\": Value of the \"Range\" header.
defaultFormat :: UUID -> Wai.Request -> Aeson.Value
defaultFormat :: UUID -> Request -> Value
defaultFormat UUID
requestId Request
request =
  Request -> Value
forall a. ToJSON a => a -> Value
Aeson.toJSON (Request -> Value) -> Request -> Value
forall a b. (a -> b) -> a -> b
$
    Request
      { requestId :: UUID
requestId = UUID
requestId
      , requestHttpVersion :: HttpVersion
requestHttpVersion = Request -> HttpVersion
Wai.httpVersion Request
request
      , requestRemoteHost :: SockAddr
requestRemoteHost = Request -> SockAddr
Wai.remoteHost Request
request
      , requestIsSecure :: Bool
requestIsSecure = Request -> Bool
Wai.isSecure Request
request
      , requestMethod :: Method
requestMethod = Request -> Method
Wai.requestMethod Request
request
      , requestPathInfo :: [Text]
requestPathInfo = Request -> [Text]
Wai.pathInfo Request
request
      , requestQueryString :: Query
requestQueryString = Request -> Query
Wai.queryString Request
request
      , requestBodyLength :: RequestBodyLength
requestBodyLength = Request -> RequestBodyLength
Wai.requestBodyLength Request
request
      , requestHeaderHost :: Maybe Method
requestHeaderHost = Request -> Maybe Method
Wai.requestHeaderHost Request
request
      , requestHeaderReferer :: Maybe Method
requestHeaderReferer = Request -> Maybe Method
Wai.requestHeaderReferer Request
request
      , requestHeaderUserAgent :: Maybe Method
requestHeaderUserAgent = Request -> Maybe Method
Wai.requestHeaderUserAgent Request
request
      , requestHeaderRange :: Maybe Method
requestHeaderRange = Request -> Maybe Method
Wai.requestHeaderRange Request
request
      }


data Response = Response
  { Response -> TimeSpec
responseElapsedTime :: Clock.TimeSpec
  , Response -> Status
responseStatus :: Status
  }

#if MIN_VERSION_aeson(2,2,0)
responseToKeyValues :: Aeson.KeyValue e kv => Response -> [kv]
#else
responseToKeyValues :: Aeson.KeyValue kv => Response -> [kv]
#endif


responseToKeyValues :: forall e kv. KeyValue e kv => Response -> [kv]
responseToKeyValues Response{TimeSpec
Status
responseElapsedTime :: Response -> TimeSpec
responseStatus :: Response -> Status
responseElapsedTime :: TimeSpec
responseStatus :: Status
..} =
  [ Key
"elapsedTimeInNanoSeconds" Key -> Integer -> kv
forall v. ToJSON v => Key -> v -> kv
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= TimeSpec -> Integer
Clock.toNanoSecs TimeSpec
responseElapsedTime
  , Key
"status" Key -> Int -> kv
forall v. ToJSON v => Key -> v -> kv
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Status -> Int
forall a. Enum a => a -> Int
fromEnum Status
responseStatus
  ]


instance Aeson.ToJSON Response where
  toJSON :: Response -> Value
toJSON = [Pair] -> Value
Aeson.object ([Pair] -> Value) -> (Response -> [Pair]) -> Response -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Response -> [Pair]
forall e kv. KeyValue e kv => Response -> [kv]
responseToKeyValues
  toEncoding :: Response -> Encoding
toEncoding = Series -> Encoding
Aeson.pairs (Series -> Encoding)
-> (Response -> Series) -> Response -> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Series] -> Series
forall a. Monoid a => [a] -> a
mconcat ([Series] -> Series)
-> (Response -> [Series]) -> Response -> Series
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Response -> [Series]
forall e kv. KeyValue e kv => Response -> [kv]
responseToKeyValues


-- | Just like 'Wai.Application' except it runs in @m@ instead of 'IO'
type ApplicationT m = Wai.Request -> (Wai.Response -> m Wai.ResponseReceived) -> m Wai.ResponseReceived


-- | Converts an 'ApplicationT' to a normal 'Wai.Application'
runApplication :: MonadIO m => (forall a. m a -> IO a) -> ApplicationT m -> Wai.Application
runApplication :: forall (m :: * -> *).
MonadIO m =>
(forall a. m a -> IO a) -> ApplicationT m -> Application
runApplication forall a. m a -> IO a
toIO ApplicationT m
application Request
request Response -> IO ResponseReceived
send =
  m ResponseReceived -> IO ResponseReceived
forall a. m a -> IO a
toIO (m ResponseReceived -> IO ResponseReceived)
-> m ResponseReceived -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ ApplicationT m
application Request
request (IO ResponseReceived -> m ResponseReceived
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ResponseReceived -> m ResponseReceived)
-> (Response -> IO ResponseReceived)
-> Response
-> m ResponseReceived
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Response -> IO ResponseReceived
send)


-- | Just like 'Wai.Middleware' except it runs in @m@ instead of 'IO'
type MiddlewareT m = ApplicationT m -> ApplicationT m


withLoggedResponse
  :: Katip.KatipContext m
  => Katip.Severity
  -> Clock.TimeSpec
  -> (Wai.Response -> m Wai.ResponseReceived)
  -> Wai.Response
  -> m Wai.ResponseReceived
withLoggedResponse :: forall (m :: * -> *).
KatipContext m =>
Severity
-> TimeSpec
-> (Response -> m ResponseReceived)
-> Response
-> m ResponseReceived
withLoggedResponse Severity
severity TimeSpec
start Response -> m ResponseReceived
send Response
response = do
  ResponseReceived
responseReceived <- Response -> m ResponseReceived
send Response
response

  TimeSpec
end <- IO TimeSpec -> m TimeSpec
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO TimeSpec -> m TimeSpec) -> IO TimeSpec -> m TimeSpec
forall a b. (a -> b) -> a -> b
$ Clock -> IO TimeSpec
Clock.getTime Clock
Clock.Monotonic

  let loggableResponse :: Response
loggableResponse =
        Response
          { responseElapsedTime :: TimeSpec
responseElapsedTime = TimeSpec
end TimeSpec -> TimeSpec -> TimeSpec
`Clock.diffTimeSpec` TimeSpec
start
          , responseStatus :: Status
responseStatus = Response -> Status
Wai.responseStatus Response
response
          }

  SimpleLogPayload -> m ResponseReceived -> m ResponseReceived
forall i (m :: * -> *) a.
(LogItem i, KatipContext m) =>
i -> m a -> m a
Katip.katipAddContext (Text -> Response -> SimpleLogPayload
forall a. ToJSON a => Text -> a -> SimpleLogPayload
Katip.sl Text
"response" Response
loggableResponse) (m ResponseReceived -> m ResponseReceived)
-> m ResponseReceived -> m ResponseReceived
forall a b. (a -> b) -> a -> b
$ do
    Severity -> LogStr -> m ()
forall (m :: * -> *).
(Applicative m, KatipContext m) =>
Severity -> LogStr -> m ()
Katip.logFM Severity
severity LogStr
"Response sent"
    ResponseReceived -> m ResponseReceived
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ResponseReceived
responseReceived


-- | Logs the request using the provided format, response, and elapsed time in Katip's context
middlewareWithFormatter :: Katip.KatipContext m => (UUID -> Wai.Request -> Aeson.Value) -> Katip.Severity -> MiddlewareT m
middlewareWithFormatter :: forall (m :: * -> *).
KatipContext m =>
(UUID -> Request -> Value) -> Severity -> MiddlewareT m
middlewareWithFormatter UUID -> Request -> Value
format Severity
severity ApplicationT m
application Request
request Response -> m ResponseReceived
send = do
  TimeSpec
start <- IO TimeSpec -> m TimeSpec
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO TimeSpec -> m TimeSpec) -> IO TimeSpec -> m TimeSpec
forall a b. (a -> b) -> a -> b
$ Clock -> IO TimeSpec
Clock.getTime Clock
Clock.Monotonic
  UUID
requestId <- IO UUID -> m UUID
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UUID
UUID.V4.nextRandom

  let jsonRequest :: Value
jsonRequest = UUID -> Request -> Value
format UUID
requestId Request
request

  SimpleLogPayload -> m ResponseReceived -> m ResponseReceived
forall i (m :: * -> *) a.
(LogItem i, KatipContext m) =>
i -> m a -> m a
Katip.katipAddContext (Text -> Value -> SimpleLogPayload
forall a. ToJSON a => Text -> a -> SimpleLogPayload
Katip.sl Text
"request" Value
jsonRequest) (m ResponseReceived -> m ResponseReceived)
-> m ResponseReceived -> m ResponseReceived
forall a b. (a -> b) -> a -> b
$ do
    Severity -> LogStr -> m ()
forall (m :: * -> *).
(Applicative m, KatipContext m) =>
Severity -> LogStr -> m ()
Katip.logFM Severity
severity LogStr
"Request received"
    ApplicationT m
application Request
request (Severity
-> TimeSpec
-> (Response -> m ResponseReceived)
-> Response
-> m ResponseReceived
forall (m :: * -> *).
KatipContext m =>
Severity
-> TimeSpec
-> (Response -> m ResponseReceived)
-> Response
-> m ResponseReceived
withLoggedResponse Severity
severity TimeSpec
start Response -> m ResponseReceived
send)


-- | Logs the request, response, and elapsed time in Katip's context
middleware :: Katip.KatipContext m => Katip.Severity -> MiddlewareT m
middleware :: forall (m :: * -> *). KatipContext m => Severity -> MiddlewareT m
middleware =
  (UUID -> Request -> Value) -> Severity -> MiddlewareT m
forall (m :: * -> *).
KatipContext m =>
(UUID -> Request -> Value) -> Severity -> MiddlewareT m
middlewareWithFormatter UUID -> Request -> Value
defaultFormat