{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}

-- The following is justified by the usage of the 'requestBody' field
-- accessor on the 'Request' object from the Network.Wai.Internal module.
--
-- The deprecation is about not using the function to get the requestBody from
-- a request since it only returns chunks, but we do use it
{-# OPTIONS_GHC -fno-warn-deprecations #-}

module Network.Wai.Middleware.Logging
    ( -- * Middleware
      withApiLogger

      -- * Settings
    , newApiLoggerSettings
    , ApiLoggerSettings
    , obfuscateKeys
    , HandlerLog (..)
    , ApiLog (..)
    , RequestId (..)
    ) where

import Prelude

import Cardano.BM.Data.LogItem
    ( PrivacyAnnotation (..) )
import Cardano.BM.Data.Severity
    ( Severity (..) )
import Cardano.BM.Data.Tracer
    ( HasPrivacyAnnotation (..), HasSeverityAnnotation (..) )
import Cardano.BM.Tracing
    ( ToObject )
import Control.Applicative
    ( (<|>) )
import Control.Arrow
    ( second )
import Control.Tracer
    ( Tracer, contramap, traceWith )
import Data.Aeson
    ( FromJSON (..), ToJSON (..), Value (..) )
import Data.ByteString
    ( ByteString )
import Data.ByteString.Builder
    ( Builder )
import Data.IORef
    ( IORef, atomicModifyIORef, modifyIORef, newIORef, readIORef )
import Data.Text
    ( Text )
import Data.Text.Class
    ( ToText (..) )
import Data.Time.Clock
    ( NominalDiffTime, diffUTCTime, getCurrentTime )
import GHC.Generics
    ( Generic )
import Network.HTTP.Types.Status
    ( Status (..) )
import Network.Wai
    ( Middleware, Request (..), rawPathInfo, rawQueryString, requestMethod )
import Network.Wai.Internal
    ( Response (..), getRequestBodyChunk )
import UnliftIO.MVar
    ( MVar, modifyMVar, newMVar )

import qualified Data.Aeson as Aeson
import qualified Data.Aeson.Key as Aeson
import qualified Data.Aeson.KeyMap as Aeson
import qualified Data.ByteString as BS
import qualified Data.ByteString.Builder as B
import qualified Data.ByteString.Lazy as BL
import qualified Data.HashMap.Strict as HM
import qualified Data.Text as T
import qualified Data.Text.Encoding as T

-- | Installs a request & response logger on a Wai application.
--
-- The logger logs requests' and responses' bodies along with a few other
-- useful piece of information.
withApiLogger
    :: Tracer IO ApiLog
    -> ApiLoggerSettings
    -> Middleware
withApiLogger :: Tracer IO ApiLog -> ApiLoggerSettings -> Middleware
withApiLogger Tracer IO ApiLog
t0 ApiLoggerSettings
settings Application
app Request
req0 Response -> IO ResponseReceived
sendResponse = do
    RequestId
rid <- ApiLoggerSettings -> IO RequestId
nextRequestId ApiLoggerSettings
settings
    let t :: Tracer IO HandlerLog
t = (HandlerLog -> ApiLog) -> Tracer IO ApiLog -> Tracer IO HandlerLog
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap (RequestId -> HandlerLog -> ApiLog
ApiLog RequestId
rid) Tracer IO ApiLog
t0
    Tracer IO HandlerLog -> HandlerLog -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO HandlerLog
t HandlerLog
LogRequestStart
    UTCTime
start <- IO UTCTime
getCurrentTime
    (Request
req, ByteString
reqBody) <- Request -> IO (Request, ByteString)
getRequestBody Request
req0
    Tracer IO HandlerLog -> HandlerLog -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO HandlerLog
t (Request -> HandlerLog
LogRequest Request
req)
    Tracer IO HandlerLog -> HandlerLog -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO HandlerLog
t ([Text] -> ByteString -> HandlerLog
LogRequestBody (ApiLoggerSettings -> Request -> [Text]
_obfuscateKeys ApiLoggerSettings
settings Request
req) ByteString
reqBody)
    Application
app Request
req ((Response -> IO ResponseReceived) -> IO ResponseReceived)
-> (Response -> IO ResponseReceived) -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ \Response
res -> do
        IORef (Maybe Status, Builder)
builderIO <- (Maybe Status, Builder) -> IO (IORef (Maybe Status, Builder))
forall a. a -> IO (IORef a)
newIORef (Maybe Status
forall a. Maybe a
Nothing, Builder
forall a. Monoid a => a
mempty)
        ResponseReceived
rcvd <- IORef (Maybe Status, Builder) -> Response -> IO Response
recordChunks IORef (Maybe Status, Builder)
builderIO Response
res IO Response
-> (Response -> IO ResponseReceived) -> IO ResponseReceived
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Response -> IO ResponseReceived
sendResponse
        NominalDiffTime
time <- (UTCTime -> UTCTime -> NominalDiffTime)
-> UTCTime -> UTCTime -> NominalDiffTime
forall a b c. (a -> b -> c) -> b -> a -> c
flip UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
start (UTCTime -> NominalDiffTime) -> IO UTCTime -> IO NominalDiffTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO UTCTime
getCurrentTime
        IORef (Maybe Status, Builder) -> IO (Maybe Status, Builder)
forall a. IORef a -> IO a
readIORef IORef (Maybe Status, Builder)
builderIO IO (Maybe Status, Builder)
-> ((Maybe Status, Builder) -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
            let fromBuilder :: (d, Builder) -> (d, ByteString)
fromBuilder = (Builder -> ByteString) -> (d, Builder) -> (d, ByteString)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (ByteString -> ByteString
BL.toStrict (ByteString -> ByteString)
-> (Builder -> ByteString) -> Builder -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> ByteString
B.toLazyByteString)
            in (Maybe Status -> ByteString -> IO ())
-> (Maybe Status, ByteString) -> IO ()
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (Tracer IO HandlerLog
-> NominalDiffTime
-> Request
-> Maybe Status
-> ByteString
-> IO ()
logResponse Tracer IO HandlerLog
t NominalDiffTime
time Request
req) ((Maybe Status, ByteString) -> IO ())
-> ((Maybe Status, Builder) -> (Maybe Status, ByteString))
-> (Maybe Status, Builder)
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe Status, Builder) -> (Maybe Status, ByteString)
forall d. (d, Builder) -> (d, ByteString)
fromBuilder
        Tracer IO HandlerLog -> HandlerLog -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO HandlerLog
t HandlerLog
LogRequestFinish
        ResponseReceived -> IO ResponseReceived
forall (m :: * -> *) a. Monad m => a -> m a
return ResponseReceived
rcvd
  where
    logResponse
        :: Tracer IO HandlerLog
        -> NominalDiffTime
        -> Request
        -> Maybe Status
        -> ByteString
        -> IO ()
    logResponse :: Tracer IO HandlerLog
-> NominalDiffTime
-> Request
-> Maybe Status
-> ByteString
-> IO ()
logResponse Tracer IO HandlerLog
t NominalDiffTime
time Request
req Maybe Status
status ByteString
body = do
        Tracer IO HandlerLog -> HandlerLog -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO HandlerLog
t (NominalDiffTime -> Request -> Maybe Status -> HandlerLog
LogResponse NominalDiffTime
time Request
req Maybe Status
status)
        Tracer IO HandlerLog -> HandlerLog -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO HandlerLog
t (ByteString -> HandlerLog
LogResponseBody ByteString
body)

-- | API logger settings
data ApiLoggerSettings = ApiLoggerSettings
    { ApiLoggerSettings -> Request -> [Text]
_obfuscateKeys :: Request -> [Text]
        -- ^ For a given 'Request', obfuscate the values associated with the
        -- given keys from a JSON object payload.

    , ApiLoggerSettings -> MVar Integer
_requestCounter :: MVar Integer
        -- ^ A function to get a unique identifier from a 'Request'
    }

-- | Just a wrapper for readability
newtype RequestId = RequestId Integer
    deriving ((forall x. RequestId -> Rep RequestId x)
-> (forall x. Rep RequestId x -> RequestId) -> Generic RequestId
forall x. Rep RequestId x -> RequestId
forall x. RequestId -> Rep RequestId x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep RequestId x -> RequestId
$cfrom :: forall x. RequestId -> Rep RequestId x
Generic, Int -> RequestId -> ShowS
[RequestId] -> ShowS
RequestId -> String
(Int -> RequestId -> ShowS)
-> (RequestId -> String)
-> ([RequestId] -> ShowS)
-> Show RequestId
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RequestId] -> ShowS
$cshowList :: [RequestId] -> ShowS
show :: RequestId -> String
$cshow :: RequestId -> String
showsPrec :: Int -> RequestId -> ShowS
$cshowsPrec :: Int -> RequestId -> ShowS
Show, RequestId -> RequestId -> Bool
(RequestId -> RequestId -> Bool)
-> (RequestId -> RequestId -> Bool) -> Eq RequestId
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RequestId -> RequestId -> Bool
$c/= :: RequestId -> RequestId -> Bool
== :: RequestId -> RequestId -> Bool
$c== :: RequestId -> RequestId -> Bool
Eq, [RequestId] -> Encoding
[RequestId] -> Value
RequestId -> Encoding
RequestId -> Value
(RequestId -> Value)
-> (RequestId -> Encoding)
-> ([RequestId] -> Value)
-> ([RequestId] -> Encoding)
-> ToJSON RequestId
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [RequestId] -> Encoding
$ctoEncodingList :: [RequestId] -> Encoding
toJSONList :: [RequestId] -> Value
$ctoJSONList :: [RequestId] -> Value
toEncoding :: RequestId -> Encoding
$ctoEncoding :: RequestId -> Encoding
toJSON :: RequestId -> Value
$ctoJSON :: RequestId -> Value
ToJSON)

