module Network.ABCI.Server.Middleware.Logger
    ( -- * Custom Loggers
      mkLogger
    , mkLoggerM
    ) where

import           Control.Monad.IO.Class    (MonadIO)
import           Control.Monad.Trans.Class (lift)
import qualified Data.Aeson                as A
import           Data.ByteArray.HexString  (HexString)
import           Data.String               (fromString)
import           Katip
import           Network.ABCI.Server.App   (App (..), MessageType, Middleware,
                                            Request (..), Response (..),
                                            demoteRequestType, hashRequest,
                                            msgTypeKey, transformApp)

---------------------------------------------------------------------------
-- Types
---------------------------------------------------------------------------
-- | Loggable newtype wrapper
newtype Loggable a = Loggable a

instance ToObject (Loggable (Request (t :: MessageType))) where
  toObject :: Loggable (Request t) -> Object
toObject (Loggable v :: Request t
v) = case Request t -> Value
forall a. ToJSON a => a -> Value
A.toJSON Request t
v of
      A.Object o :: Object
o -> Object
o
      _          -> [Char] -> Object
forall a. HasCallStack => [Char] -> a
error "Contract violation: `toJSON` of any `Request t` must result with json object"

instance LogItem (Loggable (Request (t :: MessageType))) where
  payloadKeys :: Verbosity -> Loggable (Request t) -> PayloadSelection
payloadKeys V3 _ = PayloadSelection
AllKeys
  payloadKeys _ _  = [Text] -> PayloadSelection
SomeKeys ["type"]

instance ToObject (Loggable (Response (t :: MessageType))) where
  toObject :: Loggable (Response t) -> Object
toObject (Loggable v :: Response t
v) = case Response t -> Value
forall a. ToJSON a => a -> Value
A.toJSON Response t
v of
      A.Object o :: Object
o -> Object
o
      _          -> [Char] -> Object
forall a. HasCallStack => [Char] -> a
error "Contract violation: `toJSON` of any `Response t` must result with json object"

instance LogItem (Loggable (Response (t :: MessageType))) where
  payloadKeys :: Verbosity -> Loggable (Response t) -> PayloadSelection
payloadKeys V3 _ = PayloadSelection
AllKeys
  payloadKeys _ _  = [Text] -> PayloadSelection
SomeKeys ["type"]

---------------------------------------------------------------------------
-- mkLogger
---------------------------------------------------------------------------
-- | Logger middleware for ABCI messages with custom 'Katip.LogEnv'
-- and 'Katip.Namespace'. This method makes it easy use various scribes such as
-- <http://hackage.haskell.org/package/katip-elasticsearch-0.5.1.1/docs/Katip-Scribes-ElasticSearch.html elastic-search>.
mkLogger
  :: MonadIO m
  => LogEnv
  -> Namespace
  -> Middleware m
mkLogger :: LogEnv -> Namespace -> Middleware m
mkLogger le :: LogEnv
le ns :: Namespace
ns =
  (forall (t :: MessageType).
 KatipContextT m (Response t) -> m (Response t))
-> App (KatipContextT m) -> App m
forall (m :: * -> *) (g :: * -> *).
(forall (t :: MessageType). m (Response t) -> g (Response t))
-> App m -> App g
transformApp (LogEnv
-> ()
-> Namespace
-> KatipContextT m (Response t)
-> m (Response t)
forall c (m :: * -> *) a.
LogItem c =>
LogEnv -> c -> Namespace -> KatipContextT m a -> m a
runKatipContextT LogEnv
le () Namespace
ns) (App (KatipContextT m) -> App m)
-> (App m -> App (KatipContextT m)) -> Middleware m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Middleware (KatipContextT m)
forall (m :: * -> *). KatipContext m => Middleware m
mkLoggerM Middleware (KatipContextT m)
-> (App m -> App (KatipContextT m))
-> App m
-> App (KatipContextT m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall (t :: MessageType).
 m (Response t) -> KatipContextT m (Response t))
-> App m -> App (KatipContextT m)
forall (m :: * -> *) (g :: * -> *).
(forall (t :: MessageType). m (Response t) -> g (Response t))
-> App m -> App g
transformApp forall (t :: MessageType).
m (Response t) -> KatipContextT m (Response t)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift

---------------------------------------------------------------------------
-- mkLoggerM
---------------------------------------------------------------------------
-- | Logger middleware for ABCI messages in app with KatipContext.
-- Great for `App m` with a `KatipContext` instance.
mkLoggerM
  :: KatipContext m
  => Middleware m
mkLoggerM :: Middleware m
mkLoggerM (App app :: forall (t :: MessageType). Request t -> m (Response t)
app) = (forall (t :: MessageType). Request t -> m (Response t)) -> App m
forall (m :: * -> *).
(forall (t :: MessageType). Request t -> m (Response t)) -> App m
App ((forall (t :: MessageType). Request t -> m (Response t)) -> App m)
-> (forall (t :: MessageType). Request t -> m (Response t))
-> App m
forall a b. (a -> b) -> a -> b
$ \ req :: Request t
req -> do
  let globalContext :: GlobalMessageContext
