module Tendermint.SDK.BaseApp.Events
  (
  -- * Class
    ToEvent(..)
  , ContextEvent(..)

  -- * Effect
  , emit
  , logEvent

  -- * Re-Exports
  , Event(..)
  ) where

import qualified Data.Aeson                             as A
import qualified Data.ByteArray.Base64String            as Base64
import qualified Data.ByteString                        as BS
import           Data.Char                              (toLower)
import           Data.String.Conversions                (cs)
import           GHC.Generics
import           Network.ABCI.Types.Messages.FieldTypes (Event (..),
                                                         KVPair (..))
import           Polysemy                               (Member, Sem)
import           Polysemy.Output                        (Output, output)
import qualified Tendermint.SDK.BaseApp.Logger          as Log
import           Tendermint.SDK.Codec                   (HasCodec (..))

{-
TODO : These JSON instances are fragile but convenient. We
should come up with a custom solution.
-}

class GToNamedEventPrimatives f where
  gtoNamedEventPrimatives :: f a -> [(BS.ByteString, BS.ByteString)]

instance (GToNamedEventPrimatives f) => GToNamedEventPrimatives (C1 c f) where
  gtoNamedEventPrimatives :: C1 c f a -> [(ByteString, ByteString)]
gtoNamedEventPrimatives = f a -> [(ByteString, ByteString)]
forall k (f :: k -> *) (a :: k).
GToNamedEventPrimatives f =>
f a -> [(ByteString, ByteString)]
gtoNamedEventPrimatives (f a -> [(ByteString, ByteString)])
-> (C1 c f a -> f a) -> C1 c f a -> [(ByteString, ByteString)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. C1 c f a -> f a
forall i (c :: Meta) k (f :: k -> *) (p :: k). M1 i c f p -> f p
unM1

instance (Selector s, HasCodec a) => GToNamedEventPrimatives (S1 s (K1 i a)) where
  gtoNamedEventPrimatives :: S1 s (K1 i a) a -> [(ByteString, ByteString)]
gtoNamedEventPrimatives m1 :: S1 s (K1 i a) a
m1@(M1 x :: K1 i a a
x) =
    let name :: ByteString
name = [Char] -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs ([Char] -> ByteString) -> [Char] -> ByteString
forall a b. (a -> b) -> a -> b
$ S1 s (K1 i a) a -> [Char]
forall k (s :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Selector s =>
t s f a -> [Char]
selName S1 s (K1 i a) a
m1
        val :: ByteString
val = a -> ByteString
forall a. HasCodec a => a -> ByteString
encode (a -> ByteString) -> a -> ByteString
forall a b. (a -> b) -> a -> b
$ K1 i a a -> a
forall i c k (p :: k). K1 i c p -> c
unK1 K1 i a a
x
    in [(ByteString
name, ByteString
val)]

instance (GToNamedEventPrimatives a, GToNamedEventPrimatives b) => GToNamedEventPrimatives (a :*: b) where
  gtoNamedEventPrimatives :: (:*:) a b a -> [(ByteString, ByteString)]
gtoNamedEventPrimatives (a :: a a
a :*: b :: b a
b) = a a -> [(ByteString, ByteString)]
forall k (f :: k -> *) (a :: k).
GToNamedEventPrimatives f =>
f a -> [(ByteString, ByteString)]
gtoNamedEventPrimatives a a
a [(ByteString, ByteString)]
-> [(ByteString, ByteString)] -> [(ByteString, ByteString)]
forall a. Semigroup a => a -> a -> a
<> b a -> [(ByteString, ByteString)]
forall k (f :: k -> *) (a :: k).
GToNamedEventPrimatives f =>
f a -> [(ByteString, ByteString)]
gtoNamedEventPrimatives b a
b

class GToEvent f where
  gmakeEvent :: f p -> Event

instance (GToNamedEventPrimatives f, Datatype d) => GToEvent (D1 d f) where
  gmakeEvent :: D1 d f p -> Event
gmakeEvent m1 :: D1 d f p
m1@(M1 x :: f p
x) = Event :: Text -> [KVPair] -> Event
Event
    { eventType :: Text
eventType = [Char] -> Text
forall a b. ConvertibleStrings a b => a -> b
cs ([Char] -> Text) -> ([Char] -> [Char]) -> [Char] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
lowerFirst ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ D1 d f p -> [Char]
forall k (d :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Datatype d =>
t d f a -> [Char]
datatypeName D1 d f p
m1
    , eventAttributes :: [KVPair]
eventAttributes = (\(k :: ByteString
k, v :: ByteString
v) -> Base64String -> Base64String -> KVPair
KVPair (ByteString -> Base64String
forall ba. ByteArrayAccess ba => ba -> Base64String
Base64.fromBytes ByteString
k) (ByteString -> Base64String
forall ba. ByteArrayAccess ba => ba -> Base64String
Base64.fromBytes ByteString
v)) ((ByteString, ByteString) -> KVPair)
-> [(ByteString, ByteString)] -> [KVPair]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f p -> [(ByteString, ByteString)]
forall k (f :: k -> *) (a :: k).
GToNamedEventPrimatives f =>
f a -> [(ByteString, ByteString)]
gtoNamedEventPrimatives f p
x
    }
    where
      lowerFirst :: [Char] -> [Char]
lowerFirst []       = []
      lowerFirst (y :: Char
y : ys :: [Char]
ys) = Char -> Char
toLower Char
y Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [Char]
ys

-- | A class representing a type that can be emitted as an event in the
-- | event logs for the deliverTx response.
class ToEvent e where
  toEvent :: e -> Event

  default toEvent :: (Generic e, GToEvent (Rep e)) => e -> Event
  toEvent = Rep e Any -> Event
forall k (f :: k -> *) (p :: k). GToEvent f => f p -> Event
gmakeEvent (Rep e Any -> Event) -> (e -> Rep e Any) -> e -> Event
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> Rep e Any
forall a x. Generic a => a -> Rep a x
from

emit
  :: ToEvent e
  => Member (Output Event) r
  => e
  -> Sem r ()
emit :: e -> Sem r ()
emit e :: e
e = Event -> Sem r ()
forall o (r :: [Effect]).
MemberWithError (Output o) r =>
o -> Sem r ()
output (Event -> Sem r ()) -> Event -> Sem r ()
forall a b. (a -> b) -> a -> b
$ e -> Event
forall e. ToEvent e => e -> Event
toEvent e
e



-- | Special event wrapper to add contextual event_type info
newtype ContextEvent t = ContextEvent t
instance (A.ToJSON a, ToEvent a) => A.ToJSON (ContextEvent a) where
  toJSON :: ContextEvent a -> Value
toJSON (ContextEvent a :: a
a) =
    let Event{Text
eventType :: Text
eventType :: Event -> Text
eventType} = a -> Event
forall e. ToEvent e => e -> Event
toEvent a
a
    in  [Pair] -> Value
A.object [ "event_type" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
A..= Text
eventType
                 , "event" Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
A..= a -> Value
forall a. ToJSON a => a -> Value
A.toJSON a
a
                 ]
instance Log.Select a => Log.Select (ContextEvent a) where
  select :: Verbosity -> ContextEvent a -> LogSelect
select v :: Verbosity
v (ContextEvent a :: a
a) = Verbosity -> a -> LogSelect
forall a. Select a => Verbosity -> a -> LogSelect
Log.select Verbosity
v a
a

logEvent
  :: forall e r.
     (A.ToJSON e, ToEvent e, Log.Select e)
  => Member Log.Logger r
  => e
  -> Sem r ()
logEvent :: e -> Sem r ()
logEvent event :: e
event = ContextEvent e -> Sem r () -> Sem r ()
forall (r :: [Effect]) x a.
(MemberWithError Logger r, Select x, ToJSON x) =>
x -> Sem r a -> Sem r a
Log.addContext (e -> ContextEvent e
forall t. t -> ContextEvent t
ContextEvent e
event) (Sem r () -> Sem r ()) -> Sem r () -> Sem r ()
forall a b. (a -> b) -> a -> b
$
  let Event{Text
eventType :: Text
eventType :: Event -> Text
eventType} = e -> Event
forall e. ToEvent e => e -> Event
toEvent e
event
  in Severity -> Text -> Sem r ()
forall (r :: [Effect]).
MemberWithError Logger r =>
Severity -> Text -> Sem r ()
Log.log Severity
Log.Info Text
eventType