-- | Create a new opaque 'ApiLoggerSettings'
newApiLoggerSettings :: IO ApiLoggerSettings
newApiLoggerSettings :: IO ApiLoggerSettings
newApiLoggerSettings = do
    MVar Integer
counter <- Integer -> IO (MVar Integer)
forall (m :: * -> *) a. MonadIO m => a -> m (MVar a)
newMVar Integer
0
    ApiLoggerSettings -> IO ApiLoggerSettings
forall (m :: * -> *) a. Monad m => a -> m a
return ApiLoggerSettings :: (Request -> [Text]) -> MVar Integer -> ApiLoggerSettings
ApiLoggerSettings
        { _obfuscateKeys :: Request -> [Text]
_obfuscateKeys = [Text] -> Request -> [Text]
forall a b. a -> b -> a
const []
        , _requestCounter :: MVar Integer
_requestCounter = MVar Integer
counter
        }

-- | Define a set of top-level object keys that should be obfuscated for a given
-- request in a JSON format.
obfuscateKeys :: (Request -> [Text]) -> ApiLoggerSettings -> ApiLoggerSettings
obfuscateKeys :: (Request -> [Text]) -> ApiLoggerSettings -> ApiLoggerSettings
obfuscateKeys Request -> [Text]
getKeys ApiLoggerSettings
x =
    ApiLoggerSettings
