content: {-| 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 (..),
    withLogs,
    withLogsBy,
  ) 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 (Eq, Ord, Show)
  
  ifLevel :: Verbosity -> Verbosity -> [a] -> [a]
  ifLevel current level vals
    | level <= current = vals
    | otherwise = []
  
  withLogs :: (MonadIO m) => Server m -> Server m
  withLogs = applyPlugin (logHttp V2)
  
  withLogsBy :: (MonadIO m) => (Json.Value -> m ()) -> Server m -> Server m
  withLogsBy toLogItem = applyPlugin (logHttpBy toLogItem V2)
  
  -------------------------------------------------------------------------------------
  -- through
  
  -- | Logging of requests and responses
  logHttp :: (MonadIO m) => Verbosity -> Plugin m
  logHttp verbosity = logResp verbosity <> logReq verbosity
  
  -- | Logging of requests and responses with custom logger
  logHttpBy :: (MonadIO m) => (Json.Value -> m ()) -> Verbosity -> Plugin m
  logHttpBy printer verbosity = logRespBy printer verbosity <> logReqBy printer verbosity
  
  -------------------------------------------------------------------------------------
  -- request
  
  -- | Logs requests
  logReq :: (MonadIO m) => Verbosity -> Plugin m
  logReq = logReqBy defaultPrinter
  
  -- | Logs requests with custom logger
  logReqBy :: (MonadIO m) => (Json.Value -> m ()) -> Verbosity -> Plugin m
  logReqBy printer verbosity = toPlugin $ \(RawRequest req) -> prependServerAction $ do
    when (verbosity > V0) $ do
      reqTrace <- liftIO $ do
        eBody <- req.readBody
        now <- getCurrentTime
        pure $ ppReq verbosity (Just now) eBody req
      printer reqTrace
  
  -- | Pretty prints the request
  ppReq :: Verbosity -> Maybe UTCTime -> Either Text BL.ByteString -> Request -> Json.Value
  ppReq verbosity now body req =
    Json.object $
      concat $
        [ ifLevel verbosity V1 $
            mconcat
              [ maybe [] (pure . ("time" .=)) now
              ,
                [ "type" .= ("http-request" :: Text)
                , "path" .= toFullPath req
                , "method" .= Text.decodeUtf8 (renderHeader req.method)
                ]
              ]
        , ifLevel
            verbosity
            V2
            [ "body" .= fromBody body
            ]
        , ["headers" .= fromHeaders req.headers]
        ]
    where
      fromHeaders headers = Json.object $ fmap go $ onVerbosity $ (Map.toList headers)
        where
          go (name, val) =
            headerName name .= Text.decodeUtf8 val
  
          onVerbosity
            | verbosity < V3 = filter ((\name -> name == "Accept" || name == "Content-Type") . fst)
            | otherwise = id
  
      fromBody :: Either Text BL.ByteString -> Json.Value
      fromBody
        | isJsonReq = either Json.String jsonBody
        | otherwise = Json.String . either id (Text.decodeUtf8 . BL.toStrict)
  
      isJsonReq = Map.lookup "Content-Type" req.headers == Just "application/json"
  
  -------------------------------------------------------------------------------------
  -- response
  
  -- | Logs response
  logResp :: (MonadIO m) => Verbosity -> Plugin m
  logResp = logRespBy defaultPrinter
  
  -- | Logs response with custom logger
  logRespBy :: forall m. (MonadIO m) => (Json.Value -> m ()) -> Verbosity -> Plugin m
  logRespBy printer verbosity = toPlugin go
    where
      go :: PluginFun m
      go = \f -> \req -> do
        (dur, resp) <- duration (f req)
        when (verbosity > V0) $ do
          now <- liftIO getCurrentTime
          mapM_ (printer . ppResp verbosity now dur req) resp
        pure resp
  
  -- | Pretty prints the response
  ppResp :: Verbosity -> UTCTime -> Seconds -> Request -> Response -> Json.Value
  ppResp verbosity now dur req resp =
    Json.object $
      concat
        [ ifLevel
            verbosity
            V1
            [ "time" .= now
            , "duration" .= dur
            , "type" .= ("http-response" :: Text)
            , "path" .= toFullPath req
            , "status" .= resp.status.statusCode
            , "method" .= Text.decodeUtf8 (renderHeader req.method)
            ]
        , ifLevel
            verbosity
            V2
            ["body" .= fromBody resp.body]
        , ["headers" .= fromHeaders resp.headers]
        ]
    where
      fromHeaders headers = Json.object $ fmap go $ headers
        where
          go (name, val) = headerName name .= Text.decodeUtf8 val
  
      fromBody = \case
        RawResp mediaType bs | mediaType == "application/json" -> jsonBody bs
        RawResp _ bs -> Json.String $ Text.decodeUtf8 (BL.toStrict bs)
        FileResp file -> Json.object ["file" .= file]
        StreamResp -> Json.object ["stream" .= ()]
  
  -------------------------------------------------------------------------------------
  -- utils
  
  -- | Default printer
  defaultPrinter :: (MonadIO m) => Json.Value -> m ()
  defaultPrinter =
    liftIO . B.putStrLn . Yaml.encode . addLogPrefix
  
  addLogPrefix :: Json.Value -> Json.Value
  addLogPrefix val = Json.object ["log" .= val]
  
  headerName :: CI ByteString -> Json.Key
  headerName name = Json.fromText (Text.decodeUtf8 $ CI.foldedCase name)
  
  jsonBody :: BL.ByteString -> Json.Value
  jsonBody =
    either fromString id . Json.eitherDecode
  