{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds       #-}
{-# LANGUAGE GADTs           #-}
-- | 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.API (
  -- * Updating the blockchain
    queueTx
  , nextSlot
  , currentSlot
  , awaitSlot
  -- * Querying the blockchain
  , utxosAt
  , utxosAtPlutus
  , utxoAtTxOutRef
  , utxoAtTxOutRefPlutus
  , fundsAt
  , lookupDatum
  -- * Transactions
  , balanceTx
  , signTx
  , submitUnbalancedTx
  , submitTxConfirmed
  , payToAddress
  -- * Logging
  , logDebug
  , logInfo
  , logWarn
  , logError
  -- * Types
  , EmulatorState(EmulatorState)
  , esChainState
  , esAddressMap
  , esDatumMap
  , EmulatorError(..)
  , EmulatorLogs
  , EmulatorMsg(..)
  , L.LogMessage(..)
  , MonadEmulator
  , EmulatorT
  , EmulatorM
  , emptyEmulatorState
  , emptyEmulatorStateWithInitialDist
  , getParams
) where

import Cardano.Api qualified as C
import Cardano.Api.Shelley qualified as C
import Cardano.Node.Emulator.Internal.API (EmulatorError (BalancingError, ToCardanoError, ValidationError),
                                           EmulatorLogs, EmulatorM, EmulatorState (EmulatorState), EmulatorT,
                                           MonadEmulator, esAddressMap, esChainState, esDatumMap, handleChain,
                                           modifySlot, processBlock)
import Control.Lens ((%~), (&), (<>~), (^.))
import Control.Monad (void)
import Control.Monad.Error.Class (throwError)
import Control.Monad.Freer.Extras.Log qualified as L
import Control.Monad.RWS.Class (ask, get, tell)
import Data.Aeson (ToJSON (toJSON))
import Data.Map (Map)
import Data.Map qualified as Map
import Ledger (CardanoAddress, CardanoTx (CardanoEmulatorEraTx), Datum, DatumHash, DecoratedTxOut,
               PaymentPrivateKey (unPaymentPrivateKey), Slot, TxOutRef, UtxoIndex)
import Ledger.AddressMap qualified as AM
import Ledger.Index (createGenesisTransaction, insertBlock)
import Ledger.Tx (TxOut, addCardanoTxSignature, cardanoTxOutValue, getCardanoTxData, getCardanoTxId, toCtxUTxOTxOut,
                  toDecoratedTxOut)
import Ledger.Tx.CardanoAPI (CardanoBuildTx (CardanoBuildTx), fromCardanoTxIn, toCardanoTxIn, toCardanoTxOutValue)

import Cardano.Node.Emulator.Generators qualified as G
import Cardano.Node.Emulator.Internal.Node.Chain qualified as E (chainNewestFirst, emptyChainState, getCurrentSlot,
                                                                 index, queueTx)
import Cardano.Node.Emulator.Internal.Node.Fee qualified as E (makeAutoBalancedTransactionWithUtxoProvider,
                                                               utxoProviderFromWalletOutputs)
import Cardano.Node.Emulator.Internal.Node.Params qualified as E (Params)
import Cardano.Node.Emulator.Internal.Node.Validation (unsafeMakeValid)
import Cardano.Node.Emulator.LogMessages (EmulatorMsg (ChainEvent, GenericMsg, TxBalanceMsg),
                                          TxBalanceMsg (BalancingUnbalancedTx, FinishedBalancing, SigningTx, SubmittingTx))

emptyEmulatorState :: EmulatorState
emptyEmulatorState :: EmulatorState
emptyEmulatorState = ChainState -> AddressMap -> Map DatumHash Datum -> EmulatorState
EmulatorState ChainState
E.emptyChainState AddressMap
forall a. Monoid a => a
mempty Map DatumHash Datum
forall a. Monoid a => a
mempty

emptyEmulatorStateWithInitialDist :: Map CardanoAddress C.Value -> EmulatorState
emptyEmulatorStateWithInitialDist :: Map CardanoAddress Value -> EmulatorState
emptyEmulatorStateWithInitialDist Map CardanoAddress Value
initialDist =
  let tx :: CardanoTx
tx = Map CardanoAddress Value -> CardanoTx
createGenesisTransaction Map CardanoAddress Value
initialDist
      vtx :: OnChainTx
vtx = CardanoTx -> OnChainTx
unsafeMakeValid CardanoTx
tx
  in EmulatorState
emptyEmulatorState
    EmulatorState -> (EmulatorState -> EmulatorState) -> EmulatorState
forall a b. a -> (a -> b) -> b
& (ChainState -> Identity ChainState)
-> EmulatorState -> Identity EmulatorState
Lens' EmulatorState ChainState
esChainState ((ChainState -> Identity ChainState)
 -> EmulatorState -> Identity EmulatorState)
-> ((Blockchain -> Identity Blockchain)
    -> ChainState -> Identity ChainState)
-> (Blockchain -> Identity Blockchain)
-> EmulatorState
-> Identity EmulatorState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Blockchain -> Identity Blockchain)
-> ChainState -> Identity ChainState
Lens' ChainState Blockchain
E.chainNewestFirst ((Blockchain -> Identity Blockchain)
 -> EmulatorState -> Identity EmulatorState)
-> (Blockchain -> Blockchain) -> EmulatorState -> EmulatorState
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ ([OnChainTx
vtx] [OnChainTx] -> Blockchain -> Blockchain
forall a. a -> [a] -> [a]
:)
    EmulatorState -> (EmulatorState -> EmulatorState) -> EmulatorState
forall a b. a -> (a -> b) -> b
& (ChainState -> Identity ChainState)
-> EmulatorState -> Identity EmulatorState
Lens' EmulatorState ChainState
esChainState ((ChainState -> Identity ChainState)
 -> EmulatorState -> Identity EmulatorState)
-> ((UtxoIndex -> Identity UtxoIndex)
    -> ChainState -> Identity ChainState)
-> (UtxoIndex -> Identity UtxoIndex)
-> EmulatorState
-> Identity EmulatorState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UtxoIndex -> Identity UtxoIndex)
-> ChainState -> Identity ChainState
Lens' ChainState UtxoIndex
E.index ((UtxoIndex -> Identity UtxoIndex)
 -> EmulatorState -> Identity EmulatorState)
