{-# LANGUAGE ConstraintKinds  #-}
{-# LANGUAGE DataKinds        #-}
{-# LANGUAGE GADTs            #-}
{-# LANGUAGE TemplateHaskell  #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators    #-}
-- | If you want to run the node emulator without using the `Contract` monad, this module provides a simple MTL-based interface.
module Cardano.Node.Emulator.Internal.API (
  -- * Types
    EmulatorState(EmulatorState)
      , esChainState
      , esAddressMap
      , esDatumMap
  , EmulatorError(..)
  , EmulatorLogs
  , EmulatorMsg(..)
  , L.LogMessage(..)
  , MonadEmulator
  , EmulatorT
  , EmulatorM
  -- * Running Eff chain effects in MTL
  , handleChain
  , processBlock
  , modifySlot
) where

import Cardano.Node.Emulator.Internal.Node qualified as E
import Cardano.Node.Emulator.LogMessages (EmulatorMsg (ChainEvent, GenericMsg))
import Control.Exception (Exception)
import Control.Lens (makeLenses, (&))
import Control.Monad (void)
import Control.Monad.Error.Class (MonadError)
import Control.Monad.Except (ExceptT)
import Control.Monad.Freer (Eff, Member, interpret, run, type (~>))
import Control.Monad.Freer.Extras (raiseEnd)
import Control.Monad.Freer.Extras.Log qualified as L
import Control.Monad.Freer.State (State, modify, runState)
import Control.Monad.Freer.Writer qualified as F (Writer, runWriter, tell)
import Control.Monad.Identity (Identity)
import Control.Monad.RWS.Class (MonadRWS, ask, get, put, tell)
import Control.Monad.RWS.Strict (RWST)
import Data.Map (Map)
import Data.Sequence (Seq)
import Ledger (Block, Datum, DatumHash, Slot, ToCardanoError, ValidationErrorInPhase, eitherTx, getCardanoTxData)
import Ledger.AddressMap qualified as AM


data EmulatorState = EmulatorState
  { EmulatorState -> ChainState
_esChainState :: !E.ChainState
  , EmulatorState -> AddressMap
_esAddressMap :: !AM.AddressMap
  , EmulatorState -> Map DatumHash Datum
_esDatumMap   :: !(Map DatumHash Datum)
  }
  deriving (Int -> EmulatorState -> ShowS
[EmulatorState] -> ShowS
EmulatorState -> String
(Int -> EmulatorState -> ShowS)
-> (EmulatorState -> String)
-> ([EmulatorState] -> ShowS)
-> Show EmulatorState
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [EmulatorState] -> ShowS
$cshowList :: [EmulatorState] -> ShowS
show :: EmulatorState -> String
$cshow :: EmulatorState -> String
showsPrec :: Int -> EmulatorState -> ShowS
$cshowsPrec :: Int -> EmulatorState -> ShowS
Show)

makeLenses 'EmulatorState

data EmulatorError
  = BalancingError !E.BalancingError
  | ValidationError !ValidationErrorInPhase
  | ToCardanoError !ToCardanoError
  deriving (Int -> EmulatorError -> ShowS
[EmulatorError] -> ShowS
EmulatorError -> String
(Int -> EmulatorError -> ShowS)
-> (EmulatorError -> String)
-> ([EmulatorError] -> ShowS)
-> Show EmulatorError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [EmulatorError] -> ShowS
$cshowList :: [EmulatorError] -> ShowS
show :: EmulatorError -> String
$cshow :: EmulatorError -> String
showsPrec :: Int -> EmulatorError -> ShowS
$cshowsPrec :: Int -> EmulatorError -> ShowS
Show)

instance Exception EmulatorError

type EmulatorLogs = Seq (L.LogMessage EmulatorMsg)
type MonadEmulator m = (MonadRWS E.Params EmulatorLogs EmulatorState m, MonadError EmulatorError m)
type EmulatorT m = ExceptT EmulatorError (RWST E.Params EmulatorLogs EmulatorState m)
type EmulatorM = EmulatorT Identity

handleChain :: MonadEmulator m => Eff [E.ChainControlEffect, E.ChainEffect] a -> m a
handleChain :: Eff '[ChainControlEffect, ChainEffect] a -> m a
handleChain Eff '[ChainControlEffect, ChainEffect] a
eff = do
  Params
params <- m Params
forall r (m :: * -> *). MonadReader r m => m r
ask
  EmulatorState ChainState
chainState AddressMap
am Map DatumHash Datum
dm <- m EmulatorState
forall s (m :: * -> *). MonadState s m => m s
get
  let ((((a
a, Map DatumHash Datum
dm'), AddressMap
am') , ChainState
newChainState), EmulatorLogs
lg) = Eff '[ChainControlEffect, ChainEffect] a
-> Eff
     '[ChainControlEffect, ChainEffect, LogMsg ChainEvent,
       State (Map DatumHash Datum), State AddressMap, State ChainState,
       Writer EmulatorLogs]
     a
forall (effs :: [* -> *]) (as :: [* -> *]).
CanWeakenEnd as effs =>
Eff as ~> Eff effs
raiseEnd Eff '[ChainControlEffect, ChainEffect] a
eff
        Eff
  '[ChainControlEffect, ChainEffect, LogMsg ChainEvent,
    State (Map DatumHash Datum), State AddressMap, State ChainState,
    Writer EmulatorLogs]
  a
-> (Eff
      '[ChainControlEffect, ChainEffect, LogMsg ChainEvent,
        State (Map DatumHash Datum), State AddressMap, State ChainState,
        Writer EmulatorLogs]
      a
    -> Eff
         '[ChainEffect, LogMsg ChainEvent, State (Map DatumHash Datum),
           State AddressMap, State ChainState, Writer EmulatorLogs]
         a)
-> Eff
     '[ChainEffect, LogMsg ChainEvent, State (Map DatumHash Datum),
       State AddressMap, State ChainState, Writer EmulatorLogs]
     a
forall a b. a -> (a -> b) -> b
& (ChainControlEffect
 ~> Eff
      '[ChainEffect, LogMsg ChainEvent, State (Map DatumHash Datum),
        State AddressMap, State ChainState, Writer EmulatorLogs])