x { _obfuscateKeys :: Request -> [Text]
_obfuscateKeys = Request -> [Text]
getKeys }

-- | Get the next request id, incrementing the request counter.
nextRequestId :: ApiLoggerSettings -> IO RequestId
nextRequestId :: ApiLoggerSettings -> IO RequestId
nextRequestId ApiLoggerSettings
settings =
    MVar Integer
-> (Integer -> IO (Integer, RequestId)) -> IO RequestId
forall (m :: * -> *) a b.
MonadUnliftIO m =>
MVar a -> (a -> m (a, b)) -> m b
modifyMVar (ApiLoggerSettings -> MVar Integer
_requestCounter ApiLoggerSettings
settings) (\Integer
n -> (Integer, RequestId) -> IO (Integer, RequestId)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Integer
nInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
1, Integer -> RequestId
RequestId Integer
n))

{-------------------------------------------------------------------------------
                                  Internals

  We can't actually read the content of a request twice, which has several
  issues.

  First of all, the 'setLogger' method from the 'warp' package isn't really
  helpful as we get a `Request` object in argument, but can't extract its body
  since it has already been consumed by the time it reaches our logger. As a
  consequence, we can merely do logging on superficial request information
  (e.g. headers, status, path etc.).

  See: https://hackage.haskell.org/package/warp-3.2.27/docs/Network-Wai-Handler-Warp.html#v:setLogger

  Then, there exists packages like `wai-extra` with ways to construct detailed
  loggers from a 'Request' object and its body parsed via some ad-hoc helpers
  (see below). However, this package requires a few undesirable dependencies
  (like data-default, or wai-logger) but more importantly, it doesn't make it
  possible to use a custom trace or logger object but instead, forces log outputs
  and behaviors to what's supported by the package.

  See: http://hackage.haskell.org/package/wai-extra-3.0.26/docs/Network-Wai-Middleware-RequestLogger.html

  So, in order to implement our own Request/Response logging middleware, I've
  extracted some relevant bits from the `wai-extra` package in order to:

  - Read the request body, and put it back. There's a small performance cost in
    doing so of course, but that's rather fine for the wallet API which isn't
    meant to serve concurrent client and be under heavy load.

  - Extract the body from a response and make it available in an IORef.

  Source code from the original functions below can be found in 'wai-extra'

  See: http://hackage.haskell.org/package/wai-extra-3.0.26/docs/src/Network.Wai.Middleware.RequestLogger.html

  (Note that functions have been slightly adjust for code-style and, to return
  an extra response status when available instead of only the request body).

-------------------------------------------------------------------------------}

