{-| Debug utils for server. Simple logger for HTTP requests and responses
Also we can use real logging functions with ***By versions of the logger functions.
Simple variants are only for local testing. It prints to stdout
with no ordering of the concurrent prints.

It can be useful for fast setup of debug for your application. Example of the usage:

> applyPlugin (logHttp V2) server
-}
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

-- | Verbosity level of echo prints
data Verbosity
  = -- | prints nothing
    V0
  | -- | prints time, path query, essential headers
    V1
  | -- | prints V1 + body
    V2
  | -- | prints V2 + all headers
    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 = []

-------------------------------------------------------------------------------------
-- through

-- | Logging of requests and responses
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

-- | Logging of requests and responses with custom logger
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

-------------------------------------------------------------------------------------
-- request

-- | Logs requests
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

-- | Logs requests with custom logger
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

-- | Pretty prints the request
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"

-------------------------------------------------------------------------------------
-- response

-- | Logs response
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

-- | Logs response with custom logger
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

-- | Pretty prints the response
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
.= ()]

-------------------------------------------------------------------------------------
-- utils

-- | Default printer
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 :: HeaderName -> Key
headerName 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