-> (UtxoIndex -> UtxoIndex) -> EmulatorState -> EmulatorState
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ [OnChainTx] -> UtxoIndex -> UtxoIndex
insertBlock [OnChainTx
vtx]
    EmulatorState -> (EmulatorState -> EmulatorState) -> EmulatorState
forall a b. a -> (a -> b) -> b
& (AddressMap -> Identity AddressMap)
-> EmulatorState -> Identity EmulatorState
Lens' EmulatorState AddressMap
esAddressMap ((AddressMap -> Identity AddressMap)
 -> EmulatorState -> Identity EmulatorState)
-> (AddressMap -> AddressMap) -> EmulatorState -> EmulatorState
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ OnChainTx -> AddressMap -> AddressMap
AM.updateAllAddresses OnChainTx
vtx
    EmulatorState -> (EmulatorState -> EmulatorState) -> EmulatorState
forall a b. a -> (a -> b) -> b
& (Map DatumHash Datum -> Identity (Map DatumHash Datum))
-> EmulatorState -> Identity EmulatorState
Lens' EmulatorState (Map DatumHash Datum)
esDatumMap ((Map DatumHash Datum -> Identity (Map DatumHash Datum))
 -> EmulatorState -> Identity EmulatorState)
-> Map DatumHash Datum -> EmulatorState -> EmulatorState
forall a s t. Semigroup a => ASetter s t a a -> a -> s -> t
<>~ CardanoTx -> Map DatumHash Datum
getCardanoTxData CardanoTx
tx

getParams :: MonadEmulator m => m E.Params
getParams :: m Params
getParams = m Params
forall r (m :: * -> *). MonadReader r m => m r
ask

-- | Queue the transaction, it will be processed when @nextSlot@ is called.
queueTx :: MonadEmulator m => CardanoTx -> m ()
queueTx :: CardanoTx -> m ()
queueTx CardanoTx
tx = do
  LogLevel -> EmulatorMsg -> m ()
forall (m :: * -> *).
MonadEmulator m =>
LogLevel -> EmulatorMsg -> m ()
logMsg LogLevel
L.Info (EmulatorMsg -> m ()) -> EmulatorMsg -> m ()
forall a b. (a -> b) -> a -> b
$ TxBalanceMsg -> EmulatorMsg
TxBalanceMsg (TxBalanceMsg -> EmulatorMsg) -> TxBalanceMsg -> EmulatorMsg
forall a b. (a -> b) -> a -> b
$ CardanoTx -> TxBalanceMsg
SubmittingTx CardanoTx
tx
  Eff '[ChainControlEffect, ChainEffect] () -> m ()
forall (m :: * -> *) a.
MonadEmulator m =>
Eff '[ChainControlEffect, ChainEffect] a -> m a
handleChain (CardanoTx -> Eff '[ChainControlEffect, ChainEffect] ()
forall (effs :: [* -> *]).
Member ChainEffect effs =>
CardanoTx -> Eff effs ()
E.queueTx CardanoTx
tx)

-- | Process the queued transactions and increase the slot number.
nextSlot :: MonadEmulator m => m ()
nextSlot :: m ()
nextSlot = do
  m [OnChainTx] -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m [OnChainTx] -> m ()) -> m [OnChainTx] -> m ()
forall a b. (a -> b) -> a -> b
$ m [OnChainTx]
forall (m :: * -> *). MonadEmulator m => m [OnChainTx]
processBlock
  m Slot -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m Slot -> m ()) -> m Slot -> m ()
forall a b. (a -> b) -> a -> b
$ (Slot -> Slot) -> m Slot
forall (m :: * -> *). MonadEmulator m => (Slot -> Slot) -> m Slot
modifySlot Slot -> Slot
forall a. Enum a => a -> a
succ

-- | Get the current slot number of the emulated node.
currentSlot :: MonadEmulator m => m Slot
currentSlot :: m Slot
currentSlot = Eff '[ChainControlEffect, ChainEffect] Slot -> m Slot
forall (m :: * -> *) a.
MonadEmulator m =>
Eff '[ChainControlEffect, ChainEffect] a -> m a
handleChain Eff '[ChainControlEffect, ChainEffect] Slot
forall (effs :: [* -> *]). Member ChainEffect effs => Eff effs Slot
E.getCurrentSlot

