+
{-# LANGUAGE ConstraintKinds #-}
+
{-# LANGUAGE DataKinds #-}
+
{-# 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.MTL (
+
-- * Updating the blockchain
+
-- * Querying the blockchain
+
, hasValidatedTransactionCountOfTotal
+
, EmulatorState(EmulatorState)
+
, emptyEmulatorStateWithInitialDist
+
-- * Running Eff chain effects in MTL
+
import Control.Lens (alaf, makeLenses, view, (%~), (&), (^.))
+
import Control.Monad (void)
+
import Control.Monad.Error.Class (MonadError, throwError)
+
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 (LogMessage (..), LogMsg (..))
+
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.Foldable (toList)
+
import Data.Map qualified as Map
+
import Data.Monoid (Endo (..), Sum (..))
+
import Data.Sequence (Seq)
+
import Data.Text qualified as Text
+
import Prettyprinter qualified as Pretty
+
import Prettyprinter.Render.Text qualified as Pretty
+
import Cardano.Api qualified as C
+
import Cardano.Api.Shelley qualified as C
+
import Cardano.Node.Emulator qualified as E
+
import Ledger (CardanoAddress, CardanoTx, DatumFromQuery, DatumHash, DecoratedTxOut, OnChainTx (..),
+
PaymentPrivateKey (..), ToCardanoError, TxOut (..), TxOutRef, UtxoIndex, ValidationErrorInPhase,
+
import Ledger.AddressMap qualified as AM
+
import Ledger.Index (UtxoIndex (..), createGenesisTransaction, insertBlock)
+
import Ledger.Tx (CardanoTx (..), DatumFromQuery (..), addCardanoTxSignature, decoratedTxOutValue, getCardanoTxId)
+
import Ledger.Tx.CardanoAPI (CardanoBuildTx (..), fromCardanoReferenceScript, fromCardanoScriptData,
+
import Plutus.V2.Ledger.Api qualified as PV2
+
import PlutusTx.Builtins qualified as PlutusTx
+
data EmulatorState = EmulatorState
+
{ _esChainState :: E.ChainState
+
, _esAddressMap :: AM.AddressMap
+
makeLenses 'EmulatorState
+
= BalancingError E.BalancingError
+
| ValidationError ValidationErrorInPhase
+
| ToCardanoError ToCardanoError
+
type MonadEmulator m = (MonadRWS E.Params (Seq E.ChainEvent) EmulatorState m, MonadError EmulatorError m)
+
type EmulatorT m = ExceptT EmulatorError (RWST E.Params (Seq E.ChainEvent) EmulatorState m)
+
type EmulatorM = EmulatorT Identity
+
emptyEmulatorState :: EmulatorState
+
emptyEmulatorState = EmulatorState E.emptyChainState mempty
+
emptyEmulatorStateWithInitialDist :: Map CardanoAddress C.Value -> EmulatorState
+
emptyEmulatorStateWithInitialDist initialDist =
+
let tx = Valid $ createGenesisTransaction initialDist
+
& esChainState . E.chainNewestFirst %~ ([tx] :)
+
& esChainState . E.index %~ insertBlock [tx]
+
& esAddressMap %~ AM.updateAllAddresses tx
+
handleChain :: MonadEmulator m => Eff [E.ChainControlEffect, E.ChainEffect] a -> m a
+
EmulatorState chainState am <- get
+
let (((a, am') , newChainState), lg) = raiseEnd eff
+
& interpret (E.handleControlChain params)
+
& interpret (E.handleChain params)
+
& interpret handleChainLogs
+
put $ EmulatorState newChainState am'
+
:: ( Member (State AM.AddressMap) effs
+
, Member (F.Writer (Seq E.ChainEvent)) effs
+
=> LogMsg E.ChainEvent ~> Eff effs
+
handleChainLogs (LMessage (LogMessage _ e)) = do
+
F.tell @(Seq E.ChainEvent) (pure e)
+
void $ modify $ alaf Endo foldMap AM.updateAllAddresses $ E.chainEventOnChainTx e
+
-- | Queue the transaction, it will be processed when @nextSlot@ is called.
+
queueTx :: MonadEmulator m => CardanoTx -> m ()
+
queueTx tx = handleChain (E.queueTx tx)
+
-- | Process the queued transactions and increase the slot number.
+
nextSlot :: MonadEmulator m => m ()
+
nextSlot = handleChain $ do
+
void $ E.modifySlot succ
+
-- | Query the unspent transaction outputs at the given address.
+
utxosAt :: MonadEmulator m => CardanoAddress -> m (Map TxOutRef DecoratedTxOut)
+
pure $ Map.mapMaybe toDecoratedTxOut $ es ^. esAddressMap . AM.fundsAt addr
+
toDecoratedTxOut :: (CardanoTx, TxOut) -> Maybe DecoratedTxOut
+
toDecoratedTxOut (_, TxOut (C.TxOut addr' val dt rs)) =
+
mkDecoratedTxOut addr' (C.txOutValueToValue val) (toDecoratedDatum dt) (fromCardanoReferenceScript rs)
+
toDecoratedDatum :: C.TxOutDatum C.CtxTx C.BabbageEra -> Maybe (DatumHash, DatumFromQuery)
+
toDecoratedDatum C.TxOutDatumNone =
+
toDecoratedDatum (C.TxOutDatumHash _ h) =
+
Just (PV2.DatumHash $ PlutusTx.toBuiltin (C.serialiseToRawBytes h), DatumUnknown)
+
toDecoratedDatum (C.TxOutDatumInTx _ d) =
+
Just (PV2.DatumHash $ PlutusTx.toBuiltin (C.serialiseToRawBytes (C.hashScriptData d)), DatumInBody $ PV2.Datum $ fromCardanoScriptData d)
+
toDecoratedDatum (C.TxOutDatumInline _ d) =
+
Just (PV2.DatumHash $ PlutusTx.toBuiltin (C.serialiseToRawBytes (C.hashScriptData d)), DatumInline $ PV2.Datum $ fromCardanoScriptData d)
+
-- | Query the total value of the unspent transaction outputs at the given address.
+
fundsAt :: MonadEmulator m => CardanoAddress -> m C.Value
+
fundsAt addr = foldMap (view decoratedTxOutValue) <$> utxosAt addr
+
-- | Balance an unbalanced transaction, using funds from the given wallet if needed, and returning any remaining value to the same wallet.
+
=> UtxoIndex -- ^ Just the transaction inputs, not the entire 'UTxO'.
+
-> CardanoAddress -- ^ Wallet address
+
balanceTx utxoIndex changeAddr utx = do
+
ownUtxos = UtxoIndex $ snd <$> es ^. esAddressMap . AM.fundsAt changeAddr
+
utxoProvider = E.utxoProviderFromWalletOutputs ownUtxos utx
+
CardanoEmulatorEraTx <$> E.makeAutoBalancedTransactionWithUtxoProvider
+
(either (throwError . BalancingError) pure . utxoProvider)
+
(throwError . either ValidationError ToCardanoError)
+
-- | Balance a transaction, sign it with the given signatures, and finally queue it.
+
:: (MonadEmulator m, Foldable f)
+
=> UtxoIndex -- ^ Just the transaction inputs, not the entire 'UTxO'.
+
-> CardanoAddress -- ^ Wallet address
+
-> f PaymentPrivateKey -- ^ Signatures
+
submitUnbalancedTx utxoIndex changeAddr utx keys = do
+
newTx <- balanceTx utxoIndex changeAddr utx
+
let signedTx = foldr (addCardanoTxSignature . unPaymentPrivateKey) newTx keys
+
-- | Create a transaction that transfers funds from one address to another, and sign and submit it.
+
payToAddress :: MonadEmulator m => (CardanoAddress, PaymentPrivateKey) -> CardanoAddress -> C.Value -> m PV2.TxId
+
payToAddress (sourceAddr, sourcePrivKey) targetAddr value = do
+
let buildTx = CardanoBuildTx $ E.emptyTxBodyContent
