module Mig.Extra.Plugin.Trace (
logReq,
logResp,
logReqBy,
logRespBy,
logHttp,
logHttpBy,
ppReq,
Verbosity (..),
) where
import Control.Monad
import Control.Monad.IO.Class
import Data.Aeson ((.=))
import Data.Aeson qualified as Json
import Data.Aeson.Key qualified as Json
import Data.ByteString (ByteString)
import Data.ByteString.Char8 qualified as B
import Data.ByteString.Lazy.Char8 qualified as BL
import Data.CaseInsensitive (CI)
import Data.CaseInsensitive qualified as CI
import Data.Map.Strict qualified as Map
import Data.String
import Data.Text (Text)
import Data.Text.Encoding qualified as Text
import Data.Time
import Data.Yaml qualified as Yaml
import Network.HTTP.Media.RenderHeader (renderHeader)
import Network.HTTP.Types.Status (Status (..))
import System.Time.Extra
import Mig.Core
data Verbosity
=
V0
|
V1
|
V2
|
V3
deriving (Verbosity -> Verbosity -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Verbosity -> Verbosity -> Bool
$c/= :: Verbosity -> Verbosity -> Bool
== :: Verbosity -> Verbosity -> Bool
$c== :: Verbosity -> Verbosity -> Bool
Eq, Eq Verbosity
Verbosity -> Verbosity -> Bool
Verbosity -> Verbosity -> Ordering
Verbosity -> Verbosity -> Verbosity
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
min :: Verbosity -> Verbosity -> Verbosity
$cmin :: Verbosity -> Verbosity -> Verbosity
max :: Verbosity -> Verbosity -> Verbosity
$cmax :: Verbosity -> Verbosity -> Verbosity
>= :: Verbosity -> Verbosity -> Bool
$c>= :: Verbosity -> Verbosity -> Bool
> :: Verbosity -> Verbosity -> Bool
$c> :: Verbosity -> Verbosity -> Bool
<= :: Verbosity -> Verbosity -> Bool
$c<= :: Verbosity -> Verbosity -> Bool
< :: Verbosity -> Verbosity -> Bool
$c< :: Verbosity -> Verbosity -> Bool
compare :: Verbosity -> Verbosity -> Ordering
$ccompare :: Verbosity -> Verbosity -> Ordering
Ord, Int -> Verbosity -> ShowS
[Verbosity] -> ShowS
Verbosity -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Verbosity] -> ShowS
$cshowList :: [Verbosity] -> ShowS
show :: Verbosity -> String
$cshow :: Verbosity -> String
showsPrec :: Int -> Verbosity -> ShowS
$cshowsPrec :: Int -> Verbosity -> ShowS
Show)
ifLevel :: Verbosity -> Verbosity -> [a] -> [a]
ifLevel :: forall a. Verbosity -> Verbosity -> [a] -> [a]
ifLevel Verbosity
current Verbosity
level [a]
vals
| Verbosity
level forall a. Ord a => a -> a -> Bool
<= Verbosity
current = [a]
vals
| Bool
otherwise = []
logHttp :: (MonadIO m) => Verbosity -> Plugin m
logHttp :: forall (m :: * -> *). MonadIO m => Verbosity -> Plugin m
logHttp Verbosity
verbosity = forall (m :: * -> *). MonadIO m => Verbosity -> Plugin m
logResp Verbosity
verbosity forall a. Semigroup a => a -> a -> a
<> forall (m :: * -> *). MonadIO m => Verbosity -> Plugin m
logReq Verbosity
verbosity
logHttpBy :: (MonadIO m) => (Json.Value -> m ()) -> Verbosity -> Plugin m
logHttpBy :: forall (m :: * -> *).
MonadIO m =>
(Value -> m ()) -> Verbosity -> Plugin m
logHttpBy Value -> m ()
printer Verbosity
verbosity = forall (m :: * -> *).
MonadIO m =>
(Value -> m ()) -> Verbosity -> Plugin m
logRespBy Value -> m ()
printer Verbosity
verbosity forall a. Semigroup a => a -> a -> a
<> forall (m :: * -> *).
MonadIO m =>
(Value -> m ()) -> Verbosity -> Plugin m
logReqBy Value -> m ()
printer Verbosity
verbosity
logReq :: (MonadIO m) => Verbosity -> Plugin m
logReq :: forall (m :: * -> *). MonadIO m => Verbosity -> Plugin m
logReq = forall (m :: * -> *).
MonadIO m =>
(Value -> m ()) -> Verbosity -> Plugin m
logReqBy forall (m :: * -> *). MonadIO m => Value -> m ()
defaultPrinter
logReqBy :: (MonadIO m) => (Json.Value -> m ()) -> Verbosity -> Plugin m
logReqBy :: forall (m :: * -> *).
MonadIO m =>
(Value -> m ()) -> Verbosity -> Plugin m
logReqBy Value -> m ()
printer Verbosity
verbosity = forall f. ToPlugin f => f -> Plugin (MonadOf f)
toPlugin forall a b. (a -> b) -> a -> b
$ \(RawRequest Request
req) -> forall (m :: * -> *). MonadIO m => m () -> Plugin m
prependServerAction forall a b. (a -> b) -> a -> b
$ do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Verbosity
verbosity forall a. Ord a => a -> a -> Bool
> Verbosity
V0) forall a b. (a -> b) -> a -> b
$ do
Value
reqTrace <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
Either Text ByteString
eBody <- Request
req.readBody
UTCTime
now <- IO UTCTime
getCurrentTime
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Verbosity
-> Maybe UTCTime -> Either Text ByteString -> Request -> Value
ppReq Verbosity
verbosity (forall a. a -> Maybe a
Just UTCTime
now) Either Text ByteString
eBody Request
req
Value -> m ()
printer Value
reqTrace
ppReq :: Verbosity -> Maybe UTCTime -> Either Text BL.ByteString -> Request -> Json.Value
ppReq :: Verbosity
-> Maybe UTCTime -> Either Text ByteString -> Request -> Value
ppReq Verbosity
verbosity Maybe UTCTime
now Either Text ByteString
body Request
req =
[Pair] -> Value
Json.object forall a b. (a -> b) -> a -> b
$
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$
[ forall a. Verbosity -> Verbosity -> [a] -> [a]
ifLevel Verbosity
verbosity Verbosity
V1 forall a b. (a -> b) -> a -> b
$
forall a. Monoid a => [a] -> a
mconcat
[ forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Key
"time" .=)) Maybe UTCTime
now
,
[ Key
"type" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (Text
"http-request" :: Text)
, Key
"path" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Request -> Text
toFullPath Request
req
, Key
"method" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ByteString -> Text
Text.decodeUtf8 (forall h. RenderHeader h => h -> ByteString
renderHeader Request
req.method)
]
]
, forall a. Verbosity -> Verbosity -> [a] -> [a]
ifLevel
Verbosity
verbosity
Verbosity
V2
[ Key
"body" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Either Text ByteString -> Value
fromBody Either Text ByteString
body
]
, [Key
"headers" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Map HeaderName ByteString -> Value
fromHeaders Request
req.headers]
]
where
fromHeaders :: Map HeaderName ByteString -> Value
fromHeaders Map HeaderName ByteString
headers = [Pair] -> Value
Json.object forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall {e} {kv}. KeyValue e kv => (HeaderName, ByteString) -> kv
go forall a b. (a -> b) -> a -> b
$ [(HeaderName, ByteString)] -> [(HeaderName, ByteString)]
onVerbosity forall a b. (a -> b) -> a -> b
$ (forall k a. Map k a -> [(k, a)]
Map.toList Map HeaderName ByteString
headers)
where
go :: (HeaderName, ByteString) -> kv
go (HeaderName
name, ByteString
val) =
HeaderName -> Key
headerName HeaderName
name forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ByteString -> Text
Text.decodeUtf8 ByteString
val
onVerbosity :: [(HeaderName, ByteString)] -> [(HeaderName, ByteString)]
onVerbosity
| Verbosity
verbosity forall a. Ord a => a -> a -> Bool
< Verbosity
V3 = forall a. (a -> Bool) -> [a] -> [a]
filter ((\HeaderName
name -> HeaderName
name forall a. Eq a => a -> a -> Bool
== HeaderName
"Accept" Bool -> Bool -> Bool
|| HeaderName
name forall a. Eq a => a -> a -> Bool
== HeaderName
"Content-Type") forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst)
| Bool
otherwise = forall a. a -> a
id
fromBody :: Either Text BL.ByteString -> Json.Value
fromBody :: Either Text ByteString -> Value
fromBody
| Bool
isJsonReq = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Text -> Value
Json.String ByteString -> Value
jsonBody
| Bool
otherwise = Text -> Value
Json.String forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. a -> a
id (ByteString -> Text
Text.decodeUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BL.toStrict)
isJsonReq :: Bool
isJsonReq = forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup HeaderName
"Content-Type" Request
req.headers forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just ByteString
"application/json"
logResp :: (MonadIO m) => Verbosity -> Plugin m
logResp :: forall (m :: * -> *). MonadIO m => Verbosity -> Plugin m
logResp = forall (m :: * -> *).
MonadIO m =>
(Value -> m ()) -> Verbosity -> Plugin m
logRespBy forall (m :: * -> *). MonadIO m => Value -> m ()
defaultPrinter
logRespBy :: forall m. (MonadIO m) => (Json.Value -> m ()) -> Verbosity -> Plugin m
logRespBy :: forall (m :: * -> *).
MonadIO m =>
(Value -> m ()) -> Verbosity -> Plugin m
logRespBy Value -> m ()
printer Verbosity
verbosity = forall f. ToPlugin f => f -> Plugin (MonadOf f)
toPlugin PluginFun m
go
where
go :: PluginFun m
go :: PluginFun m
go = \ServerFun m
f -> \Request
req -> do
(Seconds
dur, Maybe Response
resp) <- forall (m :: * -> *) a. MonadIO m => m a -> m (Seconds, a)
duration (ServerFun m
f Request
req)
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Verbosity
verbosity forall a. Ord a => a -> a -> Bool
> Verbosity
V0) forall a b. (a -> b) -> a -> b
$ do
UTCTime
now <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Value -> m ()
printer forall b c a. (b -> c) -> (a -> b) -> a -> c
. Verbosity -> UTCTime -> Seconds -> Request -> Response -> Value
ppResp Verbosity
verbosity UTCTime
now Seconds
dur Request
req) Maybe Response
resp
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Response
resp
ppResp :: Verbosity -> UTCTime -> Seconds -> Request -> Response -> Json.Value
ppResp :: Verbosity -> UTCTime -> Seconds -> Request -> Response -> Value
ppResp Verbosity
verbosity UTCTime
now Seconds
dur Request
req Response
resp =
[Pair] -> Value
Json.object forall a b. (a -> b) -> a -> b
$
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ forall a. Verbosity -> Verbosity -> [a] -> [a]
ifLevel
Verbosity
verbosity
Verbosity
V1
[ Key
"time" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= UTCTime
now
, Key
"duration" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Seconds
dur
, Key
"type" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (Text
"http-response" :: Text)
, Key
"path" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Request -> Text
toFullPath Request
req
, Key
"status" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Response
resp.status.statusCode
, Key
"method" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ByteString -> Text
Text.decodeUtf8 (forall h. RenderHeader h => h -> ByteString
renderHeader Request
req.method)
]
, forall a. Verbosity -> Verbosity -> [a] -> [a]
ifLevel
Verbosity
verbosity
Verbosity
V2
[Key
"body" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ResponseBody -> Value
fromBody Response
resp.body]
, [Key
"headers" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [(HeaderName, ByteString)] -> Value
fromHeaders Response
resp.headers]
]
where
fromHeaders :: [(HeaderName, ByteString)] -> Value
fromHeaders [(HeaderName, ByteString)]
headers = [Pair] -> Value
Json.object forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall {e} {kv}. KeyValue e kv => (HeaderName, ByteString) -> kv
go forall a b. (a -> b) -> a -> b
$ [(HeaderName, ByteString)]
headers
where
go :: (HeaderName, ByteString) -> kv
go (HeaderName
name, ByteString
val) = HeaderName -> Key
headerName HeaderName
name forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ByteString -> Text
Text.decodeUtf8 ByteString
val
fromBody :: ResponseBody -> Value
fromBody = \case
RawResp MediaType
mediaType ByteString
bs | MediaType
mediaType forall a. Eq a => a -> a -> Bool
== MediaType
"application/json" -> ByteString -> Value
jsonBody ByteString
bs
RawResp MediaType
_ ByteString
bs -> Text -> Value
Json.String forall a b. (a -> b) -> a -> b
$ ByteString -> Text
Text.decodeUtf8 (ByteString -> ByteString
BL.toStrict ByteString
bs)
FileResp String
file -> [Pair] -> Value
Json.object [Key
"file" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= String
file]
ResponseBody
StreamResp -> [Pair] -> Value
Json.object [Key
"stream" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ()]
defaultPrinter :: (MonadIO m) => Json.Value -> m ()
defaultPrinter :: forall (m :: * -> *). MonadIO m => Value -> m ()
defaultPrinter =
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> IO ()
B.putStrLn forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToJSON a => a -> ByteString
Yaml.encode forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Value
addLogPrefix
addLogPrefix :: Json.Value -> Json.Value
addLogPrefix :: Value -> Value
addLogPrefix Value
val = [Pair] -> Value
Json.object [Key
"log" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Value
val]
headerName :: CI ByteString -> Json.Key
HeaderName
name = Text -> Key
Json.fromText (ByteString -> Text
Text.decodeUtf8 forall a b. (a -> b) -> a -> b
$ forall s. CI s -> s
CI.foldedCase HeaderName
name)
jsonBody :: BL.ByteString -> Json.Value
jsonBody :: ByteString -> Value
jsonBody =
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. IsString a => String -> a
fromString forall a. a -> a
id forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. FromJSON a => ByteString -> Either String a
Json.eitherDecode