getRequestBody :: Request -> IO (Request, ByteString)
getRequestBody :: Request -> IO (Request, ByteString)
getRequestBody Request
req = do
    [ByteString]
body <- ([ByteString] -> [ByteString]) -> IO [ByteString]
forall c. ([ByteString] -> c) -> IO c
loop [ByteString] -> [ByteString]
forall a. a -> a
id
    IORef [ByteString]
ichunks <- [ByteString] -> IO (IORef [ByteString])
forall a. a -> IO (IORef a)
newIORef [ByteString]
body
    let rbody :: IO ByteString
rbody = IORef [ByteString]
-> ([ByteString] -> ([ByteString], ByteString)) -> IO ByteString
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef [ByteString]
ichunks (([ByteString] -> ([ByteString], ByteString)) -> IO ByteString)
-> ([ByteString] -> ([ByteString], ByteString)) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \case
           [] -> ([], ByteString
forall a. Monoid a => a
mempty)
           ByteString
x:[ByteString]
y -> ([ByteString]
y, ByteString
x)
    (Request, ByteString) -> IO (Request, ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (Request
req { requestBody :: IO ByteString
requestBody = IO ByteString
rbody }, [ByteString] -> ByteString
forall a. Monoid a => [a] -> a
mconcat [ByteString]
body)
  where
    loop :: ([ByteString] -> c) -> IO c
loop [ByteString] -> c
front = do
        ByteString
bs <- Request -> IO ByteString
getRequestBodyChunk Request
req
        if ByteString -> Bool
BS.null ByteString
bs
            then c -> IO c
forall (m :: * -> *) a. Monad m => a -> m a
return (c -> IO c) -> c -> IO c
forall a b. (a -> b) -> a -> b
$ [ByteString] -> c
front []
            else ([ByteString] -> c) -> IO c
loop (([ByteString] -> c) -> IO c) -> ([ByteString] -> c) -> IO c
forall a b. (a -> b) -> a -> b
$ [ByteString] -> c
front ([ByteString] -> c)
-> ([ByteString] -> [ByteString]) -> [ByteString] -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString
bsByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
:)

recordChunks :: IORef (Maybe Status, Builder) -> Response -> IO Response
recordChunks :: IORef (Maybe Status, Builder) -> Response -> IO Response
recordChunks IORef (Maybe Status, Builder)
i = \case
    ResponseStream Status
s ResponseHeaders
h StreamingBody
sb -> Response -> IO Response
forall (m :: * -> *) a. Monad m => a -> m a
return (Response -> IO Response)
-> (StreamingBody -> Response) -> StreamingBody -> IO Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Status -> ResponseHeaders -> StreamingBody -> Response
ResponseStream Status
s ResponseHeaders
h (StreamingBody -> IO Response) -> StreamingBody -> IO Response
forall a b. (a -> b) -> a -> b
$
        let capture :: b -> (Maybe Status, b) -> (Maybe Status, b)
capture b
b (Maybe Status
ms, b
b') = (Maybe Status
ms Maybe Status -> Maybe Status -> Maybe Status
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Status -> Maybe Status
forall a. a -> Maybe a
Just Status
s, b
b' b -> b -> b
forall a. Semigroup a => a -> a -> a
<> b
b)
        in (\Builder -> IO ()
send IO ()
flush -> StreamingBody
sb (\Builder
b -> IORef (Maybe Status, Builder)
-> ((Maybe Status, Builder) -> (Maybe Status, Builder)) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef (Maybe Status, Builder)
i (Builder -> (Maybe Status, Builder) -> (Maybe Status, Builder)
forall b.
Semigroup b =>
b -> (Maybe Status, b) -> (Maybe Status, b)
capture Builder
b) IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Builder -> IO ()
send Builder
b) IO ()
flush)
    ResponseBuilder Status