-- | Call `nextSlot` until the current slot number equals or exceeds the given slot number.
awaitSlot :: MonadEmulator m => Slot -> m ()
awaitSlot :: Slot -> m ()
awaitSlot Slot
s = do
  Slot
c <- m Slot
forall (m :: * -> *). MonadEmulator m => m Slot
currentSlot
  if Slot
s Slot -> Slot -> Bool
forall a. Ord a => a -> a -> Bool
<= Slot
c then () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  else do
    m ()
forall (m :: * -> *). MonadEmulator m => m ()
nextSlot
    Slot -> m ()
forall (m :: * -> *). MonadEmulator m => Slot -> m ()
awaitSlot Slot
s


-- | Query the unspent transaction outputs at the given address.
utxosAt :: MonadEmulator m => CardanoAddress -> m UtxoIndex
utxosAt :: CardanoAddress -> m UtxoIndex
utxosAt CardanoAddress
addr = do
  EmulatorState
es <- m EmulatorState
forall s (m :: * -> *). MonadState s m => m s
get
  UtxoIndex -> m UtxoIndex
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UtxoIndex -> m UtxoIndex) -> UtxoIndex -> m UtxoIndex
forall a b. (a -> b) -> a -> b
$ Map TxIn (TxOut CtxUTxO BabbageEra) -> UtxoIndex
forall era. Map TxIn (TxOut CtxUTxO era) -> UTxO era
C.UTxO (Map TxIn (TxOut CtxUTxO BabbageEra) -> UtxoIndex)
-> Map TxIn (TxOut CtxUTxO BabbageEra) -> UtxoIndex
forall a b. (a -> b) -> a -> b
$ ((CardanoTx, TxOut) -> TxOut CtxUTxO BabbageEra)
-> Map TxIn (CardanoTx, TxOut)
-> Map TxIn (TxOut CtxUTxO BabbageEra)
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (TxOut -> TxOut CtxUTxO BabbageEra
toCtxUTxOTxOut (TxOut -> TxOut CtxUTxO BabbageEra)
-> ((CardanoTx, TxOut) -> TxOut)
-> (CardanoTx, TxOut)
-> TxOut CtxUTxO BabbageEra
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CardanoTx, TxOut) -> TxOut
forall a b. (a, b) -> b
snd) (Map TxIn (CardanoTx, TxOut)
 -> Map TxIn (TxOut CtxUTxO BabbageEra))
-> Map TxIn (CardanoTx, TxOut)
-> Map TxIn (TxOut CtxUTxO BabbageEra)
forall a b. (a -> b) -> a -> b
$ EmulatorState
es EmulatorState
-> Getting
     (Map TxIn (CardanoTx, TxOut))
     EmulatorState
     (Map TxIn (CardanoTx, TxOut))
-> Map TxIn (CardanoTx, TxOut)
forall s a. s -> Getting a s a -> a
^. (AddressMap -> Const (Map TxIn (CardanoTx, TxOut)) AddressMap)
-> EmulatorState
-> Const (Map TxIn (CardanoTx, TxOut)) EmulatorState
Lens' EmulatorState AddressMap
esAddressMap ((AddressMap -> Const (Map TxIn (CardanoTx, TxOut)) AddressMap)
 -> EmulatorState
 -> Const (Map TxIn (CardanoTx, TxOut)) EmulatorState)
-> ((Map TxIn (CardanoTx, TxOut)
     -> Const
          (Map TxIn (CardanoTx, TxOut)) (Map TxIn (CardanoTx, TxOut)))
    -> AddressMap -> Const (Map TxIn (CardanoTx, TxOut)) AddressMap)
-> Getting
     (Map TxIn (CardanoTx, TxOut))
     EmulatorState
     (Map TxIn (CardanoTx, TxOut))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CardanoAddress -> Lens' AddressMap (Map TxIn (CardanoTx, TxOut))
AM.fundsAt CardanoAddress
addr

-- | Query the unspent transaction outputs at the given address (using Plutus types).
utxosAtPlutus :: MonadEmulator m => CardanoAddress -> m (Map TxOutRef DecoratedTxOut)
utxosAtPlutus :: CardanoAddress -> m (Map TxOutRef DecoratedTxOut)
utxosAtPlutus CardanoAddress
addr = do
  EmulatorState
es <- m EmulatorState
forall s (m :: * -> *). MonadState s m => m s
get
  Map TxOutRef DecoratedTxOut -> m (Map TxOutRef DecoratedTxOut)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map TxOutRef DecoratedTxOut -> m (Map TxOutRef DecoratedTxOut))