-> Eff
     '[ChainControlEffect, ChainEffect, LogMsg ChainEvent,
       State (Map DatumHash Datum), State AddressMap, State ChainState,
       Writer EmulatorLogs]
   ~> Eff
        '[ChainEffect, LogMsg ChainEvent, State (Map DatumHash Datum),
          State AddressMap, State ChainState, Writer EmulatorLogs]
forall (eff :: * -> *) (effs :: [* -> *]).
(eff ~> Eff effs) -> Eff (eff : effs) ~> Eff effs
interpret (Params
-> ChainControlEffect
   ~> Eff
        '[ChainEffect, LogMsg ChainEvent, State (Map DatumHash Datum),
          State AddressMap, State ChainState, Writer EmulatorLogs]
forall (effs :: [* -> *]).
Members ChainEffs effs =>
Params -> ChainControlEffect ~> Eff effs
E.handleControlChain Params
params)
        Eff
  '[ChainEffect, LogMsg ChainEvent, State (Map DatumHash Datum),
    State AddressMap, State ChainState, Writer EmulatorLogs]
  a
-> (Eff
      '[ChainEffect, LogMsg ChainEvent, State (Map DatumHash Datum),
        State AddressMap, State ChainState, Writer EmulatorLogs]
      a
    -> Eff
         '[LogMsg ChainEvent, State (Map DatumHash Datum), State AddressMap,
           State ChainState, Writer EmulatorLogs]
         a)
-> Eff
     '[LogMsg ChainEvent, State (Map DatumHash Datum), State AddressMap,
       State ChainState, Writer EmulatorLogs]
     a
forall a b. a -> (a -> b) -> b
& (ChainEffect
 ~> Eff
      '[LogMsg ChainEvent, State (Map DatumHash Datum), State AddressMap,
        State ChainState, Writer EmulatorLogs])
-> Eff
     '[ChainEffect, LogMsg ChainEvent, State (Map DatumHash Datum),
       State AddressMap, State ChainState, Writer EmulatorLogs]
   ~> Eff
        '[LogMsg ChainEvent, State (Map DatumHash Datum), State AddressMap,
          State ChainState, Writer EmulatorLogs]