s ResponseHeaders
h Builder
b ->
        let capture :: (Maybe Status, Builder) -> (Maybe Status, Builder)
capture (Maybe Status
ms, Builder
b') = (Maybe Status
ms Maybe Status -> Maybe Status -> Maybe Status
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Status -> Maybe Status
forall a. a -> Maybe a
Just Status
s, Builder
b' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
b)
        in IORef (Maybe Status, Builder)
-> ((Maybe Status, Builder) -> (Maybe Status, Builder)) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef (Maybe Status, Builder)
i (Maybe Status, Builder) -> (Maybe Status, Builder)
capture IO () -> IO Response -> IO Response
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Response -> IO Response
forall (m :: * -> *) a. Monad m => a -> m a
return (Status -> ResponseHeaders -> Builder -> Response
ResponseBuilder Status
s ResponseHeaders
h Builder
b)
    Response
r ->
        Response -> IO Response
forall (m :: * -> *) a. Monad m => a -> m a
return Response
r

{-------------------------------------------------------------------------------
                                    Logging
-------------------------------------------------------------------------------}

-- | API handler trace events are associated with a unique request ID.
data ApiLog = ApiLog
    { ApiLog -> RequestId
requestId :: RequestId
    -- ^ Unique integer associated with the request, for the purpose of tracing.
    , ApiLog -> HandlerLog
logMsg :: HandlerLog
    -- ^ Event trace for the handler.
    } deriving ((forall x. ApiLog -> Rep ApiLog x)
-> (forall x. Rep ApiLog x -> ApiLog) -> Generic ApiLog
forall x. Rep ApiLog x -> ApiLog
forall x. ApiLog -> Rep ApiLog x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ApiLog x -> ApiLog
$cfrom :: forall x. ApiLog -> Rep ApiLog x
Generic, Int -> ApiLog -> ShowS
[ApiLog] -> ShowS
ApiLog -> String
(Int -> ApiLog -> ShowS)
-> (ApiLog -> String) -> ([ApiLog] -> ShowS) -> Show ApiLog
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ApiLog] -> ShowS
$cshowList :: [ApiLog] -> ShowS
show :: ApiLog -> String
$cshow :: ApiLog -> String
showsPrec :: Int -> ApiLog -> ShowS
$cshowsPrec :: Int -> ApiLog -> ShowS
Show, [ApiLog] -> Encoding
[ApiLog] -> Value
ApiLog -> Encoding
ApiLog -> Value
(ApiLog -> Value)
-> (ApiLog -> Encoding)
-> ([ApiLog] -> Value)
-> ([ApiLog] -> Encoding)
-> ToJSON ApiLog
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [ApiLog] -> Encoding
$ctoEncodingList :: [ApiLog] -> Encoding
toJSONList :: [ApiLog] -> Value
$ctoJSONList :: [ApiLog] -> Value
toEncoding :: ApiLog -> Encoding
$ctoEncoding :: ApiLog -> Encoding
toJSON :: ApiLog -> Value
$ctoJSON :: ApiLog -> Value
ToJSON)

instance HasPrivacyAnnotation ApiLog where
    getPrivacyAnnotation :: ApiLog -> PrivacyAnnotation
getPrivacyAnnotation (ApiLog RequestId
_ HandlerLog
msg) = HandlerLog -> PrivacyAnnotation
forall a. HasPrivacyAnnotation a => a -> PrivacyAnnotation
getPrivacyAnnotation HandlerLog
msg

instance HasSeverityAnnotation ApiLog where
    getSeverityAnnotation :: ApiLog -> Severity
getSeverityAnnotation (ApiLog RequestId
_ HandlerLog
msg) = HandlerLog -> Severity
forall a. HasSeverityAnnotation a => a -> Severity
getSeverityAnnotation HandlerLog
msg

instance ToText ApiLog where
    toText :: ApiLog -> Text
toText (ApiLog RequestId
rid HandlerLog
msg) =
        Text
"[" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (RequestId -> String
forall a. Show a => a -> String
show RequestId
rid) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"] "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> HandlerLog -> Text
forall a. ToText a => a -> Text
toText HandlerLog
msg

-- These instance are required by iohk-monitoring
instance ToObject ApiLog
instance FromJSON ApiLog where
    parseJSON :: Value -> Parser ApiLog
parseJSON Value
_ = String -> Parser ApiLog
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"FromJSON ApiLog stub"

