{-|
Module      : Gargantext.API.Middleware
Description : 
Copyright   : (c) CNRS, 2017-Present
License     : AGPL + CECILL v3
Maintainer  : team@gargantext.org
Stability   : experimental
Portability : POSIX

-}


{-# LANGUAGE ViewPatterns      #-}

{-| Edit 'sensitiveKeywords' to extend the list of redacted fields. -}
module Gargantext.API.Middleware (
  logStdoutDevSanitised
  ) where

import Control.Lens (Traversal', at, over)
import Control.Monad.Logger (LogStr, toLogStr)
import Data.Aeson qualified as A
import Data.Aeson.Lens qualified as L
import Data.ByteString (ByteString)
import Data.ByteString qualified as BS
import Data.ByteString.Builder qualified as BS
import Data.ByteString.Char8 qualified as C8
import Data.ByteString.Lazy qualified as B
import Data.CaseInsensitive qualified as CI
import Data.List qualified as L
import Data.String (fromString)
import Data.Text qualified as T
import Data.Text.Encoding qualified as TE
import Network.HTTP.Types (QueryItem, Status(..))
import Network.HTTP.Types.Header (Header, hAuthorization, hCookie, hSetCookie)
import Network.Wai (Middleware, queryString, requestMethod, rawPathInfo)
import Network.Wai.Middleware.RequestLogger
import Prelude
import System.Console.ANSI (Color(..), setSGRCode, SGR(..), ConsoleLayer(..), ColorIntensity(..))

-- | Like 'logStdoutDev' from \"wai-extra\", but redacts (or omits altogether) payloads which might have
-- sensitive information
logStdoutDevSanitised :: IO Middleware
logStdoutDevSanitised = mkRequestLogger $ defaultRequestLoggerSettings { outputFormat = CustomOutputFormatWithDetailsAndHeaders customOutput }
-- |
-- Like 'key', but uses 'at' instead of 'ix'. This is handy when
-- adding and removing object keys:
--
-- >>> "{\"a\": 100, \"b\": 200}" & atKey "a" .~ Nothing
-- "{\"b\":200}"
--
-- >>> "{\"a\": 100, \"b\": 200}" & atKey "c" ?~ String "300"
-- "{\"a\":100,\"b\":200,\"c\":\"300\"}"
atKey :: L.AsValue t => T.Text -> Traversal' t (Maybe A.Value)
atKey i = L._Object . at (fromString $ T.unpack i)
{-# INLINE atKey #-}

customOutput :: OutputFormatterWithDetailsAndHeaders
customOutput _zonedDate rq status _mb_response_size request_dur (sanitiseBody . mconcat -> reqbody) raw_response (map sanitiseHeader -> headers) =
  let params = map sanitiseQueryItem (queryString rq)
  in mkRequestLog params reqbody <> mkResponseLog

  where

    mkRequestLog :: [QueryItem] -> ByteString -> LogStr
    mkRequestLog params bdy =
        foldMap toLogStr (ansiMethod' (requestMethod rq))
            <> " "
            <> toLogStr (rawPathInfo rq)
            <> "\n"
            <> foldMap (\(k, mb_v) -> toLogStr $ show (k, mb_v)) params
            <> toLogStr bdy
            <> "\n"
            <> foldMap (\(k, v) -> toLogStr $ mconcat $ ansiColor' White $ "  " <> CI.original k <> ": " <> v <> "\n") headers
            <> "\n"

    mkResponseLog :: LogStr
    mkResponseLog =
      foldMap toLogStr (ansiColor' White "  Status: ")
          <> foldMap toLogStr (ansiStatusCode' status (C8.pack (show $ statusCode status) <> " " <> statusMessage status))
          <> " "
          <> (toLogStr . B.toStrict $ (BS.toLazyByteString raw_response))
          <> " "
          <> "Served in " <> toLogStr (C8.pack $ show $ request_dur)
          <> "\n"

sanitiseBody :: ByteString -> ByteString
sanitiseBody blob = L.foldr (\k acc -> over (atKey k) (updateField k) acc) blob sensitiveKeywords
  where
    updateField :: T.Text -> Maybe A.Value -> Maybe A.Value
    updateField _ Nothing = Nothing
    updateField k (Just x)
      | A.String _v <- x
      , k `elem` sensitiveKeywords
      = Just $ A.String "*****"
      | otherwise
      = Just x

sanitiseQueryItem :: QueryItem -> QueryItem
sanitiseQueryItem (k, mb_v)
  | TE.decodeUtf8 k `elem` sensitiveKeywords
  = (k, (\v -> if C8.null v then mempty else "*****") <$> mb_v)
  | otherwise
  = (k, mb_v)

-- /NOTE:/ Extend this list to filter for more sensitive keywords.
sensitiveKeywords :: [T.Text]
sensitiveKeywords = [
    "password"
  , "api_key"
  , "apiKey"
  , "pubmedAPIKey"
  ]


sanitiseHeader :: Header -> Header
sanitiseHeader (hName, content)
  | hName == hAuthorization = (hName, "*****")
  | hName == hCookie        = (hName, "*****")
  | hName == hSetCookie     = (hName, "*****")
  | otherwise               = (hName, content)

ansiColor' :: Color -> BS.ByteString -> [BS.ByteString]
ansiColor' color bs =
    [ C8.pack $ setSGRCode [SetColor Foreground Dull color]
    , bs
    , C8.pack $ setSGRCode [Reset]
    ]

-- | Tags http method with a unique color.
ansiMethod' :: BS.ByteString -> [BS.ByteString]
ansiMethod' m = case m of
    "GET" -> ansiColor' Cyan m
    "HEAD" -> ansiColor' Cyan m
    "PUT" -> ansiColor' Green m
    "POST" -> ansiColor' Yellow m
    "DELETE" -> ansiColor' Red m
    _ -> ansiColor' Magenta m

ansiStatusCode' :: Status -> ByteString -> [BS.ByteString]
ansiStatusCode' (Status c _) t = case C8.take 1 (C8.pack . show $ c) of
    "2" -> ansiColor' Green t
    "3" -> ansiColor' Yellow t
    "4" -> ansiColor' Red t
    "5" -> ansiColor' Magenta t
    _ -> ansiColor' Blue t