forall (eff :: * -> *) (effs :: [* -> *]).
(eff ~> Eff effs) -> Eff (eff : effs) ~> Eff effs
interpret (Params
-> ChainEffect
   ~> Eff
        '[LogMsg ChainEvent, State (Map DatumHash Datum), State AddressMap,
          State ChainState, Writer EmulatorLogs]
forall (effs :: [* -> *]).
Members ChainEffs effs =>
Params -> ChainEffect ~> Eff effs
E.handleChain Params
params)
        Eff
  '[LogMsg ChainEvent, State (Map DatumHash Datum), State AddressMap,
    State ChainState, Writer EmulatorLogs]
  a
-> (Eff
      '[LogMsg ChainEvent, State (Map DatumHash Datum), State AddressMap,
        State ChainState, Writer EmulatorLogs]
      a
    -> Eff
         '[State (Map DatumHash Datum), State AddressMap, State ChainState,
           Writer EmulatorLogs]
         a)
-> Eff
     '[State (Map DatumHash Datum), State AddressMap, State ChainState,
       Writer EmulatorLogs]
     a
forall a b. a -> (a -> b) -> b
& (LogMsg ChainEvent
 ~> Eff
      '[State (Map DatumHash Datum), State AddressMap, State ChainState,
        Writer EmulatorLogs])
-> Eff
     '[LogMsg ChainEvent, State (Map DatumHash Datum), State AddressMap,
       State ChainState, Writer EmulatorLogs]
   ~> Eff
        '[State (Map DatumHash Datum), State AddressMap, State ChainState,
          Writer EmulatorLogs]
forall (eff :: * -> *) (effs :: [* -> *]).
(eff ~> Eff effs) -> Eff (eff : effs) ~> Eff effs
interpret forall (effs :: [* -> *]).
(Member (State AddressMap) effs,
 Member (State (Map DatumHash Datum)) effs,
 Member (Writer EmulatorLogs) effs) =>
LogMsg ChainEvent ~> Eff effs
LogMsg ChainEvent
~> Eff
     '[State (Map DatumHash Datum), State AddressMap, State ChainState,
       Writer EmulatorLogs]
handleChainLogs
        Eff
  '[State (Map DatumHash Datum), State AddressMap, State ChainState,
    Writer EmulatorLogs]
  a
-> (Eff
      '[State (Map DatumHash Datum), State AddressMap, State ChainState,
        Writer EmulatorLogs]
      a
    -> Eff
         '[State AddressMap, State ChainState, Writer EmulatorLogs]
         (a, Map DatumHash Datum))
-> Eff
     '[State AddressMap, State ChainState, Writer EmulatorLogs]
     (a, Map DatumHash Datum)
forall a b. a -> (a -> b) -> b
& Map DatumHash Datum
-> Eff
     '[State (Map DatumHash Datum), State AddressMap, State ChainState,
       Writer EmulatorLogs]
     a
-> Eff
     '[State AddressMap, State ChainState, Writer EmulatorLogs]
     (a, Map DatumHash Datum)
forall s (effs :: [* -> *]) a.
s -> Eff (State s : effs) a -> Eff effs (a, s)
runState Map DatumHash Datum
dm
        Eff
  '[State AddressMap, State ChainState, Writer EmulatorLogs]
  (a, Map DatumHash Datum)
-> (Eff
      '[State AddressMap, State ChainState, Writer EmulatorLogs]
      (a, Map DatumHash Datum)
    -> Eff
         '[State ChainState, Writer EmulatorLogs]
         ((a, Map DatumHash Datum), AddressMap))
-> Eff
     '[State ChainState, Writer EmulatorLogs]
     ((a, Map DatumHash Datum), AddressMap)
forall a b. a -> (a -> b) -> b
& AddressMap
-> Eff
     '[State AddressMap, State ChainState, Writer EmulatorLogs]
     (a, Map DatumHash Datum)
-> Eff
     '[State ChainState, Writer EmulatorLogs]
     ((a, Map DatumHash Datum), AddressMap)