-- | Tracer events related to the handling of a single request.
data HandlerLog
    = LogRequestStart
    | LogRequest Request
    | LogRequestBody [Text] ByteString
    -- ^ Request content, with list of sensitive json keys.
    | LogResponse NominalDiffTime Request (Maybe Status)
    | LogResponseBody ByteString
    | LogRequestFinish
    deriving ((forall x. HandlerLog -> Rep HandlerLog x)
-> (forall x. Rep HandlerLog x -> HandlerLog) -> Generic HandlerLog
forall x. Rep HandlerLog x -> HandlerLog
forall x. HandlerLog -> Rep HandlerLog x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep HandlerLog x -> HandlerLog
$cfrom :: forall x. HandlerLog -> Rep HandlerLog x
Generic, Int -> HandlerLog -> ShowS
[HandlerLog] -> ShowS
HandlerLog -> String
(Int -> HandlerLog -> ShowS)
-> (HandlerLog -> String)
-> ([HandlerLog] -> ShowS)
-> Show HandlerLog
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [HandlerLog] -> ShowS
$cshowList :: [HandlerLog] -> ShowS
show :: HandlerLog -> String
$cshow :: HandlerLog -> String
showsPrec :: Int -> HandlerLog -> ShowS
$cshowsPrec :: Int -> HandlerLog -> ShowS
Show)

instance ToText HandlerLog where
    toText :: HandlerLog -> Text
toText HandlerLog
msg = case HandlerLog
msg of
        HandlerLog
LogRequestStart -> Text
"Received API request"
        LogRequest Request