-> Map TxOutRef DecoratedTxOut -> m (Map TxOutRef DecoratedTxOut)
forall a b. (a -> b) -> a -> b
$ (TxIn -> TxOutRef)
-> Map TxIn DecoratedTxOut -> Map TxOutRef DecoratedTxOut
forall k2 k1 a. Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a
Map.mapKeys TxIn -> TxOutRef
fromCardanoTxIn (Map TxIn DecoratedTxOut -> Map TxOutRef DecoratedTxOut)
-> Map TxIn DecoratedTxOut -> Map TxOutRef DecoratedTxOut
forall a b. (a -> b) -> a -> b
$ ((CardanoTx, TxOut) -> Maybe DecoratedTxOut)
-> Map TxIn (CardanoTx, TxOut) -> Map TxIn DecoratedTxOut
forall a b k. (a -> Maybe b) -> Map k a -> Map k b
Map.mapMaybe (TxOut -> Maybe DecoratedTxOut
toDecoratedTxOut (TxOut -> Maybe DecoratedTxOut)
-> ((CardanoTx, TxOut) -> TxOut)
-> (CardanoTx, TxOut)
-> Maybe DecoratedTxOut
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CardanoTx, TxOut) -> TxOut
forall a b. (a, b) -> b
snd) (Map TxIn (CardanoTx, TxOut) -> Map TxIn DecoratedTxOut)
-> Map TxIn (CardanoTx, TxOut) -> Map TxIn DecoratedTxOut
forall a b. (a -> b) -> a -> b
$ EmulatorState
es EmulatorState
-> Getting
     (Map TxIn (CardanoTx, TxOut))
     EmulatorState
     (Map TxIn (CardanoTx, TxOut))
-> Map TxIn (CardanoTx, TxOut)
forall s a. s -> Getting a s a -> a
^. (AddressMap -> Const (Map TxIn (CardanoTx, TxOut)) AddressMap)
-> EmulatorState
-> Const (Map TxIn (CardanoTx, TxOut)) EmulatorState
Lens' EmulatorState AddressMap
esAddressMap ((AddressMap -> Const (Map TxIn (CardanoTx, TxOut)) AddressMap)
 -> EmulatorState
 -> Const (Map TxIn (CardanoTx, TxOut)) EmulatorState)
-> ((Map TxIn (CardanoTx, TxOut)
     -> Const
          (Map TxIn (CardanoTx, TxOut)) (Map TxIn (CardanoTx, TxOut)))
    -> AddressMap -> Const (Map TxIn (CardanoTx, TxOut)) AddressMap)
-> Getting
     (Map TxIn (CardanoTx, TxOut))
     EmulatorState
     (Map TxIn (CardanoTx, TxOut))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CardanoAddress -> Lens' AddressMap (Map TxIn (CardanoTx, TxOut))
AM.fundsAt CardanoAddress
addr

-- | Resolve the transaction output reference.
utxoAtTxOutRef :: MonadEmulator m => C.TxIn -> m (Maybe TxOut)
utxoAtTxOutRef :: TxIn -> m (Maybe TxOut)
utxoAtTxOutRef TxIn
txIn = do
  EmulatorState
es <- m EmulatorState
forall s (m :: * -> *). MonadState s m => m s
get
  Maybe TxOut -> m (Maybe TxOut)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe TxOut -> m (Maybe TxOut)) -> Maybe TxOut -> m (Maybe TxOut)
forall a b. (a -> b) -> a -> b
$ TxIn -> AddressMap -> Maybe TxOut
AM.lookupOutRef TxIn
txIn (EmulatorState
es EmulatorState
-> Getting AddressMap EmulatorState AddressMap -> AddressMap
forall s a. s -> Getting a s a -> a
^. Getting AddressMap EmulatorState AddressMap
Lens' EmulatorState AddressMap
esAddressMap)

-- | Resolve the transaction output reference (using Plutus types).
utxoAtTxOutRefPlutus :: MonadEmulator m => TxOutRef -> m (Maybe DecoratedTxOut)
utxoAtTxOutRefPlutus :: TxOutRef -> m (Maybe DecoratedTxOut)
utxoAtTxOutRefPlutus TxOutRef
ref = (ToCardanoError -> m (Maybe DecoratedTxOut))
-> (TxIn -> m (Maybe DecoratedTxOut))
-> Either ToCardanoError TxIn
-> m (Maybe DecoratedTxOut)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (m (Maybe DecoratedTxOut)
-> ToCardanoError -> m (Maybe DecoratedTxOut)
forall a b. a -> b -> a
const (m (Maybe DecoratedTxOut)
 -> ToCardanoError -> m (Maybe DecoratedTxOut))
-> m (Maybe DecoratedTxOut)
-> ToCardanoError
-> m (Maybe DecoratedTxOut)
forall a b. (a -> b) -> a -> b
$ Maybe DecoratedTxOut -> m (Maybe DecoratedTxOut)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe DecoratedTxOut
forall a. Maybe a
Nothing) TxIn -> m (Maybe DecoratedTxOut)
forall (m :: * -> *).
MonadState EmulatorState m =>
TxIn -> m (Maybe DecoratedTxOut)
findTxOut (TxOutRef -> Either ToCardanoError TxIn
toCardanoTxIn TxOutRef
ref)
  where
    findTxOut :: TxIn -> m (Maybe DecoratedTxOut)
findTxOut TxIn
txIn = do
      EmulatorState
es <- m EmulatorState
forall s (m :: * -> *). MonadState s m => m s
get
      let mTxOut :: Maybe TxOut
