{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE StrictData #-}
module Katip.Wai
(
defaultFormat
, middlewareWithFormatter
, middleware
, 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
, :: Maybe ByteString
, :: Maybe ByteString
, :: Maybe ByteString
, :: 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
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
type ApplicationT m = Wai.Request -> (Wai.Response -> m Wai.ResponseReceived) -> m Wai.ResponseReceived
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)
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
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)
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