req -> [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat [ Text
"[", Text
method, Text
"] ", Text
path, Text
query ]
          where
            method :: Text
method = ByteString -> Text
T.decodeUtf8 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ Request -> ByteString
requestMethod Request
req
            path :: Text
path = ByteString -> Text
T.decodeUtf8 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ Request -> ByteString
rawPathInfo Request
req
            query :: Text
query = ByteString -> Text
T.decodeUtf8 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ Request -> ByteString
rawQueryString Request
req
        LogRequestBody [Text]
ks ByteString
body -> [Text] -> ByteString -> Text
sanitize [Text]
ks ByteString
body
        LogResponse NominalDiffTime
time Request
req Maybe Status
status ->
            [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat [ Text
method, Text
" ", Text
path, Text
" ", Text
code, Text
" ", Text
text, Text
" in ", Text
tsec ]
          where
            method :: Text
method = ByteString -> Text
T.decodeUtf8 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ Request -> ByteString
requestMethod Request
req
            path :: Text
path = ByteString -> Text
T.decodeUtf8 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ Request -> ByteString
rawPathInfo Request
req
            code :: Text
code = Text -> (Status -> Text) -> Maybe Status -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"???" (Int -> Text
forall a. ToText a => a -> Text
toText (Int -> Text) -> (Status -> Int) -> Status -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Status -> Int
statusCode) Maybe Status
status
            text :: Text
text = Text -> (Status -> Text) -> Maybe Status -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"Status Unknown" (ByteString -> Text
T.decodeUtf8 (ByteString -> Text) -> (Status -> ByteString) -> Status -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Status -> ByteString
statusMessage) Maybe Status
status
            tsec :: Text
tsec = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ NominalDiffTime -> String
forall a. Show a => a -> String
show NominalDiffTime
time
        LogResponseBody ByteString
body -> ByteString -> Text
T.decodeUtf8 ByteString
body
        HandlerLog
LogRequestFinish -> Text
"Completed response to API request"

instance ToJSON HandlerLog where
    toJSON :: HandlerLog -> Value
toJSON = Text -> Value
String (Text -> Value) -> (HandlerLog -> Text) -> HandlerLog -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HandlerLog -> Text
forall a. ToText a => a -> Text
toText

-- | Removes sensitive details from valid request payloads and completely
-- obfuscate invalid payloads.
sanitize :: [Text] -> ByteString -> Text
sanitize :: [Text] -> ByteString -> Text
sanitize [Text]
keys ByteString
bytes = Value -> Text
encode' (Value -> Text) -> Value -> Text
forall a b. (a -> b) -> a -> b
$ case ByteString -> Maybe Value
decode' ByteString
bytes of
    Just (Object Object
o) ->
        Object -> Value
Object
            (Object -> Value) -> Object -> Value
forall a b. (a -> b) -> a -> b
$ HashMap Key Value -> Object
forall v. HashMap Key v -> KeyMap v
Aeson.fromHashMap
            (HashMap Key Value -> Object) -> HashMap Key Value -> Object
forall a b. (a -> b) -> a -> b
$ (Text -> HashMap Key Value -> HashMap Key Value)
-> HashMap Key Value -> [Text] -> HashMap Key Value
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr
                ((Value -> Value) -> Key -> HashMap Key Value -> HashMap Key Value
forall k v.
(Eq k, Hashable k) =>
(v -> v) -> k -> HashMap k v -> HashMap k v
HM.adjust Value -> Value
forall p. p -> Value
obfuscate (Key -> HashMap Key Value -> HashMap Key Value)
-> (Text -> Key) -> Text -> HashMap Key Value -> HashMap Key Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Key
Aeson.fromText)
                (Object -> HashMap Key Value
forall v. KeyMap v -> HashMap Key v
Aeson.toHashMap Object
o)
                [Text]
keys
    Just Value
v ->
        Value
v
    Maybe Value
Nothing ->
        Text -> Value
String Text
"Invalid payload: not JSON"
  where
    encode' :: Value -> Text
encode' = ByteString -> Text
T.decodeUtf8 (ByteString -> Text) -> (Value -> ByteString) -> Value -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BL.toStrict (ByteString -> ByteString)
-> (Value -> ByteString) -> Value -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> ByteString
forall a. ToJSON a => a -> ByteString
Aeson.encode
    decode' :: ByteString -> Maybe Value
decode' = ByteString -> Maybe Value
forall a. FromJSON a => ByteString -> Maybe a
Aeson.decode (ByteString -> Maybe Value)
-> (ByteString -> ByteString) -> ByteString -> Maybe Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
BL.fromStrict
    obfuscate :: p -> Value
obfuscate p
_ = Text -> Value
String Text
"*****"

instance HasPrivacyAnnotation HandlerLog where
    getPrivacyAnnotation :: HandlerLog -> PrivacyAnnotation
getPrivacyAnnotation HandlerLog
msg = case HandlerLog
msg of
        LogRequestStart{} -> PrivacyAnnotation
Public
        LogRequest{} -> PrivacyAnnotation
Public
        LogRequestBody{} -> PrivacyAnnotation
Confidential
        LogResponse{} -> PrivacyAnnotation
Public
        LogResponseBody{} -> PrivacyAnnotation
Confidential
        LogRequestFinish{} -> PrivacyAnnotation
Public

instance HasSeverityAnnotation HandlerLog where
    getSeverityAnnotation :: HandlerLog -> Severity
getSeverityAnnotation HandlerLog
msg = case HandlerLog
msg of
        HandlerLog
LogRequestStart -> Severity
Debug
        LogRequest Request
_ -> Severity
Info
        LogRequestBody [Text]
_ ByteString
_ -> Severity
Debug
        LogResponse NominalDiffTime
t Request
_ Maybe Status
status -> Severity -> Severity -> Severity
forall a. Ord a => a -> a -> a
max (NominalDiffTime -> Severity
severityFromRequestTime NominalDiffTime
t) (Severity -> Severity) -> Severity -> Severity
forall a b. (a -> b) -> a -> b
$
            case Status -> Int
statusCode (Status -> Int) -> Maybe Status -> Maybe Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Status
status of
                Just Int
s | Int
s Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
503 -> Severity
Warning
                Just Int
s | Int
s Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
500 -> Severity
Error
                Maybe Int
_ -> Severity
Info
        LogResponseBody ByteString
_ -> Severity
Debug
        HandlerLog
LogRequestFinish -> Severity
Debug

severityFromRequestTime :: NominalDiffTime -> Severity
severityFromRequestTime :: NominalDiffTime -> Severity
severityFromRequestTime NominalDiffTime
t
    | NominalDiffTime
t NominalDiffTime -> NominalDiffTime -> Bool
forall a. Ord a => a -> a -> Bool
> NominalDiffTime
5     = Severity
Error
    | NominalDiffTime
t NominalDiffTime -> NominalDiffTime -> Bool
forall a. Ord a => a -> a -> Bool
> NominalDiffTime
1     = Severity
Warning
    | NominalDiffTime
t NominalDiffTime -> NominalDiffTime -> Bool
forall a. Ord a => a -> a -> Bool
> NominalDiffTime
0.5   = Severity
Notice
    | Bool
otherwise = Severity
Info