mTxOut = TxIn -> AddressMap -> Maybe TxOut
AM.lookupOutRef TxIn
txIn (EmulatorState
es EmulatorState
-> Getting AddressMap EmulatorState AddressMap -> AddressMap
forall s a. s -> Getting a s a -> a
^. Getting AddressMap EmulatorState AddressMap
Lens' EmulatorState AddressMap
esAddressMap)
      Maybe DecoratedTxOut -> m (Maybe DecoratedTxOut)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe DecoratedTxOut -> m (Maybe DecoratedTxOut))
-> Maybe DecoratedTxOut -> m (Maybe DecoratedTxOut)
forall a b. (a -> b) -> a -> b
$ Maybe TxOut
mTxOut Maybe TxOut
-> (TxOut -> Maybe DecoratedTxOut) -> Maybe DecoratedTxOut
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TxOut -> Maybe DecoratedTxOut
toDecoratedTxOut

-- | Query the total value of the unspent transaction outputs at the given address.
fundsAt :: MonadEmulator m => CardanoAddress -> m C.Value
fundsAt :: CardanoAddress -> m Value
fundsAt CardanoAddress
addr = (TxOut CtxUTxO BabbageEra -> Value)
-> Map TxIn (TxOut CtxUTxO BabbageEra) -> Value
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap TxOut CtxUTxO BabbageEra -> Value
forall ctx era. TxOut ctx era -> Value
cardanoTxOutValue (Map TxIn (TxOut CtxUTxO BabbageEra) -> Value)
-> (UtxoIndex -> Map TxIn (TxOut CtxUTxO BabbageEra))
-> UtxoIndex
-> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UtxoIndex -> Map TxIn (TxOut CtxUTxO BabbageEra)
forall era. UTxO era -> Map TxIn (TxOut CtxUTxO era)
C.unUTxO (UtxoIndex -> Value) -> m UtxoIndex -> m Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CardanoAddress -> m UtxoIndex
forall (m :: * -> *).
MonadEmulator m =>
CardanoAddress -> m UtxoIndex
utxosAt CardanoAddress
addr

-- | Resolve a datum hash to an actual datum, if known.
lookupDatum :: MonadEmulator m => DatumHash -> m (Maybe Datum)
lookupDatum :: DatumHash -> m (Maybe Datum)
lookupDatum DatumHash
h = do
  EmulatorState
es <- m EmulatorState
forall s (m :: * -> *). MonadState s m => m s
get
  Maybe Datum -> m (Maybe Datum)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Datum -> m (Maybe Datum)) -> Maybe Datum -> m (Maybe Datum)
forall a b. (a -> b) -> a -> b
$ DatumHash -> Map DatumHash Datum -> Maybe Datum
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup DatumHash
h (EmulatorState
es EmulatorState
-> Getting
     (Map DatumHash Datum) EmulatorState (Map DatumHash Datum)
-> Map DatumHash Datum
forall s a. s -> Getting a s a -> a
^. Getting (Map DatumHash Datum) EmulatorState (Map DatumHash Datum)
Lens' EmulatorState (Map DatumHash Datum)
esDatumMap)


-- | Balance an unbalanced transaction, using funds from the given wallet if needed, and returning any remaining value to the same wallet.
balanceTx
  :: MonadEmulator m
  => UtxoIndex -- ^ Just the transaction inputs, not the entire 'UTxO'.
  -> CardanoAddress -- ^ Wallet address
  -> CardanoBuildTx
  -> m CardanoTx
balanceTx :: UtxoIndex -> CardanoAddress -> CardanoBuildTx -> m CardanoTx
balanceTx UtxoIndex
utxoIndex CardanoAddress
changeAddr CardanoBuildTx
utx = do
  LogLevel -> EmulatorMsg -> m ()
forall (m :: * -> *).
MonadEmulator m =>
LogLevel -> EmulatorMsg -> m ()
logMsg LogLevel
L.Info (EmulatorMsg -> m ()) -> EmulatorMsg -> m ()
forall a b. (a -> b) -> a -> b
$ TxBalanceMsg -> EmulatorMsg
TxBalanceMsg (TxBalanceMsg -> EmulatorMsg) -> TxBalanceMsg -> EmulatorMsg
forall a b. (a -> b) -> a -> b
$ CardanoBuildTx -> UtxoIndex -> TxBalanceMsg
BalancingUnbalancedTx CardanoBuildTx
utx UtxoIndex
utxoIndex
  Params
params <- m Params
forall r (m :: * -> *). MonadReader r m => m r
ask
  EmulatorState
es <- m EmulatorState
forall s (m :: * -> *). MonadState s m => m s
get
  let
    ownUtxos :: UtxoIndex
ownUtxos = Map TxIn (TxOut CtxUTxO BabbageEra) -> UtxoIndex
forall era. Map TxIn (TxOut CtxUTxO era) -> UTxO era
C.UTxO (Map TxIn (TxOut CtxUTxO BabbageEra) -> UtxoIndex)
-> Map TxIn (TxOut CtxUTxO BabbageEra) -> UtxoIndex
forall a b. (a -> b) -> a -> b
$ TxOut -> TxOut CtxUTxO BabbageEra
toCtxUTxOTxOut (TxOut -> TxOut CtxUTxO BabbageEra)
-> ((CardanoTx, TxOut) -> TxOut)
-> (CardanoTx, TxOut)
-> TxOut CtxUTxO BabbageEra
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CardanoTx, TxOut) -> TxOut
forall a b. (a, b) -> b
snd ((CardanoTx, TxOut) -> TxOut CtxUTxO BabbageEra)
-> Map TxIn (CardanoTx, TxOut)
-> Map TxIn (TxOut CtxUTxO BabbageEra)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> EmulatorState
es EmulatorState
-> Getting
     (Map TxIn (CardanoTx, TxOut))
     EmulatorState
     (Map TxIn (CardanoTx, TxOut))