forall s (effs :: [* -> *]) a.
s -> Eff (State s : effs) a -> Eff effs (a, s)
runState AddressMap
am
        Eff
  '[State ChainState, Writer EmulatorLogs]
  ((a, Map DatumHash Datum), AddressMap)
-> (Eff
      '[State ChainState, Writer EmulatorLogs]
      ((a, Map DatumHash Datum), AddressMap)
    -> Eff
         '[Writer EmulatorLogs]
         (((a, Map DatumHash Datum), AddressMap), ChainState))
-> Eff
     '[Writer EmulatorLogs]
     (((a, Map DatumHash Datum), AddressMap), ChainState)
forall a b. a -> (a -> b) -> b
& ChainState
-> Eff
     '[State ChainState, Writer EmulatorLogs]
     ((a, Map DatumHash Datum), AddressMap)
-> Eff
     '[Writer EmulatorLogs]
     (((a, Map DatumHash Datum), AddressMap), ChainState)
forall s (effs :: [* -> *]) a.
s -> Eff (State s : effs) a -> Eff effs (a, s)
runState ChainState
chainState
        Eff
  '[Writer EmulatorLogs]
  (((a, Map DatumHash Datum), AddressMap), ChainState)
-> (Eff
      '[Writer EmulatorLogs]
      (((a, Map DatumHash Datum), AddressMap), ChainState)
    -> Eff
         '[]
         ((((a, Map DatumHash Datum), AddressMap), ChainState),
          EmulatorLogs))
-> Eff
     '[]
     ((((a, Map DatumHash Datum), AddressMap), ChainState),
      EmulatorLogs)
forall a b. a -> (a -> b) -> b
& Eff
  '[Writer EmulatorLogs]
  (((a, Map DatumHash Datum), AddressMap), ChainState)
-> Eff
     '[]
     ((((a, Map DatumHash Datum), AddressMap), ChainState),
      EmulatorLogs)
forall w (effs :: [* -> *]) a.
Monoid w =>
Eff (Writer w : effs) a -> Eff effs (a, w)
F.runWriter
        Eff
  '[]
  ((((a, Map DatumHash Datum), AddressMap), ChainState),
   EmulatorLogs)
-> (Eff
      '[]
      ((((a, Map DatumHash Datum), AddressMap), ChainState),
       EmulatorLogs)
    -> ((((a, Map DatumHash Datum), AddressMap), ChainState),
        EmulatorLogs))
-> ((((a, Map DatumHash Datum), AddressMap), ChainState),
    EmulatorLogs)
forall a b. a -> (a -> b) -> b
& Eff
  '[]
  ((((a, Map DatumHash Datum), AddressMap), ChainState),
   EmulatorLogs)
-> ((((a, Map DatumHash Datum), AddressMap), ChainState),
    EmulatorLogs)
forall a. Eff '[] a -> a
run
  EmulatorLogs -> m ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell EmulatorLogs
lg
  EmulatorState -> m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (EmulatorState -> m ()) -> EmulatorState -> m ()
forall a b. (a -> b) -> a -> b
$ ChainState -> AddressMap -> Map DatumHash Datum -> EmulatorState
EmulatorState ChainState
newChainState AddressMap
am' Map DatumHash Datum
dm'
  a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
  where
    handleChainLogs
      :: ( Member (State AM.AddressMap) effs
         , Member (State (Map DatumHash Datum)) effs
         , Member (F.Writer EmulatorLogs) effs
         )
      => L.LogMsg E.ChainEvent ~> Eff effs
    handleChainLogs :: LogMsg ChainEvent ~> Eff effs
handleChainLogs (L.LMessage msg :: LogMessage ChainEvent
msg@(L.LogMessage LogLevel
_ ChainEvent
e)) = do
      EmulatorLogs -> Eff effs ()
forall w (effs :: [* -> *]).
Member (Writer w) effs =>
w -> Eff effs ()
F.tell @EmulatorLogs (LogMessage EmulatorMsg -> EmulatorLogs
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LogMessage EmulatorMsg -> EmulatorLogs)
-> LogMessage EmulatorMsg -> EmulatorLogs
forall a b. (a -> b) -> a -> b
$ ChainEvent -> EmulatorMsg
ChainEvent (ChainEvent -> EmulatorMsg)
-> LogMessage ChainEvent -> LogMessage EmulatorMsg
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LogMessage ChainEvent
msg)
      ChainEvent -> Maybe OnChainTx
