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


requestToKeyValues :: Aeson.KeyValue kv => Request -> [kv]
requestToKeyValues :: Request -> [kv]
requestToKeyValues Request{Bool
Query
[Text]
Maybe Method
Method
HttpVersion
SockAddr
UUID
RequestBodyLength
requestHeaderRange :: Maybe Method
requestHeaderUserAgent :: Maybe Method
requestHeaderReferer :: Maybe Method
requestHeaderHost :: Maybe Method
requestBodyLength :: RequestBodyLength
requestQueryString :: Query
requestPathInfo :: [Text]
requestMethod :: Method
requestIsSecure :: Bool
requestRemoteHost :: SockAddr
requestHttpVersion :: HttpVersion
requestId :: UUID
requestHeaderRange :: Request -> Maybe Method
requestHeaderUserAgent :: Request -> Maybe Method
requestHeaderReferer :: Request -> Maybe Method
requestHeaderHost :: Request -> Maybe Method
requestBodyLength :: Request -> RequestBodyLength
requestQueryString :: Request -> Query
requestPathInfo :: Request -> [Text]
requestMethod :: Request -> Method
requestIsSecure :: Request -> Bool
requestRemoteHost :: Request -> SockAddr
requestHttpVersion :: Request -> HttpVersion
requestId :: Request -> UUID
..} =
  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 kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= (Method -> Text) -> Maybe Method -> Maybe Text
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 kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= (Method -> Text) -> Maybe Method -> Maybe Text
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 kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= (Method -> Text) -> Maybe Method -> Maybe Text
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 kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= (Method -> Text) -> Maybe Method -> Maybe Text
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 kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= UUID -> Text
UUID.toText UUID
requestId
      , Key
"httpVersion" Key -> String -> kv
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= HttpVersion -> String
forall a. Show a => a -> String
show HttpVersion
requestHttpVersion
      , Key
"remoteHost" Key -> String -> kv
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= SockAddr -> String
forall a. Show a => a -> String
show SockAddr
requestRemoteHost
      , Key
"isSecure" Key -> Bool -> kv
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Bool
requestIsSecure
      , Key
"method" Key -> Text -> kv
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Method -> Text
toText Method
requestMethod
      , Key
"path" Key -> Text -> kv
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text -> [Text] -> Text
Text.intercalate Text
"/" [Text]
requestPathInfo
      , Key
"queryString" Key -> QueryText -> kv
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Query -> QueryText
queryToQueryText Query
requestQueryString
      , Key
"bodyLength" Key -> String -> kv
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= RequestBodyLength -> String
forall a. Show a => a -> String
show RequestBodyLength
requestBodyLength
      , Key
"headers" Key -> Value -> kv
forall kv v. (KeyValue 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 kv. KeyValue 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 kv. KeyValue 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 :: UUID
-> HttpVersion
-> SockAddr
-> Bool
-> Method
-> [Text]
-> Query
-> RequestBodyLength
-> Maybe Method
-> Maybe Method
-> Maybe Method
-> Maybe Method
-> Request
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
  }


responseToKeyValues :: Aeson.KeyValue kv => Response -> [kv]
responseToKeyValues :: Response -> [kv]
responseToKeyValues Response{TimeSpec
Status
responseStatus :: Status
responseElapsedTime :: TimeSpec
responseStatus :: Response -> Status
responseElapsedTime :: Response -> TimeSpec
..} =
  [ Key
"elapsedTimeInNanoSeconds" Key -> Integer -> kv
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= TimeSpec -> Integer
Clock.toNanoSecs TimeSpec
responseElapsedTime
  , Key
"status" Key -> Int -> kv
forall kv v. (KeyValue 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 kv. KeyValue 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 kv. KeyValue 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 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 (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 :: 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 (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 :: TimeSpec -> Status -> Response
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 (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 :: (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 (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 (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 :: 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