-> Map TxIn (CardanoTx, TxOut)
forall s a. s -> Getting a s a -> a
^. (AddressMap -> Const (Map TxIn (CardanoTx, TxOut)) AddressMap)
-> EmulatorState
-> Const (Map TxIn (CardanoTx, TxOut)) EmulatorState
Lens' EmulatorState AddressMap
esAddressMap ((AddressMap -> Const (Map TxIn (CardanoTx, TxOut)) AddressMap)
 -> EmulatorState
 -> Const (Map TxIn (CardanoTx, TxOut)) EmulatorState)
-> ((Map TxIn (CardanoTx, TxOut)
     -> Const
          (Map TxIn (CardanoTx, TxOut)) (Map TxIn (CardanoTx, TxOut)))
    -> AddressMap -> Const (Map TxIn (CardanoTx, TxOut)) AddressMap)
-> Getting
     (Map TxIn (CardanoTx, TxOut))
     EmulatorState
     (Map TxIn (CardanoTx, TxOut))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CardanoAddress -> Lens' AddressMap (Map TxIn (CardanoTx, TxOut))
AM.fundsAt CardanoAddress
changeAddr
    utxoProvider :: UtxoProvider (Either BalancingError)
utxoProvider = UtxoIndex -> CardanoBuildTx -> UtxoProvider (Either BalancingError)
E.utxoProviderFromWalletOutputs UtxoIndex
ownUtxos CardanoBuildTx
utx
  CardanoTx
tx <- Tx BabbageEra -> CardanoTx
CardanoEmulatorEraTx (Tx BabbageEra -> CardanoTx) -> m (Tx BabbageEra) -> m CardanoTx
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Params
-> UtxoIndex
-> CardanoAddress
-> UtxoProvider m
-> (forall a. CardanoLedgerError -> m a)
-> CardanoBuildTx
-> m (Tx BabbageEra)
forall (m :: * -> *).
Monad m =>
Params
-> UtxoIndex
-> CardanoAddress
-> UtxoProvider m
-> (forall a. CardanoLedgerError -> m a)
-> CardanoBuildTx
-> m (Tx BabbageEra)
E.makeAutoBalancedTransactionWithUtxoProvider
      Params
params
      UtxoIndex
utxoIndex
      CardanoAddress
changeAddr
      ((BalancingError -> m (UtxoIndex, Value))
-> ((UtxoIndex, Value) -> m (UtxoIndex, Value))
-> Either BalancingError (UtxoIndex, Value)
-> m (UtxoIndex, Value)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (EmulatorError -> m (UtxoIndex, Value)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (EmulatorError -> m (UtxoIndex, Value))
-> (BalancingError -> EmulatorError)
-> BalancingError
-> m (UtxoIndex, Value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BalancingError -> EmulatorError
BalancingError) (UtxoIndex, Value) -> m (UtxoIndex, Value)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either BalancingError (UtxoIndex, Value) -> m (UtxoIndex, Value))
-> UtxoProvider (Either BalancingError) -> UtxoProvider m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UtxoProvider (Either BalancingError)
utxoProvider)
      (EmulatorError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (EmulatorError -> m a)
-> (CardanoLedgerError -> EmulatorError)
-> CardanoLedgerError
-> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ValidationErrorInPhase -> EmulatorError)
-> (ToCardanoError -> EmulatorError)
-> CardanoLedgerError
-> EmulatorError
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ValidationErrorInPhase -> EmulatorError
ValidationError ToCardanoError -> EmulatorError
ToCardanoError)
      CardanoBuildTx
utx
  LogLevel -> EmulatorMsg -> m ()
forall (m :: * -> *).
MonadEmulator m =>
LogLevel -> EmulatorMsg -> m ()
logMsg LogLevel
L.Info (EmulatorMsg -> m ()) -> EmulatorMsg -> m ()
forall a b. (a -> b) -> a -> b
$ TxBalanceMsg -> EmulatorMsg
TxBalanceMsg (TxBalanceMsg -> EmulatorMsg) -> TxBalanceMsg -> EmulatorMsg
forall a b. (a -> b) -> a -> b
$ CardanoTx -> TxBalanceMsg
FinishedBalancing CardanoTx
tx
  CardanoTx -> m CardanoTx
forall (f :: * -> *) a. Applicative f => a -> f a
pure CardanoTx
tx

-- | Sign a transaction with the given signatures.
signTx
  :: (MonadEmulator m, Foldable f)
  => f PaymentPrivateKey -- ^ Signatures
  -> CardanoTx
  -> m CardanoTx
