{-# LANGUAGE TemplateHaskell      #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

module Tendermint.SDK.BaseApp.Logger.Katip
  (
  -- * Setup and Config
    LogConfig(..)
  , logNamespace
  , logContext
  , logEnv
  , InitialLogNamespace(..)
  , initialLogEnvironment
  , initialLogProcessName

  -- * Eval
  , evalKatip
  ) where

import           Control.Lens                  (over, view)
import           Control.Lens.TH               (makeLenses)
import qualified Data.Aeson                    as A
import           Data.String                   (fromString)
import           Data.String.Conversions       (cs)
import           Data.Text                     (Text)
import qualified Katip                         as K
import           Polysemy                      (Embed, Members, Sem, interpretH,
                                                pureT, raise, runT)
import           Polysemy.Reader               (Reader, asks, local)
import           Tendermint.SDK.BaseApp.Logger

newtype Object a = Object a

instance Select a => Select (Object a) where
  select :: Verbosity -> Object a -> LogSelect
select v :: Verbosity
v (Object x :: a
x) = Verbosity -> a -> LogSelect
forall a. Select a => Verbosity -> a -> LogSelect
select Verbosity
v a
x

instance A.ToJSON a => K.ToObject (Object a) where
  toObject :: Object a -> Object
toObject (Object a :: a
a) = case a -> Value
forall a. ToJSON a => a -> Value
A.toJSON a
a of
      A.Object o :: Object
o -> Object
o
      _          -> Object
forall a. Monoid a => a
mempty

instance (A.ToJSON a, Select a) => K.LogItem (Object a) where
  payloadKeys :: Verbosity -> Object a -> PayloadSelection
payloadKeys = Verbosity -> Object a -> PayloadSelection
forall a. Select a => Verbosity -> a -> PayloadSelection
interpretFromSelect
    where
      interpretFromSelect :: Verbosity -> a -> PayloadSelection
interpretFromSelect kVerbosity :: Verbosity
kVerbosity obj :: a
obj =
        let selectRes :: LogSelect
selectRes = Verbosity -> a -> LogSelect
forall a. Select a => Verbosity -> a -> LogSelect
select (Verbosity -> Verbosity
kVerbToVerb Verbosity
kVerbosity) a
obj
        in case LogSelect
selectRes of
          All     -> PayloadSelection
K.AllKeys
          Some ts :: [Text]
ts -> [Text] -> PayloadSelection
K.SomeKeys [Text]
ts
      kVerbToVerb :: Verbosity -> Verbosity
kVerbToVerb K.V0 = Verbosity
V0
      kVerbToVerb K.V1 = Verbosity
V1
      kVerbToVerb K.V2 = Verbosity
V2
      kVerbToVerb K.V3 = Verbosity
V3

data LogConfig = LogConfig
  { LogConfig -> Namespace
_logNamespace :: K.Namespace
  , LogConfig -> LogContexts
_logContext   :: K.LogContexts
  , LogConfig -> LogEnv
_logEnv       :: K.LogEnv
  }
makeLenses ''LogConfig

data InitialLogNamespace = InitialLogNamespace
  { InitialLogNamespace -> Text
_initialLogEnvironment :: Text
  , InitialLogNamespace -> Text
_initialLogProcessName :: Text
  }

makeLenses ''InitialLogNamespace

instance (Members [Embed IO, Reader LogConfig] r) => K.Katip (Sem r)  where
  getLogEnv :: Sem r LogEnv
getLogEnv = (LogConfig -> LogEnv) -> Sem r LogEnv
forall i j (r :: [(* -> *) -> * -> *]).
Member (Reader i) r =>
(i -> j) -> Sem r j
asks ((LogConfig -> LogEnv) -> Sem r LogEnv)
-> (LogConfig -> LogEnv) -> Sem r LogEnv
forall a b. (a -> b) -> a -> b
$ Getting LogEnv LogConfig LogEnv -> LogConfig -> LogEnv
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting LogEnv LogConfig LogEnv
Lens' LogConfig LogEnv
logEnv
  localLogEnv :: (LogEnv -> LogEnv) -> Sem r a -> Sem r a
localLogEnv f :: LogEnv -> LogEnv
f m :: Sem r a
m = (LogConfig -> LogConfig) -> Sem r a -> Sem r a
forall i (r :: [(* -> *) -> * -> *]) a.
MemberWithError (Reader i) r =>
(i -> i) -> Sem r a -> Sem r a
local (ASetter LogConfig LogConfig LogEnv LogEnv
-> (LogEnv -> LogEnv) -> LogConfig -> LogConfig
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter LogConfig LogConfig LogEnv LogEnv
Lens' LogConfig LogEnv
logEnv LogEnv -> LogEnv
f) Sem r a
m

instance (Members [Embed IO, Reader LogConfig] r) => K.KatipContext (Sem r) where
  getKatipContext :: Sem r LogContexts
getKatipContext = (LogConfig -> LogContexts) -> Sem r LogContexts
forall i j (r :: [(* -> *) -> * -> *]).
Member (Reader i) r =>
(i -> j) -> Sem r j
asks ((LogConfig -> LogContexts) -> Sem r LogContexts)
-> (LogConfig -> LogContexts) -> Sem r LogContexts
forall a b. (a -> b) -> a -> b
$ Getting LogContexts LogConfig LogContexts
-> LogConfig -> LogContexts
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting LogContexts LogConfig LogContexts
Lens' LogConfig LogContexts
logContext
  localKatipContext :: (LogContexts -> LogContexts) -> Sem r a -> Sem r a
localKatipContext f :: LogContexts -> LogContexts
f m :: Sem r a
m = (LogConfig -> LogConfig) -> Sem r a -> Sem r a
forall i (r :: [(* -> *) -> * -> *]) a.
MemberWithError (Reader i) r =>
(i -> i) -> Sem r a -> Sem r a
local (ASetter LogConfig LogConfig LogContexts LogContexts
-> (LogContexts -> LogContexts) -> LogConfig -> LogConfig
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter LogConfig LogConfig LogContexts LogContexts
Lens' LogConfig LogContexts
logContext LogContexts -> LogContexts
f) Sem r a
m
  getKatipNamespace :: Sem r Namespace
getKatipNamespace = (LogConfig -> Namespace) -> Sem r Namespace
forall i j (r :: [(* -> *) -> * -> *]).
Member (Reader i) r =>
(i -> j) -> Sem r j
asks ((LogConfig -> Namespace) -> Sem r Namespace)
-> (LogConfig -> Namespace) -> Sem r Namespace
forall a b. (a -> b) -> a -> b
$ Getting Namespace LogConfig Namespace -> LogConfig -> Namespace
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Namespace LogConfig Namespace
Lens' LogConfig Namespace
logNamespace
  localKatipNamespace :: (Namespace -> Namespace) -> Sem r a -> Sem r a
localKatipNamespace f :: Namespace -> Namespace
f m :: Sem r a
m = (LogConfig -> LogConfig) -> Sem r a -> Sem r a
forall i (r :: [(* -> *) -> * -> *]) a.
MemberWithError (Reader i) r =>
(i -> i) -> Sem r a -> Sem r a
local (ASetter LogConfig LogConfig Namespace Namespace
-> (Namespace -> Namespace) -> LogConfig -> LogConfig
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter LogConfig LogConfig Namespace Namespace
Lens' LogConfig Namespace
logNamespace Namespace -> Namespace
f) Sem r a
m

evalKatip
  :: forall r a.
     K.KatipContext (Sem r)
  => Sem (Logger ': r) a
  -> Sem r a
evalKatip :: Sem (Logger : r) a -> Sem r a
evalKatip = do
  (forall x (m :: * -> *). Logger m x -> Tactical Logger m r x)
-> Sem (Logger : r) a -> Sem r a
forall (e :: (* -> *) -> * -> *) (r :: [(* -> *) -> * -> *]) a.
(forall x (m :: * -> *). e m x -> Tactical e m r x)
-> Sem (e : r) a -> Sem r a
interpretH (\case
    Log severity msg -> do
      Sem r () -> Sem (Tactics f m (Logger : r) : r) ()
forall (e :: (* -> *) -> * -> *) (r :: [(* -> *) -> * -> *]) a.
Sem r a -> Sem (e : r) a
raise (Sem r () -> Sem (Tactics f m (Logger : r) : r) ())
-> Sem r () -> Sem (Tactics f m (Logger : r) : r) ()
forall a b. (a -> b) -> a -> b
$
        Severity -> LogStr -> Sem r ()
forall (m :: * -> *).
(Applicative m, KatipContext m) =>
Severity -> LogStr -> m ()
K.logFM (Severity -> Severity
coerceSeverity Severity
severity) (String -> LogStr
forall a. IsString a => String -> a
fromString (String -> LogStr) -> (Text -> String) -> Text -> LogStr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
forall a b. ConvertibleStrings a b => a -> b
cs (Text -> LogStr) -> Text -> LogStr
forall a b. (a -> b) -> a -> b
$ Text
msg)
      () -> Tactical Logger m r ()
forall a (e :: (* -> *) -> * -> *) (m :: * -> *)
       (r :: [(* -> *) -> * -> *]).
a -> Tactical e m r a
pureT ()
    AddContext obj action -> do
      Sem (Logger : r) (f x)
a <- m x -> Sem (Tactics f m (Logger : r) : r) (Sem (Logger : r) (f x))
forall (m :: * -> *) a (e :: (* -> *) -> * -> *) (f :: * -> *)
       (r :: [(* -> *) -> * -> *]).
m a -> Sem (WithTactics e f m r) (Sem (e : r) (f a))
runT m x
action
      Sem r (f x) -> Sem (Tactics f m (Logger : r) : r) (f x)
forall (e :: (* -> *) -> * -> *) (r :: [(* -> *) -> * -> *]) a.
Sem r a -> Sem (e : r) a
raise (Sem r (f x) -> Sem (Tactics f m (Logger : r) : r) (f x))
-> Sem r (f x) -> Sem (Tactics f m (Logger : r) : r) (f x)
forall a b. (a -> b) -> a -> b
$ Object x -> Sem r (f x) -> Sem r (f x)
forall i (m :: * -> *) a.
(LogItem i, KatipContext m) =>
i -> m a -> m a
K.katipAddContext (x -> Object x
forall a. a -> Object a
Object x
obj) (Sem (Logger : r) (f x) -> Sem r (f x)
forall (r :: [(* -> *) -> * -> *]) a.
KatipContext (Sem r) =>
Sem (Logger : r) a -> Sem r a
evalKatip Sem (Logger : r) (f x)
a)
    )
    where
      coerceSeverity :: Severity -> K.Severity
      coerceSeverity :: Severity -> Severity
coerceSeverity = \case
        Debug -> Severity
K.DebugS
        Info -> Severity
K.InfoS
        Warning -> Severity
K.WarningS
        Error -> Severity
K.ErrorS
        Exception -> Severity
K.CriticalS