{-# LANGUAGE ConstraintKinds       #-}
{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE DeriveAnyClass        #-}
{-# LANGUAGE DerivingStrategies    #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE GADTs                 #-}
{-# LANGUAGE LambdaCase            #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE TemplateHaskell       #-}
{-# LANGUAGE TupleSections         #-}
{-# LANGUAGE TypeApplications      #-}
{-# LANGUAGE TypeOperators         #-}
module Wallet.Emulator.NodeClient where

import Cardano.Api qualified as C
import Cardano.Node.Emulator.Internal.Node.Chain
import Control.Lens hiding (index)
import Control.Monad.Freer
import Control.Monad.Freer.Extras.Log (LogMsg, logInfo)
import Control.Monad.Freer.State
import Control.Monad.Freer.TH
import Data.Aeson (FromJSON, ToJSON)
import GHC.Generics (Generic)
import Ledger
import Ledger.AddressMap qualified as AM
import Prettyprinter hiding (annotate)
import Wallet.Effects (NodeClientEffect (..))

data NodeClientEvent =
    TxSubmit C.TxId C.Lovelace
    -- ^ A transaction has been added to the pool of pending transactions. The value is the fee of the transaction.
    deriving stock (NodeClientEvent -> NodeClientEvent -> Bool
(NodeClientEvent -> NodeClientEvent -> Bool)
-> (NodeClientEvent -> NodeClientEvent -> Bool)
-> Eq NodeClientEvent
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: NodeClientEvent -> NodeClientEvent -> Bool
$c/= :: NodeClientEvent -> NodeClientEvent -> Bool
== :: NodeClientEvent -> NodeClientEvent -> Bool
$c== :: NodeClientEvent -> NodeClientEvent -> Bool
Eq, Int -> NodeClientEvent -> ShowS
[NodeClientEvent] -> ShowS
NodeClientEvent -> String
(Int -> NodeClientEvent -> ShowS)
-> (NodeClientEvent -> String)
-> ([NodeClientEvent] -> ShowS)
-> Show NodeClientEvent
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [NodeClientEvent] -> ShowS
$cshowList :: [NodeClientEvent] -> ShowS
show :: NodeClientEvent -> String
$cshow :: NodeClientEvent -> String
showsPrec :: Int -> NodeClientEvent -> ShowS
$cshowsPrec :: Int -> NodeClientEvent -> ShowS
Show, (forall x. NodeClientEvent -> Rep NodeClientEvent x)
-> (forall x. Rep NodeClientEvent x -> NodeClientEvent)
-> Generic NodeClientEvent
forall x. Rep NodeClientEvent x -> NodeClientEvent
forall x. NodeClientEvent -> Rep NodeClientEvent x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep NodeClientEvent x -> NodeClientEvent
$cfrom :: forall x. NodeClientEvent -> Rep NodeClientEvent x
Generic)
    deriving anyclass (Value -> Parser [NodeClientEvent]
Value -> Parser NodeClientEvent
(Value -> Parser NodeClientEvent)
-> (Value -> Parser [NodeClientEvent]) -> FromJSON NodeClientEvent
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [NodeClientEvent]
$cparseJSONList :: Value -> Parser [NodeClientEvent]
parseJSON :: Value -> Parser NodeClientEvent
$cparseJSON :: Value -> Parser NodeClientEvent
FromJSON, [NodeClientEvent] -> Encoding
[NodeClientEvent] -> Value
NodeClientEvent -> Encoding
NodeClientEvent -> Value
(NodeClientEvent -> Value)
-> (NodeClientEvent -> Encoding)
-> ([NodeClientEvent] -> Value)
-> ([NodeClientEvent] -> Encoding)
-> ToJSON NodeClientEvent
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [NodeClientEvent] -> Encoding
$ctoEncodingList :: [NodeClientEvent] -> Encoding
toJSONList :: [NodeClientEvent] -> Value
$ctoJSONList :: [NodeClientEvent] -> Value
toEncoding :: NodeClientEvent -> Encoding
$ctoEncoding :: NodeClientEvent -> Encoding
toJSON :: NodeClientEvent -> Value
$ctoJSON :: NodeClientEvent -> Value
ToJSON)

instance Pretty NodeClientEvent where
    pretty :: NodeClientEvent -> Doc ann
pretty (TxSubmit TxId
tx Lovelace
_) = Doc ann
"TxSubmit:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> TxId -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty TxId
tx

makePrisms ''NodeClientEvent

data NodeClientState = NodeClientState {
    NodeClientState -> Slot
_clientSlot  :: Slot,
    NodeClientState -> AddressMap
_clientIndex :: AM.AddressMap
    -- ^ Full index
} deriving stock (Int -> NodeClientState -> ShowS
[NodeClientState] -> ShowS
NodeClientState -> String
(Int -> NodeClientState -> ShowS)
-> (NodeClientState -> String)
-> ([NodeClientState] -> ShowS)
-> Show NodeClientState
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [NodeClientState] -> ShowS
$cshowList :: [NodeClientState] -> ShowS
show :: NodeClientState -> String
$cshow :: NodeClientState -> String
showsPrec :: Int -> NodeClientState -> ShowS
$cshowsPrec :: Int -> NodeClientState -> ShowS
Show, NodeClientState -> NodeClientState -> Bool
(NodeClientState -> NodeClientState -> Bool)
-> (NodeClientState -> NodeClientState -> Bool)
-> Eq NodeClientState
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: NodeClientState -> NodeClientState -> Bool
$c/= :: NodeClientState -> NodeClientState -> Bool
== :: NodeClientState -> NodeClientState -> Bool
$c== :: NodeClientState -> NodeClientState -> Bool
Eq)

emptyNodeClientState :: NodeClientState
emptyNodeClientState :: NodeClientState
emptyNodeClientState = Slot -> AddressMap -> NodeClientState
NodeClientState (Integer -> Slot
Slot Integer
0) AddressMap
forall a. Monoid a => a
mempty

makeLenses ''NodeClientState

data ChainClientNotification = BlockValidated Block | SlotChanged Slot
    deriving (Int -> ChainClientNotification -> ShowS
[ChainClientNotification] -> ShowS
ChainClientNotification -> String
(Int -> ChainClientNotification -> ShowS)
-> (ChainClientNotification -> String)
-> ([ChainClientNotification] -> ShowS)
-> Show ChainClientNotification
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ChainClientNotification] -> ShowS
$cshowList :: [ChainClientNotification] -> ShowS
show :: ChainClientNotification -> String
$cshow :: ChainClientNotification -> String
showsPrec :: Int -> ChainClientNotification -> ShowS
$cshowsPrec :: Int -> ChainClientNotification -> ShowS
Show, ChainClientNotification -> ChainClientNotification -> Bool
(ChainClientNotification -> ChainClientNotification -> Bool)
-> (ChainClientNotification -> ChainClientNotification -> Bool)
-> Eq ChainClientNotification
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ChainClientNotification -> ChainClientNotification -> Bool
$c/= :: ChainClientNotification -> ChainClientNotification -> Bool
== :: ChainClientNotification -> ChainClientNotification -> Bool
$c== :: ChainClientNotification -> ChainClientNotification -> Bool
Eq)

data NodeClientControlEffect r where
    ClientNotify :: ChainClientNotification -> NodeClientControlEffect ()
makeEffect ''NodeClientControlEffect

type NodeClientEffs = '[ChainEffect, State NodeClientState, LogMsg NodeClientEvent]

handleNodeControl
    :: (Members NodeClientEffs effs)
    => Eff (NodeClientControlEffect ': effs) ~> Eff effs
handleNodeControl :: Eff (NodeClientControlEffect : effs) ~> Eff effs
handleNodeControl = (NodeClientControlEffect ~> Eff effs)
-> Eff (NodeClientControlEffect : effs) ~> Eff effs
forall (eff :: * -> *) (effs :: [* -> *]).
(eff ~> Eff effs) -> Eff (eff : effs) ~> Eff effs
interpret ((NodeClientControlEffect ~> Eff effs)
 -> Eff (NodeClientControlEffect : effs) ~> Eff effs)
-> (NodeClientControlEffect ~> Eff effs)
-> Eff (NodeClientControlEffect : effs) ~> Eff effs
forall a b. (a -> b) -> a -> b
$ \case
    ClientNotify (BlockValidated blk) -> (NodeClientState -> NodeClientState) -> Eff effs ()
forall s (effs :: [* -> *]).
Member (State s) effs =>
(s -> s) -> Eff effs ()
modify ((NodeClientState -> NodeClientState) -> Eff effs ())
-> (NodeClientState -> NodeClientState) -> Eff effs ()
forall a b. (a -> b) -> a -> b
$ \NodeClientState
s ->
            NodeClientState
s NodeClientState
-> (NodeClientState -> NodeClientState) -> NodeClientState
forall a b. a -> (a -> b) -> b
& (AddressMap -> Identity AddressMap)
-> NodeClientState -> Identity NodeClientState
Lens' NodeClientState AddressMap
clientIndex ((AddressMap -> Identity AddressMap)
 -> NodeClientState -> Identity NodeClientState)
-> (AddressMap -> AddressMap) -> NodeClientState -> NodeClientState
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (\AddressMap
am -> (AddressMap -> OnChainTx -> AddressMap)
-> AddressMap -> [OnChainTx] -> AddressMap
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\AddressMap
am' OnChainTx
t -> OnChainTx -> AddressMap -> AddressMap
AM.updateAllAddresses OnChainTx
t AddressMap
am') AddressMap
am [OnChainTx]
blk)
    ClientNotify (SlotChanged sl) -> (NodeClientState -> NodeClientState) -> Eff effs ()
forall s (effs :: [* -> *]).
Member (State s) effs =>
(s -> s) -> Eff effs ()
modify (ASetter NodeClientState NodeClientState Slot Slot
-> Slot -> NodeClientState -> NodeClientState
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter NodeClientState NodeClientState Slot Slot
Lens' NodeClientState Slot
clientSlot Slot
sl)

handleNodeClient
    :: (Members NodeClientEffs effs)
    => Eff (NodeClientEffect ': effs) ~> Eff effs
handleNodeClient :: Eff (NodeClientEffect : effs) ~> Eff effs
handleNodeClient = (NodeClientEffect ~> Eff effs)
-> Eff (NodeClientEffect : effs) ~> Eff effs
forall (eff :: * -> *) (effs :: [* -> *]).
(eff ~> Eff effs) -> Eff (eff : effs) ~> Eff effs
interpret ((NodeClientEffect ~> Eff effs)
 -> Eff (NodeClientEffect : effs) ~> Eff effs)
-> (NodeClientEffect ~> Eff effs)
-> Eff (NodeClientEffect : effs) ~> Eff effs
forall a b. (a -> b) -> a -> b
$ \case
    PublishTx tx    -> CardanoTx -> Eff effs ()
forall (effs :: [* -> *]).
Member ChainEffect effs =>
CardanoTx -> Eff effs ()
queueTx CardanoTx
tx Eff effs () -> Eff effs () -> Eff effs ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> NodeClientEvent -> Eff effs ()
forall a (effs :: [* -> *]).
Member (LogMsg a) effs =>
a -> Eff effs ()
logInfo (TxId -> Lovelace -> NodeClientEvent
TxSubmit (CardanoTx -> TxId
getCardanoTxId CardanoTx
tx) (CardanoTx -> Lovelace
getCardanoTxFee CardanoTx
tx))
    NodeClientEffect x
GetClientSlot   -> (NodeClientState -> Slot) -> Eff effs Slot
forall s a (effs :: [* -> *]).
Member (State s) effs =>
(s -> a) -> Eff effs a
gets NodeClientState -> Slot
_clientSlot
    NodeClientEffect x
GetClientParams -> Eff effs x
forall (effs :: [* -> *]).
Member ChainEffect effs =>
Eff effs Params
getParams