signTx :: f PaymentPrivateKey -> CardanoTx -> m CardanoTx
signTx f PaymentPrivateKey
keys CardanoTx
tx = do
  LogLevel -> EmulatorMsg -> m ()
forall (m :: * -> *).
MonadEmulator m =>
LogLevel -> EmulatorMsg -> m ()
logMsg LogLevel
L.Info (EmulatorMsg -> m ()) -> EmulatorMsg -> m ()
forall a b. (a -> b) -> a -> b
$ TxBalanceMsg -> EmulatorMsg
TxBalanceMsg (TxBalanceMsg -> EmulatorMsg) -> TxBalanceMsg -> EmulatorMsg
forall a b. (a -> b) -> a -> b
$ CardanoTx -> TxBalanceMsg
SigningTx CardanoTx
tx
  CardanoTx -> m CardanoTx
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CardanoTx -> m CardanoTx) -> CardanoTx -> m CardanoTx
forall a b. (a -> b) -> a -> b
$ (PaymentPrivateKey -> CardanoTx -> CardanoTx)
-> CardanoTx -> f PaymentPrivateKey -> CardanoTx
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (PrivateKey -> CardanoTx -> CardanoTx
addCardanoTxSignature (PrivateKey -> CardanoTx -> CardanoTx)
-> (PaymentPrivateKey -> PrivateKey)
-> PaymentPrivateKey
-> CardanoTx
-> CardanoTx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PaymentPrivateKey -> PrivateKey
unPaymentPrivateKey) CardanoTx
tx f PaymentPrivateKey
keys

-- | Balance a transaction, sign it with the given signatures, and finally queue it.
submitUnbalancedTx
  :: (MonadEmulator m, Foldable f)
  => UtxoIndex -- ^ Just the transaction inputs, not the entire 'UTxO'.
  -> CardanoAddress -- ^ Wallet address
  -> f PaymentPrivateKey -- ^ Signatures
  -> CardanoBuildTx
  -> m CardanoTx
submitUnbalancedTx :: UtxoIndex
-> CardanoAddress
-> f PaymentPrivateKey
-> CardanoBuildTx
-> m CardanoTx
submitUnbalancedTx UtxoIndex
utxoIndex CardanoAddress
changeAddr f PaymentPrivateKey
keys CardanoBuildTx
utx = do
  CardanoTx
newTx <- UtxoIndex -> CardanoAddress -> CardanoBuildTx -> m CardanoTx
forall (m :: * -> *).
MonadEmulator m =>
UtxoIndex -> CardanoAddress -> CardanoBuildTx -> m CardanoTx
balanceTx UtxoIndex
utxoIndex CardanoAddress
changeAddr CardanoBuildTx
utx
  CardanoTx
signedTx <- f PaymentPrivateKey -> CardanoTx -> m CardanoTx
forall (m :: * -> *) (f :: * -> *).
(MonadEmulator m, Foldable f) =>
f PaymentPrivateKey -> CardanoTx -> m CardanoTx
signTx f PaymentPrivateKey
keys CardanoTx
newTx
  CardanoTx -> m ()
forall (m :: * -> *). MonadEmulator m => CardanoTx -> m ()
queueTx CardanoTx
signedTx
  CardanoTx -> m CardanoTx
forall (f :: * -> *) a. Applicative f => a -> f a
pure CardanoTx
signedTx

submitTxConfirmed
    :: (MonadEmulator m, Foldable f)
    => UtxoIndex -- ^ Just the transaction inputs, not the entire 'UTxO'.
    -> CardanoAddress
    -> f PaymentPrivateKey
    -> CardanoBuildTx
    -> m CardanoTx
submitTxConfirmed :: UtxoIndex
-> CardanoAddress
-> f PaymentPrivateKey
-> CardanoBuildTx
-> m CardanoTx
submitTxConfirmed UtxoIndex
utxoIndex CardanoAddress
addr f PaymentPrivateKey
privateKeys CardanoBuildTx
utx = do
  CardanoTx
tx <- UtxoIndex
-> CardanoAddress
-> f PaymentPrivateKey
-> CardanoBuildTx
-> m CardanoTx
forall (m :: * -> *) (f :: * -> *).
(MonadEmulator m, Foldable f) =>
UtxoIndex
-> CardanoAddress
-> f PaymentPrivateKey
-> CardanoBuildTx
-> m CardanoTx
submitUnbalancedTx UtxoIndex
utxoIndex CardanoAddress
addr f PaymentPrivateKey
privateKeys CardanoBuildTx
utx
  m ()
forall (m :: * -> *). MonadEmulator m => m ()
nextSlot
  CardanoTx -> m CardanoTx
forall (f :: * -> *) a. Applicative f => a -> f a
pure CardanoTx
tx

-- | 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 C.TxId
payToAddress :: (CardanoAddress, PaymentPrivateKey)
-> CardanoAddress -> Value -> m TxId
payToAddress (CardanoAddress
sourceAddr, PaymentPrivateKey
sourcePrivKey) CardanoAddress
targetAddr Value
value = do
  let buildTx :: CardanoBuildTx