E.chainEventOnChainTx ChainEvent
e Maybe OnChainTx -> (Maybe OnChainTx -> Eff effs ()) -> Eff effs ()
forall a b. a -> (a -> b) -> b
& Eff effs ()
-> (OnChainTx -> Eff effs ()) -> Maybe OnChainTx -> Eff effs ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> Eff effs ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) (\OnChainTx
tx -> do
        Eff effs () -> Eff effs ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Eff effs () -> Eff effs ()) -> Eff effs () -> Eff effs ()
forall a b. (a -> b) -> a -> b
$ (AddressMap -> AddressMap) -> Eff effs ()
forall s (effs :: [* -> *]).
Member (State s) effs =>
(s -> s) -> Eff effs ()
modify ((AddressMap -> AddressMap) -> Eff effs ())
-> (AddressMap -> AddressMap) -> Eff effs ()
forall a b. (a -> b) -> a -> b
$ OnChainTx -> AddressMap -> AddressMap
AM.updateAllAddresses OnChainTx
tx
        Eff effs () -> Eff effs ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Eff effs () -> Eff effs ()) -> Eff effs () -> Eff effs ()
forall a b. (a -> b) -> a -> b
$ (Map DatumHash Datum -> Map DatumHash Datum) -> Eff effs ()
forall s (effs :: [* -> *]).
Member (State s) effs =>
(s -> s) -> Eff effs ()
modify ((Map DatumHash Datum -> Map DatumHash Datum) -> Eff effs ())
-> (Map DatumHash Datum -> Map DatumHash Datum) -> Eff effs ()
forall a b. (a -> b) -> a -> b
$ (Map DatumHash Datum -> Map DatumHash Datum -> Map DatumHash Datum
forall a. Semigroup a => a -> a -> a
(<>) (Map DatumHash Datum -> Map DatumHash Datum -> Map DatumHash Datum)
-> (OnChainTx -> Map DatumHash Datum)
-> OnChainTx
-> Map DatumHash Datum
-> Map DatumHash Datum
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CardanoTx -> Map DatumHash Datum)
-> (CardanoTx -> Map DatumHash Datum)
-> OnChainTx
-> Map DatumHash Datum
forall r. (CardanoTx -> r) -> (CardanoTx -> r) -> OnChainTx -> r
eitherTx CardanoTx -> Map DatumHash Datum
getCardanoTxData CardanoTx -> Map DatumHash Datum
getCardanoTxData) OnChainTx
tx
        )

processBlock :: MonadEmulator m => m Block
processBlock :: m Block
processBlock = Eff '[ChainControlEffect, ChainEffect] Block -> m Block
forall (m :: * -> *) a.
MonadEmulator m =>
Eff '[ChainControlEffect, ChainEffect] a -> m a
handleChain Eff '[ChainControlEffect, ChainEffect] Block
forall (effs :: [* -> *]).
Member ChainControlEffect effs =>
Eff effs Block
E.processBlock

modifySlot :: MonadEmulator m => (Slot -> Slot) -> m Slot
modifySlot :: (Slot -> Slot) -> m Slot
modifySlot Slot -> Slot
f = Eff '[ChainControlEffect, ChainEffect] Slot -> m Slot
forall (m :: * -> *) a.
MonadEmulator m =>
Eff '[ChainControlEffect, ChainEffect] a -> m a
handleChain (Eff '[ChainControlEffect, ChainEffect] Slot -> m Slot)
-> Eff '[ChainControlEffect, ChainEffect] Slot -> m Slot
forall a b. (a -> b) -> a -> b
$ (Slot -> Slot) -> Eff '[ChainControlEffect, ChainEffect] Slot
forall (effs :: [* -> *]).
Member ChainControlEffect effs =>
(Slot -> Slot) -> Eff effs Slot
E.modifySlot Slot -> Slot
f