globalContext = GlobalMessageContext :: HexString -> MessageType -> GlobalMessageContext
GlobalMessageContext
        { messageHash :: HexString
messageHash = Request t -> HexString
forall (t :: MessageType). Request t -> HexString
hashRequest Request t
req
        , messageType :: MessageType
messageType = Request t -> MessageType
forall (t :: MessageType). Request t -> MessageType
demoteRequestType Request t
req
        }
  GlobalMessageContext -> m (Response t) -> m (Response t)
forall i (m :: * -> *) a.
(LogItem i, KatipContext m) =>
i -> m a -> m a
katipAddContext GlobalMessageContext
globalContext (m (Response t) -> m (Response t))
-> m (Response t) -> m (Response t)
forall a b. (a -> b) -> a -> b
$ do
    Namespace -> m () -> m ()
forall (m :: * -> *) a. KatipContext m => Namespace -> m a -> m a
katipAddNamespace ([Char] -> Namespace
forall a. IsString a => [Char] -> a
fromString "server") (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
      Request t -> m ()
forall (m :: * -> *) (t :: MessageType).
KatipContext m =>
Request t -> m ()
logRequest Request t
req
    Response t
resp <- Namespace -> m (Response t) -> m (Response t)
forall (m :: * -> *) a. KatipContext m => Namespace -> m a -> m a
katipAddNamespace ([Char] -> Namespace
forall a. IsString a => [Char] -> a
fromString "application") (m (Response t) -> m (Response t))
-> m (Response t) -> m (Response t)
forall a b. (a -> b) -> a -> b
$
      Request t -> m (Response t)
forall (t :: MessageType). Request t -> m (Response t)
app Request t
req
    Namespace -> m () -> m ()
forall (m :: * -> *) a. KatipContext m => Namespace -> m a -> m a
katipAddNamespace ([Char] -> Namespace
forall a. IsString a => [Char] -> a
fromString "server") (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
      Response t -> m ()
forall (m :: * -> *) (t :: MessageType).
KatipContext m =>
Response t -> m ()
logResponse Response t
resp
    Response t -> m (Response t)
forall (m :: * -> *) a. Monad m => a -> m a
return Response t
resp

---------------------------------------------------------------------------
-- Common
---------------------------------------------------------------------------

data GlobalMessageContext = GlobalMessageContext
  { GlobalMessageContext -> HexString
messageHash :: HexString
  , GlobalMessageContext -> MessageType
messageType :: MessageType
  }

instance A.ToJSON GlobalMessageContext where
  toJSON :: GlobalMessageContext -> Value
toJSON GlobalMessageContext {..} =
    [Pair] -> Value
A.object [ "message_type" Text -> [Char] -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
A..= MessageType -> [Char]
msgTypeKey MessageType
messageType
             , "message_hash" Text -> HexString -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
A..= HexString
messageHash
             ]

instance ToObject GlobalMessageContext

instance LogItem GlobalMessageContext where
    payloadKeys :: Verbosity -> GlobalMessageContext -> PayloadSelection
payloadKeys _ _ = PayloadSelection
AllKeys

-- | Request logger function.
logRequest
  :: KatipContext m
  => Request t
  ->  m ()
logRequest :: Request t -> m ()
logRequest req :: Request t
req = Loggable (Request t) -> m () -> m ()
forall i (m :: * -> *) a.
(LogItem i, KatipContext m) =>
i -> m a -> m a
katipAddContext (Request t -> Loggable (Request t)
forall a. a -> Loggable a
Loggable Request t
req) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
  Severity -> LogStr -> m ()
forall (m :: * -> *).
(Applicative m, KatipContext m) =>
Severity -> LogStr -> m ()
logFM Severity
logLevel "Request Received"
  where
    logLevel :: Severity
logLevel = case Request t
req of
      RequestFlush _ -> Severity
DebugS
      RequestEcho _  -> Severity
DebugS
      _              -> Severity
InfoS

logResponse
  :: KatipContext m
  => Response t
  ->  m ()
logResponse :: Response t -> m ()
logResponse resp :: Response t
resp = Loggable (Response t) -> m () -> m ()
forall i (m :: * -> *) a.
(LogItem i, KatipContext m) =>
i -> m a -> m a
katipAddContext (Response t -> Loggable (Response t)
forall a. a -> Loggable a
Loggable Response t
resp) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
  Severity -> LogStr -> m ()
forall (m :: * -> *).
(Applicative m, KatipContext m) =>
Severity -> LogStr -> m ()
logFM Severity
logLevel "Response Sent"
  where
    logLevel :: Severity
logLevel = case Response t
resp of
      ResponseFlush _ -> Severity
DebugS
      ResponseEcho _  -> Severity
DebugS
      _               -> Severity
InfoS