buildTx = TxBodyContent BuildTx BabbageEra -> CardanoBuildTx
CardanoBuildTx (TxBodyContent BuildTx BabbageEra -> CardanoBuildTx)
-> TxBodyContent BuildTx BabbageEra -> CardanoBuildTx
forall a b. (a -> b) -> a -> b
$ TxBodyContent BuildTx BabbageEra
G.emptyTxBodyContent
           { txOuts :: [TxOut CtxTx BabbageEra]
C.txOuts = [CardanoAddress
-> TxOutValue BabbageEra
-> TxOutDatum CtxTx BabbageEra
-> ReferenceScript BabbageEra
-> TxOut CtxTx BabbageEra
forall ctx era.
AddressInEra era
-> TxOutValue era
-> TxOutDatum ctx era
-> ReferenceScript era
-> TxOut ctx era
C.TxOut CardanoAddress
targetAddr (Value -> TxOutValue BabbageEra
toCardanoTxOutValue Value
value) TxOutDatum CtxTx BabbageEra
forall ctx era. TxOutDatum ctx era
C.TxOutDatumNone ReferenceScript BabbageEra
forall era. ReferenceScript era
C.ReferenceScriptNone]
           }
  CardanoTx -> TxId
getCardanoTxId (CardanoTx -> TxId) -> m CardanoTx -> m TxId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UtxoIndex
-> CardanoAddress
-> [PaymentPrivateKey]
-> CardanoBuildTx
-> m CardanoTx
forall (m :: * -> *) (f :: * -> *).
(MonadEmulator m, Foldable f) =>
UtxoIndex
-> CardanoAddress
-> f PaymentPrivateKey
-> CardanoBuildTx
-> m CardanoTx
submitUnbalancedTx UtxoIndex
forall a. Monoid a => a
mempty CardanoAddress
sourceAddr [PaymentPrivateKey
sourcePrivKey] CardanoBuildTx
buildTx

-- | Log any message
logMsg :: MonadEmulator m => L.LogLevel -> EmulatorMsg -> m ()
logMsg :: LogLevel -> EmulatorMsg -> m ()
logMsg LogLevel
l = Seq (LogMessage EmulatorMsg) -> m ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (Seq (LogMessage EmulatorMsg) -> m ())
-> (EmulatorMsg -> Seq (LogMessage EmulatorMsg))
-> EmulatorMsg
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LogMessage EmulatorMsg -> Seq (LogMessage EmulatorMsg)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LogMessage EmulatorMsg -> Seq (LogMessage EmulatorMsg))
-> (EmulatorMsg -> LogMessage EmulatorMsg)
-> EmulatorMsg
-> Seq (LogMessage EmulatorMsg)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LogLevel -> EmulatorMsg -> LogMessage EmulatorMsg
forall a. LogLevel -> a -> LogMessage a
L.LogMessage LogLevel
l

-- | Log a message at the 'Debug' level
logDebug :: (ToJSON a, MonadEmulator m) => a -> m ()
logDebug :: a -> m ()
logDebug = LogLevel -> EmulatorMsg -> m ()
forall (m :: * -> *).
MonadEmulator m =>
LogLevel -> EmulatorMsg -> m ()
logMsg LogLevel
L.Debug (EmulatorMsg -> m ()) -> (a -> EmulatorMsg) -> a -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> EmulatorMsg
GenericMsg (Value -> EmulatorMsg) -> (a -> Value) -> a -> EmulatorMsg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Value
forall a. ToJSON a => a -> Value
toJSON

-- | Log a message at the 'Info' level
logInfo :: (ToJSON a, MonadEmulator m) => a -> m ()
logInfo :: a -> m ()
logInfo = LogLevel -> EmulatorMsg -> m ()
forall (m :: * -> *).
MonadEmulator m =>
LogLevel -> EmulatorMsg -> m ()
logMsg LogLevel
L.Info (EmulatorMsg -> m ()) -> (a -> EmulatorMsg) -> a -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> EmulatorMsg
GenericMsg (Value -> EmulatorMsg) -> (a -> Value) -> a -> EmulatorMsg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Value
forall a. ToJSON a => a -> Value
toJSON

-- | Log a message at the 'Warning' level
logWarn :: (ToJSON a, MonadEmulator m) => a -> m ()
logWarn :: a -> m ()
logWarn = LogLevel -> EmulatorMsg -> m ()
forall (m :: * -> *).
MonadEmulator m =>
LogLevel -> EmulatorMsg -> m ()
logMsg LogLevel
L.Warning (EmulatorMsg -> m ()) -> (a -> EmulatorMsg) -> a -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> EmulatorMsg
GenericMsg (Value -> EmulatorMsg) -> (a -> Value) -> a -> EmulatorMsg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Value
forall a. ToJSON a => a -> Value
toJSON

-- | Log a message at the 'Error' level
logError :: (ToJSON a, MonadEmulator m) => a -> m ()
logError :: a -> m ()
logError = LogLevel -> EmulatorMsg -> m ()
forall (m :: * -> *).
MonadEmulator m =>
LogLevel -> EmulatorMsg -> m ()
logMsg LogLevel
L.Error (EmulatorMsg -> m ()) -> (a -> EmulatorMsg) -> a -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> EmulatorMsg
GenericMsg (Value -> EmulatorMsg) -> (a -> Value) -> a -> EmulatorMsg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Value
forall a. ToJSON a => a -> Value
toJSON