module Katip.Wai.Options
(
Formatter
, TimeUnit (..)
, IncludedHeaders
, defaultIncludedHeaders
, defaultRequestFormat
, defaultResponseFormat
, Options (..)
, addRequestAndResponseToContext
, logRequestAndResponse
, options
, defaultOptions
)
where
import Katip.Wai.Request (Request)
import qualified Katip.Wai.Request as Request
import Katip.Wai.Response (Response)
import qualified Katip.Wai.Response as Response
import qualified Data.Aeson as Aeson
import Data.Bifunctor (bimap)
import Data.ByteString (ByteString)
import qualified Data.CaseInsensitive as CI
import qualified Data.Map.Strict as Map
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Text (Text)
import qualified Data.Text.Encoding as TextEncoding
import qualified Data.Text.Encoding.Error as TextEncodingError
import qualified Data.UUID as UUID
import qualified Katip
import qualified Network.HTTP.Types as HttpTypes
import qualified System.Clock as Clock
type Formatter a = a -> Aeson.Value
data TimeUnit
= Nanoseconds
| Microseconds
| Milliseconds
| Seconds
deriving (Int -> TimeUnit -> ShowS
[TimeUnit] -> ShowS
TimeUnit -> String
(Int -> TimeUnit -> ShowS)
-> (TimeUnit -> String) -> ([TimeUnit] -> ShowS) -> Show TimeUnit
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TimeUnit -> ShowS
showsPrec :: Int -> TimeUnit -> ShowS
$cshow :: TimeUnit -> String
show :: TimeUnit -> String
$cshowList :: [TimeUnit] -> ShowS
showList :: [TimeUnit] -> ShowS
Show, TimeUnit -> TimeUnit -> Bool
(TimeUnit -> TimeUnit -> Bool)
-> (TimeUnit -> TimeUnit -> Bool) -> Eq TimeUnit
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TimeUnit -> TimeUnit -> Bool
== :: TimeUnit -> TimeUnit -> Bool
$c/= :: TimeUnit -> TimeUnit -> Bool
/= :: TimeUnit -> TimeUnit -> Bool
Eq, Eq TimeUnit
Eq TimeUnit =>
(TimeUnit -> TimeUnit -> Ordering)
-> (TimeUnit -> TimeUnit -> Bool)
-> (TimeUnit -> TimeUnit -> Bool)
-> (TimeUnit -> TimeUnit -> Bool)
-> (TimeUnit -> TimeUnit -> Bool)
-> (TimeUnit -> TimeUnit -> TimeUnit)
-> (TimeUnit -> TimeUnit -> TimeUnit)
-> Ord TimeUnit
TimeUnit -> TimeUnit -> Bool
TimeUnit -> TimeUnit -> Ordering
TimeUnit -> TimeUnit -> TimeUnit
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: TimeUnit -> TimeUnit -> Ordering
compare :: TimeUnit -> TimeUnit -> Ordering
$c< :: TimeUnit -> TimeUnit -> Bool
< :: TimeUnit -> TimeUnit -> Bool
$c<= :: TimeUnit -> TimeUnit -> Bool
<= :: TimeUnit -> TimeUnit -> Bool
$c> :: TimeUnit -> TimeUnit -> Bool
> :: TimeUnit -> TimeUnit -> Bool
$c>= :: TimeUnit -> TimeUnit -> Bool
>= :: TimeUnit -> TimeUnit -> Bool
$cmax :: TimeUnit -> TimeUnit -> TimeUnit
max :: TimeUnit -> TimeUnit -> TimeUnit
$cmin :: TimeUnit -> TimeUnit -> TimeUnit
min :: TimeUnit -> TimeUnit -> TimeUnit
Ord, Int -> TimeUnit
TimeUnit -> Int
TimeUnit -> [TimeUnit]
TimeUnit -> TimeUnit
TimeUnit -> TimeUnit -> [TimeUnit]
TimeUnit -> TimeUnit -> TimeUnit -> [TimeUnit]
(TimeUnit -> TimeUnit)
-> (TimeUnit -> TimeUnit)
-> (Int -> TimeUnit)
-> (TimeUnit -> Int)
-> (TimeUnit -> [TimeUnit])
-> (TimeUnit -> TimeUnit -> [TimeUnit])
-> (TimeUnit -> TimeUnit -> [TimeUnit])
-> (TimeUnit -> TimeUnit -> TimeUnit -> [TimeUnit])
-> Enum TimeUnit
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: TimeUnit -> TimeUnit
succ :: TimeUnit -> TimeUnit
$cpred :: TimeUnit -> TimeUnit
pred :: TimeUnit -> TimeUnit
$ctoEnum :: Int -> TimeUnit
toEnum :: Int -> TimeUnit
$cfromEnum :: TimeUnit -> Int
fromEnum :: TimeUnit -> Int
$cenumFrom :: TimeUnit -> [TimeUnit]
enumFrom :: TimeUnit -> [TimeUnit]
$cenumFromThen :: TimeUnit -> TimeUnit -> [TimeUnit]
enumFromThen :: TimeUnit -> TimeUnit -> [TimeUnit]
$cenumFromTo :: TimeUnit -> TimeUnit -> [TimeUnit]
enumFromTo :: TimeUnit -> TimeUnit -> [TimeUnit]
$cenumFromThenTo :: TimeUnit -> TimeUnit -> TimeUnit -> [TimeUnit]
enumFromThenTo :: TimeUnit -> TimeUnit -> TimeUnit -> [TimeUnit]
Enum, TimeUnit
TimeUnit -> TimeUnit -> Bounded TimeUnit
forall a. a -> a -> Bounded a
$cminBound :: TimeUnit
minBound :: TimeUnit
$cmaxBound :: TimeUnit
maxBound :: TimeUnit
Bounded)
type = Set HttpTypes.HeaderName
bsToText :: ByteString -> Text
bsToText :: ByteString -> Text
bsToText =
OnDecodeError -> ByteString -> Text
TextEncoding.decodeUtf8With OnDecodeError
TextEncodingError.lenientDecode
filterHeaders :: IncludedHeaders -> [HttpTypes.Header] -> [HttpTypes.Header]
IncludedHeaders
includedHeaders =
(Header -> Bool) -> [Header] -> [Header]
forall a. (a -> Bool) -> [a] -> [a]
filter ((HeaderName -> IncludedHeaders -> Bool)
-> IncludedHeaders -> HeaderName -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip HeaderName -> IncludedHeaders -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member IncludedHeaders
includedHeaders (HeaderName -> Bool) -> (Header -> HeaderName) -> Header -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Header -> HeaderName
forall a b. (a, b) -> a
fst)
formatHeaders :: [HttpTypes.Header] -> Aeson.Value
[Header]
headers =
Map Text Text -> Value
forall a. ToJSON a => a -> Value
Aeson.toJSON (Map Text Text -> Value)
-> ([(Text, Text)] -> Map Text Text) -> [(Text, Text)] -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Text, Text)] -> Map Text Text
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Text, Text)] -> Value) -> [(Text, Text)] -> Value
forall a b. (a -> b) -> a -> b
$ (Header -> (Text, Text)) -> [Header] -> [(Text, Text)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((HeaderName -> Text)
-> (ByteString -> Text) -> Header -> (Text, Text)
forall a b c d. (a -> b) -> (c -> d) -> (a, c) -> (b, d)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (CI Text -> Text
forall s. CI s -> s
CI.original (CI Text -> Text) -> (HeaderName -> CI Text) -> HeaderName -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> Text) -> HeaderName -> CI Text
forall s2 s1. FoldCase s2 => (s1 -> s2) -> CI s1 -> CI s2
CI.map ByteString -> Text
bsToText) ByteString -> Text
bsToText) [Header]
headers
formatTimeSpec :: TimeUnit -> Clock.TimeSpec -> Aeson.Value
formatTimeSpec :: TimeUnit -> TimeSpec -> Value
formatTimeSpec TimeUnit
timeUnit TimeSpec
timeSpec =
let
(Text
abbreviation, Double
divisor) =
case TimeUnit
timeUnit of
TimeUnit
Nanoseconds -> (Text
"ns" :: Text, Double
1 :: Double)
TimeUnit
Microseconds -> (Text
"μs", Double
1e+3)
TimeUnit
Milliseconds -> (Text
"ms", Double
1e+6)
TimeUnit
Seconds -> (Text
"s", Double
1e+9)
in
[Pair] -> Value
Aeson.object
[ Key
"unit" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
Aeson..= Text
abbreviation
, Key
"time" Key -> Double -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
Aeson..= (Integer -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (TimeSpec -> Integer
Clock.toNanoSecs TimeSpec
timeSpec) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
divisor)
]
defaultIncludedHeaders :: IncludedHeaders
=
[HeaderName] -> IncludedHeaders
forall a. Ord a => [a] -> Set a
Set.fromList
[ HeaderName
"Host"
, HeaderName
"Referer"
, HeaderName
"User-Agent"
, HeaderName
"Range"
]
defaultRequestFormat :: IncludedHeaders -> Formatter Request
defaultRequestFormat :: IncludedHeaders -> Formatter Request
defaultRequestFormat IncludedHeaders
includedHeaders Request
request =
[Pair] -> Value
Aeson.object
[ Key
"id" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
Aeson..= UUID -> Text
UUID.toText (Request -> UUID
Request.traceId Request
request)
, Key
"method" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
Aeson..= ByteString -> Text
bsToText (Request -> ByteString
Request.method Request
request)
, Key
"httpVersion" Key -> String -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
Aeson..= HttpVersion -> String
forall a. Show a => a -> String
show (Request -> HttpVersion
Request.httpVersion Request
request)
, Key
"path" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
Aeson..= ByteString -> Text
bsToText (Request -> ByteString
Request.rawPathInfo Request
request)
, Key
"headers" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
Aeson..= [Header] -> Value
formatHeaders (IncludedHeaders -> [Header] -> [Header]
filterHeaders IncludedHeaders
includedHeaders (Request -> [Header]
Request.requestHeaders Request
request))
, Key
"isSecure" Key -> Bool -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
Aeson..= Request -> Bool
Request.isSecure Request
request
, Key
"remoteHost" Key -> String -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
Aeson..= SockAddr -> String
forall a. Show a => a -> String
show (Request -> SockAddr
Request.remoteHost Request
request)
, Key
"queryString" Key -> [(Text, Maybe Text)] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
Aeson..= ((ByteString, Maybe ByteString) -> (Text, Maybe Text))
-> [(ByteString, Maybe ByteString)] -> [(Text, Maybe Text)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((ByteString -> Text)
-> (Maybe ByteString -> Maybe Text)
-> (ByteString, Maybe ByteString)
-> (Text, Maybe Text)
forall a b c d. (a -> b) -> (c -> d) -> (a, c) -> (b, d)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap ByteString -> Text
bsToText ((ByteString -> Text) -> Maybe ByteString -> Maybe Text
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> Text
bsToText)) (Request -> [(ByteString, Maybe ByteString)]
Request.queryString Request
request)
, Key
"receivedAt" Key -> UTCTime -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
Aeson..= Request -> UTCTime
Request.receivedAt Request
request
]
defaultResponseFormat :: IncludedHeaders -> TimeUnit -> Formatter Response
defaultResponseFormat :: IncludedHeaders -> TimeUnit -> Formatter Response
defaultResponseFormat IncludedHeaders
includedHeaders TimeUnit
timeUnit Response
response =
[Pair] -> Value
Aeson.object
[ Key
"status"
Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
Aeson..= [Pair] -> Value
Aeson.object
[ Key
"code" Key -> Int -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
Aeson..= Status -> Int
HttpTypes.statusCode (Response -> Status
Response.status Response
response)
, Key
"message" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
Aeson..= ByteString -> Text
bsToText (Status -> ByteString
HttpTypes.statusMessage (Response -> Status
Response.status Response
response))
]
, Key
"headers" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
Aeson..= [Header] -> Value
formatHeaders (IncludedHeaders -> [Header] -> [Header]
filterHeaders IncludedHeaders
includedHeaders (Response -> [Header]
Response.responseHeaders Response
response))
, Key
"respondedAt" Key -> UTCTime -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
Aeson..= Response -> UTCTime
Response.respondedAt Response
response
, Key
"responseTime" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
Aeson..= TimeUnit -> TimeSpec -> Value
formatTimeSpec TimeUnit
timeUnit (Response -> TimeSpec
Response.responseTime Response
response)
]
data Options m = Options
{ forall (m :: * -> *). Options m -> forall a. Request -> m a -> m a
handleRequest :: forall a. Request -> m a -> m a
, forall (m :: * -> *). Options m -> forall a. Response -> m a -> m a
handleResponse :: forall a. Response -> m a -> m a
}
addRequestAndResponseToContext :: Katip.KatipContext m => Formatter Request -> Formatter Response -> Options m
addRequestAndResponseToContext :: forall (m :: * -> *).
KatipContext m =>
Formatter Request -> Formatter Response -> Options m
addRequestAndResponseToContext Formatter Request
requestFormatter Formatter Response
responseFormatter =
Options
{ handleRequest :: forall a. Request -> m a -> m a
handleRequest = \Request
request m a
action ->
SimpleLogPayload -> m a -> m a
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" (Formatter Request
requestFormatter Request
request)) (m a -> m a) -> m a -> m a
forall a b. (a -> b) -> a -> b
$ do
m a
action
, handleResponse :: forall a. Response -> m a -> m a
handleResponse = \Response
response m a
action ->
SimpleLogPayload -> m a -> m a
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
"response" (Formatter Response
responseFormatter Response
response)) (m a -> m a) -> m a -> m a
forall a b. (a -> b) -> a -> b
$ do
m a
action
}
logRequestAndResponse :: Katip.KatipContext m => Katip.Severity -> Options m
logRequestAndResponse :: forall (m :: * -> *). KatipContext m => Severity -> Options m
logRequestAndResponse Severity
severity =
Options
{ handleRequest :: forall a. Request -> m a -> m a
handleRequest = \Request
_ m a
action -> do
Severity -> LogStr -> m ()
forall (m :: * -> *).
(Applicative m, KatipContext m) =>
Severity -> LogStr -> m ()
Katip.logFM Severity
severity LogStr
"Request received."
m a
action
, handleResponse :: forall a. Response -> m a -> m a
handleResponse = \Response
_ m a
action -> do
Severity -> LogStr -> m ()
forall (m :: * -> *).
(Applicative m, KatipContext m) =>
Severity -> LogStr -> m ()
Katip.logFM Severity
severity LogStr
"Response sent."
m a
action
}
options :: Katip.KatipContext m => Formatter Request -> Formatter Response -> Katip.Severity -> Options m
options :: forall (m :: * -> *).
KatipContext m =>
Formatter Request -> Formatter Response -> Severity -> Options m
options Formatter Request
requestFormatter Formatter Response
responseFormatter Severity
severity =
[Options m] -> Options m
forall a. Monoid a => [a] -> a
mconcat
[ Formatter Request -> Formatter Response -> Options m
forall (m :: * -> *).
KatipContext m =>
Formatter Request -> Formatter Response -> Options m
addRequestAndResponseToContext
Formatter Request
requestFormatter
Formatter Response
responseFormatter
, Severity -> Options m
forall (m :: * -> *). KatipContext m => Severity -> Options m
logRequestAndResponse Severity
severity
]
defaultOptions :: Katip.KatipContext m => Katip.Severity -> Options m
defaultOptions :: forall (m :: * -> *). KatipContext m => Severity -> Options m
defaultOptions =
Formatter Request -> Formatter Response -> Severity -> Options m
forall (m :: * -> *).
KatipContext m =>
Formatter Request -> Formatter Response -> Severity -> Options m
options
(IncludedHeaders -> Formatter Request
defaultRequestFormat IncludedHeaders
defaultIncludedHeaders)
(IncludedHeaders -> TimeUnit -> Formatter Response
defaultResponseFormat IncludedHeaders
defaultIncludedHeaders TimeUnit
Milliseconds)
instance Semigroup (Options m) where
Options m
a <> :: Options m -> Options m -> Options m
<> Options m
b =
Options
{ handleRequest :: forall a. Request -> m a -> m a
handleRequest = \Request
request m a
action ->
Options m -> forall a. Request -> m a -> m a
forall (m :: * -> *). Options m -> forall a. Request -> m a -> m a
handleRequest Options m
a Request
request (m a -> m a) -> m a -> m a
forall a b. (a -> b) -> a -> b
$ Options m -> forall a. Request -> m a -> m a
forall (m :: * -> *). Options m -> forall a. Request -> m a -> m a
handleRequest Options m
b Request
request m a
action
, handleResponse :: forall a. Response -> m a -> m a
handleResponse = \Response
response m a
action ->
Options m -> forall a. Response -> m a -> m a
forall (m :: * -> *). Options m -> forall a. Response -> m a -> m a
handleResponse Options m
a Response
response (m a -> m a) -> m a -> m a
forall a b. (a -> b) -> a -> b
$ Options m -> forall a. Response -> m a -> m a
forall (m :: * -> *). Options m -> forall a. Response -> m a -> m a
handleResponse Options m
b Response
response m a
action
}
instance Monoid (Options m) where
mempty :: Options m
mempty =
Options
{ handleRequest :: forall a. Request -> m a -> m a
handleRequest = (m a -> m a) -> Request -> m a -> m a
forall a b. a -> b -> a
const m a -> m a
forall a. a -> a
id
, handleResponse :: forall a. Response -> m a -> m a
handleResponse = (m a -> m a) -> Response -> m a -> m a
forall a b. a -> b -> a
const m a -> m a
forall a. a -> a
id
}