{-# LANGUAGE DataKinds          #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GADTs              #-}
{-# LANGUAGE LambdaCase         #-}
{-# LANGUAGE NamedFieldPuns     #-}
{-# LANGUAGE TemplateHaskell    #-}
{-# LANGUAGE TypeApplications   #-}
{-# LANGUAGE ViewPatterns       #-}
{-| Minimal mockchain
-}
module Convex.MockChain(
  -- * State of the mockchain
  ERA,
  MockChainState(..),
  InitialUTXOs,
  initialState,
  initialStateFor,
  genesisUTxO,
  env,
  poolState,
  transactions,
  utxoSet,
  datums,
  walletUtxo,
  fromLedgerUTxO,
  -- * Transaction validation
  ExUnitsError(..),
  _Phase1Error,
  _Phase2Error,
  ValidationError(..),
  _VExUnits,
  _PredicateFailures,
  _ApplyTxFailure,
  getTxExUnits,
  evaluateTx,
  applyTransaction,
  -- * Plutus scripts
  ScriptContext,
  fullyAppliedScript,
  -- * Mockchain implementation
  MockchainError(..),
  MockchainT(..),
  Mockchain,
  runMockchainT,
  runMockchain,
  runMockchain0,
  evalMockchainT,
  evalMockchain,
  evalMockchain0,
  execMockchain,
  execMockchainT,
  execMockchain0,

  -- ** MockchainIO
  MockchainIO,
  runMockchainIO,
  runMockchain0IO,
  runMockchain0IOWith,
  evalMockchainIO,
  evalMockchain0IO,
  execMockchainIO,
  execMockchain0IO
  ) where

import           Cardano.Api.Shelley                   (AddressInEra,
                                                        BabbageEra, Hash,
                                                        ScriptData,
                                                        ShelleyLedgerEra,
                                                        SlotNo, Tx,
                                                        TxBody (ShelleyTxBody))
import qualified Cardano.Api.Shelley                   as Cardano.Api
import           Cardano.Ledger.Alonzo.Language        (Language (..))
import           Cardano.Ledger.Alonzo.PlutusScriptApi (CollectError,
                                                        collectTwoPhaseScriptInputs,
                                                        evalScripts)
import           Cardano.Ledger.Alonzo.Scripts         (CostModel, ExUnits)
import           Cardano.Ledger.Alonzo.Scripts.Data    (Data)
import qualified Cardano.Ledger.Alonzo.Scripts.Data    as Ledger
import           Cardano.Ledger.Alonzo.TxInfo          (ScriptResult (..))
import qualified Cardano.Ledger.Alonzo.TxInfo          as Ledger
import           Cardano.Ledger.Alonzo.TxWits          (unTxDats)
import           Cardano.Ledger.Babbage                (Babbage)
import           Cardano.Ledger.Babbage.Tx             (AlonzoTx (..),
                                                        IsValid (..))
import           Cardano.Ledger.BaseTypes              (Globals (systemStart),
                                                        ProtVer, epochInfo)
import qualified Cardano.Ledger.Core                   as Core
import           Cardano.Ledger.Crypto                 (StandardCrypto)
import           Cardano.Ledger.Shelley.API            (AccountState (..),
                                                        ApplyTxError, Coin (..),
                                                        GenDelegs (..),
                                                        LedgerEnv (..),
                                                        MempoolEnv,
                                                        MempoolState, UTxO (..),
                                                        UtxoEnv (..), Validated,
                                                        initialFundsPseudoTxIn)
import qualified Cardano.Ledger.Shelley.API
import           Cardano.Ledger.Shelley.LedgerState    (LedgerState (..),
                                                        UTxOState (..),
                                                        smartUTxOState)
import qualified Cardano.Ledger.Val                    as Val
import           Control.Lens                          (_1, _3, over, set, to,
                                                        view, (%=), (&), (.~),
                                                        (^.))
import           Control.Lens.TH                       (makeLensesFor,
                                                        makePrisms)
import           Control.Monad.Except                  (ExceptT,
                                                        MonadError (throwError),
                                                        runExceptT)
import           Control.Monad.IO.Class                (MonadIO)
import           Control.Monad.Reader                  (ReaderT, ask, asks,
                                                        runReaderT)
import           Control.Monad.State                   (MonadState, StateT, get,
                                                        gets, modify, put,
                                                        runStateT)
import           Control.Monad.Trans.Class             (MonadTrans (..))
import           Convex.Class                          (MonadBlockchain (..),
                                                        MonadMockchain (..))
import           Convex.Era                            (ERA)
import qualified Convex.Lenses                         as L
import           Convex.MockChain.Defaults             ()
import qualified Convex.MockChain.Defaults             as Defaults
import           Convex.MonadLog                       (MonadLog (..))
import           Convex.NodeParams                     (NodeParams (..))
import           Convex.Utils                          (slotToUtcTime)
import           Convex.Utxos                          (UtxoSet (..),
                                                        fromApiUtxo,
                                                        onlyCredential)
import           Convex.Wallet                         (Wallet, addressInEra,
                                                        paymentCredential)
import           Data.Bifunctor                        (Bifunctor (..))
import           Data.ByteString.Short                 (ShortByteString)
import           Data.Default                          (Default (def))
import           Data.Foldable                         (for_, traverse_)
import           Data.Functor.Identity                 (Identity (..))
import           Data.Map                              (Map)
import qualified Data.Map                              as Map
import           Ouroboros.Consensus.Shelley.Eras      (EraCrypto)
import qualified PlutusCore                            as PLC
import           PlutusLedgerApi.Common                (mkTermToEvaluate)
import qualified PlutusLedgerApi.Common                as Plutus
import qualified UntypedPlutusCore                     as UPLC

{-| All the information needed to evaluate a Plutus script: The script itself, the
script language, redeemers and datums, execution units required, and the cost model.
-}
type ScriptContext era = (ShortByteString, Language, [Data era], ExUnits, CostModel)

{-| Apply the plutus script to all its arguments and return a plutus
program
-}
fullyAppliedScript :: NodeParams -> ScriptContext ERA -> Either String (UPLC.Program UPLC.NamedDeBruijn UPLC.DefaultUni UPLC.DefaultFun ())
fullyAppliedScript :: NodeParams
-> ScriptContext ERA
-> Either String (Program NamedDeBruijn DefaultUni DefaultFun ())
fullyAppliedScript NodeParams
params (ShortByteString
script, Language
lang, [Data ERA]
arguments, ExUnits
_, CostModel
_) = do
  let pv :: ProtocolVersion
pv = ProtVer -> ProtocolVersion
Ledger.transProtocolVersion (NodeParams -> ProtVer
Defaults.protVer NodeParams
params)
      pArgs :: [Data]
pArgs = forall era. Data era -> Data
Ledger.getPlutusData forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Data ERA]
arguments
      lng :: PlutusLedgerLanguage
lng = case Language
lang of
              Language
PlutusV1 -> PlutusLedgerLanguage
Plutus.PlutusV1
              Language
PlutusV2 -> PlutusLedgerLanguage
Plutus.PlutusV2
              Language
PlutusV3 -> PlutusLedgerLanguage
Plutus.PlutusV3
  Term NamedDeBruijn DefaultUni DefaultFun ()
appliedTerm <- forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadError EvaluationError m =>
PlutusLedgerLanguage
-> ProtocolVersion
-> ShortByteString
-> [Data]
-> m (Term NamedDeBruijn DefaultUni DefaultFun ())
mkTermToEvaluate PlutusLedgerLanguage
lng ProtocolVersion
pv ShortByteString
script [Data]
pArgs
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall name (uni :: * -> *) fun ann.
ann -> Version -> Term name uni fun ann -> Program name uni fun ann
UPLC.Program () Version
PLC.latestVersion Term NamedDeBruijn DefaultUni DefaultFun ()
appliedTerm

data MockChainState =
  MockChainState
    { MockChainState -> MempoolEnv ERA
mcsEnv          :: MempoolEnv ERA
    , MockChainState -> MempoolState ERA
mcsPoolState    :: MempoolState ERA
    , MockChainState -> [(Validated (Tx ERA), [ScriptContext ERA])]
mcsTransactions :: [(Validated (Core.Tx ERA), [ScriptContext ERA])]
    , MockChainState -> Map (Hash ScriptData) ScriptData
mcsDatums       :: Map (Hash ScriptData) ScriptData
    }

makeLensesFor
  [ ("mcsEnv", "env")
  , ("mcsPoolState", "poolState")
  , ("mcsTransactions", "transactions")
  , ("mcsDatums", "datums")
  ] ''MockChainState

initialState :: NodeParams -> MockChainState
initialState :: NodeParams -> MockChainState
initialState NodeParams
params = NodeParams -> InitialUTXOs -> MockChainState
initialStateFor NodeParams
params []

genesisUTxO ::
  forall era capiEra.
  (EraCrypto era ~ StandardCrypto, Core.EraTxOut era) =>
  [(AddressInEra capiEra, Coin)] ->
  UTxO era
genesisUTxO :: forall era capiEra.
(EraCrypto era ~ StandardCrypto, EraTxOut era) =>
[(AddressInEra capiEra, Coin)] -> UTxO era
genesisUTxO [(AddressInEra capiEra, Coin)]
utxos =
  forall era. Map (TxIn (EraCrypto era)) (TxOut era) -> UTxO era
UTxO forall a b. (a -> b) -> a -> b
$
    forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
      [ (TxIn StandardCrypto
txIn, TxOut era
txOut)
        | (forall era. AddressInEra era -> Addr StandardCrypto
Cardano.Api.toShelleyAddr -> Addr StandardCrypto
addr, Coin
amount) <- [(AddressInEra capiEra, Coin)]
utxos,
          let txIn :: TxIn StandardCrypto
txIn = forall c. Crypto c => Addr c -> TxIn c
initialFundsPseudoTxIn Addr StandardCrypto
addr
              txOut :: TxOut era
txOut = forall era.
EraTxOut era =>
Addr (EraCrypto era) -> Value era -> TxOut era
Core.mkBasicTxOut Addr StandardCrypto
addr (forall t. Val t => Coin -> t
Val.inject Coin
amount)
      ]

type InitialUTXOs = [(Wallet, Coin)]

{-| Initialise the 'MockChainState' with a list of UTxOs
-}
initialStateFor ::
  NodeParams ->
  InitialUTXOs -> -- List of UTXOs at each wallet's address. Can have multiple entries per wallet.
  MockChainState
initialStateFor :: NodeParams -> InitialUTXOs -> MockChainState
initialStateFor params :: NodeParams
params@NodeParams{NetworkId
npNetworkId :: NodeParams -> NetworkId
npNetworkId :: NetworkId
npNetworkId} InitialUTXOs
utxos =
  let utxo :: UTxO ERA
utxo = forall era capiEra.
(EraCrypto era ~ StandardCrypto, EraTxOut era) =>
[(AddressInEra capiEra, Coin)] -> UTxO era
genesisUTxO @ERA @Cardano.Api.BabbageEra (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (forall era.
IsShelleyBasedEra era =>
NetworkId -> Wallet -> AddressInEra era
addressInEra NetworkId
npNetworkId)) InitialUTXOs
utxos)
  in MockChainState
      { mcsEnv :: MempoolEnv ERA
mcsEnv =
          LedgerEnv
            { ledgerSlotNo :: SlotNo
ledgerSlotNo = SlotNo
0
            , ledgerIx :: TxIx
ledgerIx = forall a. Bounded a => a
minBound
            , ledgerPp :: PParams ERA
ledgerPp = NodeParams -> PParams ERA
Defaults.pParams NodeParams
params
            , ledgerAccount :: AccountState
ledgerAccount = Coin -> Coin -> AccountState
AccountState (Integer -> Coin
Coin Integer
0) (Integer -> Coin
Coin Integer
0)
            }
      , mcsPoolState :: MempoolState ERA
mcsPoolState = LedgerState
          { lsUTxOState :: UTxOState ERA
lsUTxOState = forall era.
EraTxOut era =>
PParams era
-> UTxO era -> Coin -> Coin -> GovernanceState era -> UTxOState era
smartUTxOState (NodeParams -> PParams ERA
Defaults.pParams NodeParams
params) UTxO ERA
utxo (Integer -> Coin
Coin Integer
0) (Integer -> Coin
Coin Integer
0) forall a. Default a => a
def
          , lsCertState :: CertState ERA
lsCertState = forall a. Default a => a
def
          }
      , mcsTransactions :: [(Validated (Tx ERA), [ScriptContext ERA])]
mcsTransactions = []
      , mcsDatums :: Map (Hash ScriptData) ScriptData
mcsDatums = forall k a. Map k a
Map.empty
      }

utxoEnv :: NodeParams -> SlotNo -> UtxoEnv ERA
utxoEnv :: NodeParams -> SlotNo -> UtxoEnv ERA
utxoEnv NodeParams
params SlotNo
slotNo = forall era.
SlotNo
-> PParams era
-> CertState era
-> GenDelegs (EraCrypto era)
-> UtxoEnv era
UtxoEnv SlotNo
slotNo (NodeParams -> PParams ERA
Defaults.pParams NodeParams
params) forall a. Default a => a
def (forall c. Map (KeyHash 'Genesis c) (GenDelegPair c) -> GenDelegs c
GenDelegs forall a. Monoid a => a
mempty)

data ExUnitsError =
  Phase1Error Cardano.Api.TransactionValidityError
  | Phase2Error Cardano.Api.ScriptExecutionError
  deriving (Int -> ExUnitsError -> ShowS
[ExUnitsError] -> ShowS
ExUnitsError -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ExUnitsError] -> ShowS
$cshowList :: [ExUnitsError] -> ShowS
show :: ExUnitsError -> String
$cshow :: ExUnitsError -> String
showsPrec :: Int -> ExUnitsError -> ShowS
$cshowsPrec :: Int -> ExUnitsError -> ShowS
Show)

makePrisms ''ExUnitsError

data ValidationError =
  VExUnits ExUnitsError
  | PredicateFailures [CollectError ERA]
  | ApplyTxFailure (ApplyTxError ERA)
  deriving (Int -> ValidationError -> ShowS
[ValidationError] -> ShowS
ValidationError -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ValidationError] -> ShowS
$cshowList :: [ValidationError] -> ShowS
show :: ValidationError -> String
$cshow :: ValidationError -> String
showsPrec :: Int -> ValidationError -> ShowS
$cshowsPrec :: Int -> ValidationError -> ShowS
Show)

makePrisms ''ValidationError

{-| Compute the exunits of a transaction
-}
getTxExUnits ::
  NodeParams ->
  UTxO ERA ->
  Cardano.Api.Tx Cardano.Api.BabbageEra ->
  Either ExUnitsError (Map.Map Cardano.Api.ScriptWitnessIndex Cardano.Api.ExecutionUnits)
getTxExUnits :: NodeParams
-> UTxO ERA
-> Tx BabbageEra
-> Either ExUnitsError (Map ScriptWitnessIndex ExecutionUnits)
getTxExUnits NodeParams{SystemStart
npSystemStart :: NodeParams -> SystemStart
npSystemStart :: SystemStart
npSystemStart, EraHistory CardanoMode
npEraHistory :: NodeParams -> EraHistory CardanoMode
npEraHistory :: EraHistory CardanoMode
npEraHistory, BundledProtocolParameters BabbageEra
npProtocolParameters :: NodeParams -> BundledProtocolParameters BabbageEra
npProtocolParameters :: BundledProtocolParameters BabbageEra
npProtocolParameters} UTxO ERA
utxo (forall era. Tx era -> TxBody era
Cardano.Api.getTxBody -> TxBody BabbageEra
tx) =
  case forall era.
SystemStart
-> LedgerEpochInfo
-> BundledProtocolParameters era
-> UTxO era
-> TxBody era
-> Either
     TransactionValidityError
     (Map
        ScriptWitnessIndex (Either ScriptExecutionError ExecutionUnits))
Cardano.Api.evaluateTransactionExecutionUnits SystemStart
npSystemStart (forall mode. EraHistory mode -> LedgerEpochInfo
Cardano.Api.toLedgerEpochInfo EraHistory CardanoMode
npEraHistory) BundledProtocolParameters BabbageEra
npProtocolParameters (forall era ledgerera.
(ShelleyLedgerEra era ~ ledgerera,
 EraCrypto ledgerera ~ StandardCrypto) =>
ShelleyBasedEra era -> UTxO ledgerera -> UTxO era
fromLedgerUTxO ShelleyBasedEra BabbageEra
Cardano.Api.ShelleyBasedEraBabbage UTxO ERA
utxo) TxBody BabbageEra
tx of
    Left TransactionValidityError
e      -> forall a b. a -> Either a b
Left (TransactionValidityError -> ExUnitsError
Phase1Error TransactionValidityError
e)
    Right Map ScriptWitnessIndex (Either ScriptExecutionError ExecutionUnits)
rdmrs -> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScriptExecutionError -> ExUnitsError
Phase2Error) forall a b. b -> Either a b
Right) Map ScriptWitnessIndex (Either ScriptExecutionError ExecutionUnits)
rdmrs

applyTransaction :: NodeParams -> MockChainState -> Cardano.Api.Tx Cardano.Api.BabbageEra -> Either ValidationError (MockChainState, Validated (Core.Tx ERA))
applyTransaction :: NodeParams
-> MockChainState
-> Tx BabbageEra
-> Either ValidationError (MockChainState, Validated (Tx ERA))
applyTransaction NodeParams
params MockChainState
state tx' :: Tx BabbageEra
tx'@(Cardano.Api.ShelleyTx ShelleyBasedEra BabbageEra
_era Tx (ShelleyLedgerEra BabbageEra)
tx) = do
  let currentSlot :: SlotNo
currentSlot = MockChainState
state forall s a. s -> Getting a s a -> a
^. Lens' MockChainState (MempoolEnv ERA)
env forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (LedgerEnv era) SlotNo
L.slot
      utxoState_ :: UTxOState ERA
utxoState_ = MockChainState
state forall s a. s -> Getting a s a -> a
^. Lens' MockChainState (MempoolState ERA)
poolState forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (LedgerState era) (UTxOState era)
L.utxoState
      utxo :: UTxO ERA
utxo = UTxOState ERA
utxoState_ forall s a. s -> Getting a s a -> a
^. forall era.
EraTxOut era =>
PParams era
-> Iso' (UTxOState era) (UTxO era, Coin, Coin, GovernanceState era)
L._UTxOState (forall era.
ShelleyBasedEra era
-> BundledProtocolParameters era -> PParams (ShelleyLedgerEra era)
unbundleLedgerShelleyBasedProtocolParams ShelleyBasedEra BabbageEra
Cardano.Api.ShelleyBasedEraBabbage forall a b. (a -> b) -> a -> b
$ NodeParams -> BundledProtocolParameters BabbageEra
npProtocolParameters NodeParams
params) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a b. Field1 s t a b => Lens s t a b
_1
  (AlonzoTx ERA
vtx, [ScriptContext ERA]
scripts) <- forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first [CollectError ERA] -> ValidationError
PredicateFailures (forall (m :: * -> *).
MonadError [CollectError ERA] m =>
ProtVer
-> Globals
-> UtxoEnv ERA
-> UTxOState ERA
-> Tx ERA
-> m (AlonzoTx ERA, [ScriptContext ERA])
constructValidated (NodeParams -> ProtVer
Defaults.protVer NodeParams
params) (NodeParams -> Globals
Defaults.globals NodeParams
params) (NodeParams -> SlotNo -> UtxoEnv ERA
utxoEnv NodeParams
params SlotNo
currentSlot) UTxOState ERA
utxoState_ Tx (ShelleyLedgerEra BabbageEra)
tx)
  (MockChainState, Validated (AlonzoTx ERA))
result <- NodeParams
-> MockChainState
-> Tx ERA
-> [ScriptContext ERA]
-> Either ValidationError (MockChainState, Validated (Tx ERA))
applyTx NodeParams
params MockChainState
state AlonzoTx ERA
vtx [ScriptContext ERA]
scripts

  -- Not sure if this step is needed.
  Map ScriptWitnessIndex ExecutionUnits
_ <- forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ExUnitsError -> ValidationError
VExUnits (NodeParams
-> UTxO ERA
-> Tx BabbageEra
-> Either ExUnitsError (Map ScriptWitnessIndex ExecutionUnits)
getTxExUnits NodeParams
params UTxO ERA
utxo Tx BabbageEra
tx')

  forall (f :: * -> *) a. Applicative f => a -> f a
pure (MockChainState, Validated (AlonzoTx ERA))
result

{-| Evaluate a transaction, returning all of its script contexts.
-}
evaluateTx :: NodeParams -> SlotNo -> UTxO ERA -> Cardano.Api.Tx Cardano.Api.BabbageEra -> Either ValidationError [ScriptContext ERA]
evaluateTx :: NodeParams
-> SlotNo
-> UTxO ERA
-> Tx BabbageEra
-> Either ValidationError [ScriptContext ERA]
evaluateTx NodeParams
params SlotNo
slotNo UTxO ERA
utxo (Cardano.Api.ShelleyTx ShelleyBasedEra BabbageEra
_ Tx (ShelleyLedgerEra BabbageEra)
tx) = do
    (AlonzoTx ERA
vtx, [ScriptContext ERA]
scripts) <- forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first [CollectError ERA] -> ValidationError
PredicateFailures (forall (m :: * -> *).
MonadError [CollectError ERA] m =>
ProtVer
-> Globals
-> UtxoEnv ERA
-> UTxOState ERA
-> Tx ERA
-> m (AlonzoTx ERA, [ScriptContext ERA])
constructValidated (NodeParams -> ProtVer
Defaults.protVer NodeParams
params) (NodeParams -> Globals
Defaults.globals NodeParams
params) (NodeParams -> SlotNo -> UtxoEnv ERA
utxoEnv NodeParams
params SlotNo
slotNo) (forall era. LedgerState era -> UTxOState era
lsUTxOState (MockChainState -> MempoolState ERA
mcsPoolState MockChainState
state)) Tx (ShelleyLedgerEra BabbageEra)
tx)
    (MockChainState, Validated (AlonzoTx ERA))
_ <- NodeParams
-> MockChainState
-> Tx ERA
-> [ScriptContext ERA]
-> Either ValidationError (MockChainState, Validated (Tx ERA))
applyTx NodeParams
params MockChainState
state AlonzoTx ERA
vtx [ScriptContext ERA]
scripts
    forall (f :: * -> *) a. Applicative f => a -> f a
pure [ScriptContext ERA]
scripts
  where
    state :: MockChainState
state =
      NodeParams -> MockChainState
initialState NodeParams
params
        forall a b. a -> (a -> b) -> b
& Lens' MockChainState (MempoolEnv ERA)
env forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (LedgerEnv era) SlotNo
L.slot forall s t a b. ASetter s t a b -> b -> s -> t
.~ SlotNo
slotNo
        forall a b. a -> (a -> b) -> b
& Lens' MockChainState (MempoolState ERA)
poolState forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (LedgerState era) (UTxOState era)
L.utxoState forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxOut era =>
PParams era
-> Iso' (UTxOState era) (UTxO era, Coin, Coin, GovernanceState era)
L._UTxOState (forall era.
ShelleyBasedEra era
-> BundledProtocolParameters era -> PParams (ShelleyLedgerEra era)
unbundleLedgerShelleyBasedProtocolParams ShelleyBasedEra BabbageEra
Cardano.Api.ShelleyBasedEraBabbage forall a b. (a -> b) -> a -> b
$ NodeParams -> BundledProtocolParameters BabbageEra
npProtocolParameters NodeParams
params) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a b. Field1 s t a b => Lens s t a b
_1 forall s t a b. ASetter s t a b -> b -> s -> t
.~ UTxO ERA
utxo

-- | Construct a 'ValidatedTx' from a 'Core.Tx' by setting the `IsValid`
-- flag.
--
-- Note that this simply constructs the transaction; it does not validate
-- anything other than the scripts. Thus the resulting transaction may be
-- completely invalid.
--
-- Copied from cardano-ledger as it was removed there
-- in https://github.com/input-output-hk/cardano-ledger/commit/721adb55b39885847562437a6fe7e998f8e48c03
constructValidated ::
  forall m.
  ( MonadError [CollectError Babbage] m
  ) =>
  ProtVer ->
  Globals ->
  UtxoEnv Babbage ->
  UTxOState Babbage ->
  Core.Tx Babbage ->
  m (AlonzoTx Babbage, [ScriptContext Babbage])
constructValidated :: forall (m :: * -> *).
MonadError [CollectError ERA] m =>
ProtVer
-> Globals
-> UtxoEnv ERA
-> UTxOState ERA
-> Tx ERA
-> m (AlonzoTx ERA, [ScriptContext ERA])
constructValidated ProtVer
pv Globals
globals (UtxoEnv SlotNo
_ PParams ERA
pp CertState ERA
_ GenDelegs (EraCrypto ERA)
_) UTxOState ERA
st Tx ERA
tx =
  case forall era.
(EraTx era, MaryEraTxBody era, AlonzoEraTxWits era, EraUTxO era,
 ScriptsNeeded era ~ AlonzoScriptsNeeded era, ExtendedUTxO era,
 Script era ~ AlonzoScript era, AlonzoEraPParams era,
 EraPlutusContext 'PlutusV1 era) =>
EpochInfo (Either Text)
-> SystemStart
-> PParams era
-> Tx era
-> UTxO era
-> Either
     [CollectError era]
     [(ShortByteString, Language, [Data era], ExUnits, CostModel)]
collectTwoPhaseScriptInputs EpochInfo (Either Text)
ei SystemStart
sysS PParams ERA
pp Tx ERA
tx UTxO ERA
utxo of
    Left [CollectError ERA]
errs -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError [CollectError ERA]
errs
    Right [ScriptContext ERA]
sLst ->
      let scriptEvalResult :: ScriptResult
scriptEvalResult = forall era.
(EraTx era, Script era ~ AlonzoScript era) =>
ProtVer
-> Tx era
-> [(ShortByteString, Language, [Data era], ExUnits, CostModel)]
-> ScriptResult
evalScripts @Babbage ProtVer
pv Tx ERA
tx [ScriptContext ERA]
sLst
          vTx :: AlonzoTx ERA
vTx =
            forall era.
TxBody era
-> TxWits era
-> IsValid
-> StrictMaybe (TxAuxData era)
-> AlonzoTx era
AlonzoTx
              (forall era. AlonzoTx era -> TxBody era
body Tx ERA
tx)
              (forall era. AlonzoTx era -> TxWits era
wits Tx ERA
tx) -- (getField @"wits" tx)
              (Bool -> IsValid
IsValid (ScriptResult -> Bool
lift_ ScriptResult
scriptEvalResult))
              (forall era. AlonzoTx era -> StrictMaybe (TxAuxData era)
auxiliaryData Tx ERA
tx) -- (getField @"auxiliaryData" tx)
       in forall (f :: * -> *) a. Applicative f => a -> f a
pure (AlonzoTx ERA
vTx, [ScriptContext ERA]
sLst)
  where
    utxo :: UTxO ERA
utxo = forall era. UTxOState era -> UTxO era
utxosUtxo UTxOState ERA
st
    sysS :: SystemStart
sysS = Globals -> SystemStart
systemStart Globals
globals
    ei :: EpochInfo (Either Text)
ei = Globals -> EpochInfo (Either Text)
epochInfo Globals
globals
    lift_ :: ScriptResult -> Bool
lift_ (Passes [PlutusDebug]
_)  = Bool
True
    lift_ (Fails [PlutusDebug]
_ NonEmpty ScriptFailure
_) = Bool
False

applyTx ::
  NodeParams ->
  MockChainState ->
  Core.Tx ERA ->
  [ScriptContext ERA] ->
  Either ValidationError (MockChainState, Validated (Core.Tx ERA))
applyTx :: NodeParams
-> MockChainState
-> Tx ERA
-> [ScriptContext ERA]
-> Either ValidationError (MockChainState, Validated (Tx ERA))
applyTx NodeParams
params oldState :: MockChainState
oldState@MockChainState{MempoolEnv ERA
mcsEnv :: MempoolEnv ERA
mcsEnv :: MockChainState -> MempoolEnv ERA
mcsEnv, MempoolState ERA
mcsPoolState :: MempoolState ERA
mcsPoolState :: MockChainState -> MempoolState ERA
mcsPoolState} Tx ERA
tx [ScriptContext ERA]
context = do
  (MempoolState ERA
newMempool, Validated (AlonzoTx ERA)
vtx) <- forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ApplyTxError ERA -> ValidationError
ApplyTxFailure (forall era (m :: * -> *).
(ApplyTx era, MonadError (ApplyTxError era) m) =>
Globals
-> MempoolEnv era
-> MempoolState era
-> Tx era
-> m (MempoolState era, Validated (Tx era))
Cardano.Ledger.Shelley.API.applyTx (NodeParams -> Globals
Defaults.globals NodeParams
params) MempoolEnv ERA
mcsEnv MempoolState ERA
mcsPoolState Tx ERA
tx)
  forall (m :: * -> *) a. Monad m => a -> m a
return (MockChainState
oldState forall a b. a -> (a -> b) -> b
& Lens' MockChainState (MempoolState ERA)
poolState forall s t a b. ASetter s t a b -> b -> s -> t
.~ MempoolState ERA
newMempool forall a b. a -> (a -> b) -> b
& forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over Lens' MockChainState [(Validated (Tx ERA), [ScriptContext ERA])]
transactions ((:) (Validated (AlonzoTx ERA)
vtx, [ScriptContext ERA]
context)), Validated (AlonzoTx ERA)
vtx)

newtype MockchainT m a = MockchainT (ReaderT NodeParams (StateT MockChainState (ExceptT MockchainError m)) a)
  deriving newtype (forall a b. a -> MockchainT m b -> MockchainT m a
forall a b. (a -> b) -> MockchainT m a -> MockchainT m b
forall (m :: * -> *) a b.
Functor m =>
a -> MockchainT m b -> MockchainT m a
forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> MockchainT m a -> MockchainT m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> MockchainT m b -> MockchainT m a
$c<$ :: forall (m :: * -> *) a b.
Functor m =>
a -> MockchainT m b -> MockchainT m a
fmap :: forall a b. (a -> b) -> MockchainT m a -> MockchainT m b
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> MockchainT m a -> MockchainT m b
Functor, forall a. a -> MockchainT m a
forall a b. MockchainT m a -> MockchainT m b -> MockchainT m a
forall a b. MockchainT m a -> MockchainT m b -> MockchainT m b
forall a b.
MockchainT m (a -> b) -> MockchainT m a -> MockchainT m b
forall a b c.
(a -> b -> c) -> MockchainT m a -> MockchainT m b -> MockchainT m c
forall {m :: * -> *}. Monad m => Functor (MockchainT m)
forall (m :: * -> *) a. Monad m => a -> MockchainT m a
forall (m :: * -> *) a b.
Monad m =>
MockchainT m a -> MockchainT m b -> MockchainT m a
forall (m :: * -> *) a b.
Monad m =>
MockchainT m a -> MockchainT m b -> MockchainT m b
forall (m :: * -> *) a b.
Monad m =>
MockchainT m (a -> b) -> MockchainT m a -> MockchainT m b
forall (m :: * -> *) a b c.
Monad m =>
(a -> b -> c) -> MockchainT m a -> MockchainT m b -> MockchainT m c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: forall a b. MockchainT m a -> MockchainT m b -> MockchainT m a
$c<* :: forall (m :: * -> *) a b.
Monad m =>
MockchainT m a -> MockchainT m b -> MockchainT m a
*> :: forall a b. MockchainT m a -> MockchainT m b -> MockchainT m b
$c*> :: forall (m :: * -> *) a b.
Monad m =>
MockchainT m a -> MockchainT m b -> MockchainT m b
liftA2 :: forall a b c.
(a -> b -> c) -> MockchainT m a -> MockchainT m b -> MockchainT m c
$cliftA2 :: forall (m :: * -> *) a b c.
Monad m =>
(a -> b -> c) -> MockchainT m a -> MockchainT m b -> MockchainT m c
<*> :: forall a b.
MockchainT m (a -> b) -> MockchainT m a -> MockchainT m b
$c<*> :: forall (m :: * -> *) a b.
Monad m =>
MockchainT m (a -> b) -> MockchainT m a -> MockchainT m b
pure :: forall a. a -> MockchainT m a
$cpure :: forall (m :: * -> *) a. Monad m => a -> MockchainT m a
Applicative, forall a. a -> MockchainT m a
forall a b. MockchainT m a -> MockchainT m b -> MockchainT m b
forall a b.
MockchainT m a -> (a -> MockchainT m b) -> MockchainT m b
forall (m :: * -> *). Monad m => Applicative (MockchainT m)
forall (m :: * -> *) a. Monad m => a -> MockchainT m a
forall (m :: * -> *) a b.
Monad m =>
MockchainT m a -> MockchainT m b -> MockchainT m b
forall (m :: * -> *) a b.
Monad m =>
MockchainT m a -> (a -> MockchainT m b) -> MockchainT m b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: forall a. a -> MockchainT m a
$creturn :: forall (m :: * -> *) a. Monad m => a -> MockchainT m a
>> :: forall a b. MockchainT m a -> MockchainT m b -> MockchainT m b
$c>> :: forall (m :: * -> *) a b.
Monad m =>
MockchainT m a -> MockchainT m b -> MockchainT m b
>>= :: forall a b.
MockchainT m a -> (a -> MockchainT m b) -> MockchainT m b
$c>>= :: forall (m :: * -> *) a b.
Monad m =>
MockchainT m a -> (a -> MockchainT m b) -> MockchainT m b
Monad, forall a. IO a -> MockchainT m a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
forall {m :: * -> *}. MonadIO m => Monad (MockchainT m)
forall (m :: * -> *) a. MonadIO m => IO a -> MockchainT m a
liftIO :: forall a. IO a -> MockchainT m a
$cliftIO :: forall (m :: * -> *) a. MonadIO m => IO a -> MockchainT m a
MonadIO, Doc Void -> MockchainT m ()
forall (m :: * -> *).
Monad m
-> (Doc Void -> m ())
-> (Doc Void -> m ())
-> (Doc Void -> m ())
-> MonadLog m
forall {m :: * -> *}. MonadLog m => Monad (MockchainT m)
forall (m :: * -> *). MonadLog m => Doc Void -> MockchainT m ()
logDebug' :: Doc Void -> MockchainT m ()
$clogDebug' :: forall (m :: * -> *). MonadLog m => Doc Void -> MockchainT m ()
logWarn' :: Doc Void -> MockchainT m ()
$clogWarn' :: forall (m :: * -> *). MonadLog m => Doc Void -> MockchainT m ()
logInfo' :: Doc Void -> MockchainT m ()
$clogInfo' :: forall (m :: * -> *). MonadLog m => Doc Void -> MockchainT m ()
MonadLog)

instance MonadTrans MockchainT where
  lift :: forall (m :: * -> *) a. Monad m => m a -> MockchainT m a
lift = forall (m :: * -> *) a.
ReaderT
  NodeParams (StateT MockChainState (ExceptT MockchainError m)) a
-> MockchainT m a
MockchainT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift

data MockchainError =
  MockchainValidationFailed ValidationError
  | FailWith String
  deriving (Int -> MockchainError -> ShowS
[MockchainError] -> ShowS
MockchainError -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MockchainError] -> ShowS
$cshowList :: [MockchainError] -> ShowS
show :: MockchainError -> String
$cshow :: MockchainError -> String
showsPrec :: Int -> MockchainError -> ShowS
$cshowsPrec :: Int -> MockchainError -> ShowS
Show)

instance Monad m => MonadFail (MockchainT m) where
  fail :: forall a. String -> MockchainT m a
fail = forall (m :: * -> *) a.
ReaderT
  NodeParams (StateT MockChainState (ExceptT MockchainError m)) a
-> MockchainT m a
MockchainT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> MockchainError
FailWith

instance Monad m => MonadBlockchain (MockchainT m) where
  sendTx :: Tx BabbageEra -> MockchainT m TxId
sendTx Tx BabbageEra
tx = forall (m :: * -> *) a.
ReaderT
  NodeParams (StateT MockChainState (ExceptT MockchainError m)) a
-> MockchainT m a
MockchainT forall a b. (a -> b) -> a -> b
$ do
    NodeParams
nps <- forall r (m :: * -> *). MonadReader r m => m r
ask
    forall (m :: * -> *).
MonadState MockChainState m =>
Tx BabbageEra -> m ()
addDatumHashes Tx BabbageEra
tx
    MockChainState
st <- forall s (m :: * -> *). MonadState s m => m s
get
    case NodeParams
-> MockChainState
-> Tx BabbageEra
-> Either ValidationError (MockChainState, Validated (Tx ERA))
applyTransaction NodeParams
nps MockChainState
st Tx BabbageEra
tx of
      Left ValidationError
err       -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ValidationError -> MockchainError
MockchainValidationFailed ValidationError
err)
      Right (MockChainState
st', Validated (Tx ERA)
_) ->
        let Cardano.Api.Tx TxBody BabbageEra
body [KeyWitness BabbageEra]
_ = Tx BabbageEra
tx
        in forall s (m :: * -> *). MonadState s m => s -> m ()
put MockChainState
st' forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return (forall era. TxBody era -> TxId
Cardano.Api.getTxId TxBody BabbageEra
body)
  utxoByTxIn :: Set TxIn -> MockchainT m (UTxO BabbageEra)
utxoByTxIn Set TxIn
txIns = forall (m :: * -> *) a.
ReaderT
  NodeParams (StateT MockChainState (ExceptT MockchainError m)) a
-> MockchainT m a
MockchainT forall a b. (a -> b) -> a -> b
$ do
    NodeParams
nps <- forall r (m :: * -> *). MonadReader r m => m r
ask
    Cardano.Api.UTxO Map TxIn (TxOut CtxUTxO BabbageEra)
mp <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ Lens' MockChainState (MempoolState ERA)
poolState forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (LedgerState era) (UTxOState era)
L.utxoState forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxOut era =>
PParams era
-> Iso' (UTxOState era) (UTxO era, Coin, Coin, GovernanceState era)
L._UTxOState (NodeParams -> PParams ERA
Defaults.pParams NodeParams
nps) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a b. Field1 s t a b => Lens s t a b
_1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to (forall era ledgerera.
(ShelleyLedgerEra era ~ ledgerera,
 EraCrypto ledgerera ~ StandardCrypto) =>
ShelleyBasedEra era -> UTxO ledgerera -> UTxO era
fromLedgerUTxO ShelleyBasedEra BabbageEra
Cardano.Api.ShelleyBasedEraBabbage))
    let mp' :: Map TxIn (TxOut CtxUTxO BabbageEra)
mp' = forall k a. Ord k => Map k a -> Set k -> Map k a
Map.restrictKeys Map TxIn (TxOut CtxUTxO BabbageEra)
mp Set TxIn
txIns
    forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall era. Map TxIn (TxOut CtxUTxO era) -> UTxO era
Cardano.Api.UTxO Map TxIn (TxOut CtxUTxO BabbageEra)
mp')
  queryProtocolParameters :: MockchainT m (BundledProtocolParameters BabbageEra)
queryProtocolParameters = forall (m :: * -> *) a.
ReaderT
  NodeParams (StateT MockChainState (ExceptT MockchainError m)) a
-> MockchainT m a
MockchainT (forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks NodeParams -> BundledProtocolParameters BabbageEra
npProtocolParameters)
  queryStakePools :: MockchainT m (Set PoolId)
queryStakePools = forall (m :: * -> *) a.
ReaderT
  NodeParams (StateT MockChainState (ExceptT MockchainError m)) a
-> MockchainT m a
MockchainT (forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks NodeParams -> Set PoolId
npStakePools)
  networkId :: MockchainT m NetworkId
networkId = forall (m :: * -> *) a.
ReaderT
  NodeParams (StateT MockChainState (ExceptT MockchainError m)) a
-> MockchainT m a
MockchainT (forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks NodeParams -> NetworkId
npNetworkId)
  querySystemStart :: MockchainT m SystemStart
querySystemStart = forall (m :: * -> *) a.
ReaderT
  NodeParams (StateT MockChainState (ExceptT MockchainError m)) a
-> MockchainT m a
MockchainT (forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks NodeParams -> SystemStart
npSystemStart)
  queryEraHistory :: MockchainT m (EraHistory CardanoMode)
queryEraHistory = forall (m :: * -> *) a.
ReaderT
  NodeParams (StateT MockChainState (ExceptT MockchainError m)) a
-> MockchainT m a
MockchainT (forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks NodeParams -> EraHistory CardanoMode
npEraHistory)
  querySlotNo :: MockchainT m (SlotNo, SlotLength, UTCTime)
querySlotNo = forall (m :: * -> *) a.
ReaderT
  NodeParams (StateT MockChainState (ExceptT MockchainError m)) a
-> MockchainT m a
MockchainT forall a b. (a -> b) -> a -> b
$ do
    MockChainState
st <- forall s (m :: * -> *). MonadState s m => m s
get
    NodeParams{SystemStart
npSystemStart :: SystemStart
npSystemStart :: NodeParams -> SystemStart
npSystemStart, EraHistory CardanoMode
npEraHistory :: EraHistory CardanoMode
npEraHistory :: NodeParams -> EraHistory CardanoMode
npEraHistory, SlotLength
npSlotLength :: NodeParams -> SlotLength
npSlotLength :: SlotLength
npSlotLength} <- forall r (m :: * -> *). MonadReader r m => m r
ask
    let slotNo :: SlotNo
slotNo = MockChainState
st forall s a. s -> Getting a s a -> a
^. Lens' MockChainState (MempoolEnv ERA)
env forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (LedgerEnv era) SlotNo
L.slot
    UTCTime
utime <- forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> MockchainError
FailWith) forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall mode.
EraHistory mode -> SystemStart -> SlotNo -> Either String UTCTime
slotToUtcTime EraHistory CardanoMode
npEraHistory SystemStart
npSystemStart SlotNo
slotNo)
    forall (m :: * -> *) a. Monad m => a -> m a
return (SlotNo
slotNo, SlotLength
npSlotLength, UTCTime
utime)

instance Monad m => MonadMockchain (MockchainT m) where
  modifySlot :: forall a. (SlotNo -> (SlotNo, a)) -> MockchainT m a
modifySlot SlotNo -> (SlotNo, a)
f = forall (m :: * -> *) a.
ReaderT
  NodeParams (StateT MockChainState (ExceptT MockchainError m)) a
-> MockchainT m a
MockchainT forall a b. (a -> b) -> a -> b
$ do
    SlotNo
s <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ Lens' MockChainState (MempoolEnv ERA)
env forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (LedgerEnv era) SlotNo
L.slot)
    let (SlotNo
s', a
a) = SlotNo -> (SlotNo, a)
f SlotNo
s
    forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (forall s t a b. ASetter s t a b -> b -> s -> t
set (Lens' MockChainState (MempoolEnv ERA)
env forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (LedgerEnv era) SlotNo
L.slot) SlotNo
s')
    forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
  modifyUtxo :: forall a. (UTxO ERA -> (UTxO ERA, a)) -> MockchainT m a
modifyUtxo UTxO ERA -> (UTxO ERA, a)
f = forall (m :: * -> *) a.
ReaderT
  NodeParams (StateT MockChainState (ExceptT MockchainError m)) a
-> MockchainT m a
MockchainT forall a b. (a -> b) -> a -> b
$ do
    NodeParams
nps <- forall r (m :: * -> *). MonadReader r m => m r
ask
    UTxO ERA
u <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ Lens' MockChainState (MempoolState ERA)
poolState forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (LedgerState era) (UTxOState era)
L.utxoState forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxOut era =>
PParams era
-> Iso' (UTxOState era) (UTxO era, Coin, Coin, GovernanceState era)
L._UTxOState (NodeParams -> PParams ERA
Defaults.pParams NodeParams
nps) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a b. Field1 s t a b => Lens s t a b
_1)
    let (UTxO ERA
u', a
a) = UTxO ERA -> (UTxO ERA, a)
f UTxO ERA
u
    forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (forall s t a b. ASetter s t a b -> b -> s -> t
set (Lens' MockChainState (MempoolState ERA)
poolState forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (LedgerState era) (UTxOState era)
L.utxoState forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxOut era =>
PParams era
-> Iso' (UTxOState era) (UTxO era, Coin, Coin, GovernanceState era)
L._UTxOState (NodeParams -> PParams ERA
Defaults.pParams NodeParams
nps) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a b. Field1 s t a b => Lens s t a b
_1) UTxO ERA
u')
    forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
  resolveDatumHash :: Hash ScriptData -> MockchainT m (Maybe ScriptData)
resolveDatumHash Hash ScriptData
k = forall (m :: * -> *) a.
ReaderT
  NodeParams (StateT MockChainState (ExceptT MockchainError m)) a
-> MockchainT m a
MockchainT (forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Hash ScriptData
k forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' MockChainState (Map (Hash ScriptData) ScriptData)
datums))


{-| Add all datums from the transaction to the map of known datums
-}
addDatumHashes :: MonadState MockChainState m => Tx BabbageEra -> m ()
addDatumHashes :: forall (m :: * -> *).
MonadState MockChainState m =>
Tx BabbageEra -> m ()
addDatumHashes (Cardano.Api.Tx (ShelleyTxBody ShelleyBasedEra BabbageEra
Cardano.Api.ShelleyBasedEraBabbage TxBody (ShelleyLedgerEra BabbageEra)
txBody [Script (ShelleyLedgerEra BabbageEra)]
_scripts TxBodyScriptData BabbageEra
scriptData Maybe (TxAuxData (ShelleyLedgerEra BabbageEra))
_auxData TxScriptValidity BabbageEra
_) [KeyWitness BabbageEra]
_witnesses) = do
  let txOuts :: [TxOut CtxTx BabbageEra]
txOuts = forall era.
ShelleyBasedEra era
-> TxBody (ShelleyLedgerEra era)
-> TxBodyScriptData era
-> [TxOut CtxTx era]
Cardano.Api.fromLedgerTxOuts ShelleyBasedEra BabbageEra
Cardano.Api.ShelleyBasedEraBabbage TxBody (ShelleyLedgerEra BabbageEra)
txBody TxBodyScriptData BabbageEra
scriptData

  let insertHashableScriptData :: HashableScriptData -> m ()
insertHashableScriptData HashableScriptData
hashableScriptData =
        Lens' MockChainState (Map (Hash ScriptData) ScriptData)
datums forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (HashableScriptData -> Hash ScriptData
Cardano.Api.hashScriptDataBytes HashableScriptData
hashableScriptData) (HashableScriptData -> ScriptData
Cardano.Api.getScriptData HashableScriptData
hashableScriptData)

  forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [TxOut CtxTx BabbageEra]
txOuts forall a b. (a -> b) -> a -> b
$ \(forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (forall ctx era.
Iso'
  (TxOut ctx era)
  (AddressInEra era, TxOutValue era, TxOutDatum ctx era,
   ReferenceScript era)
L._TxOut forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a b. Field3 s t a b => Lens s t a b
_3) -> TxOutDatum CtxTx BabbageEra
txDat) -> case TxOutDatum CtxTx BabbageEra
txDat of
    Cardano.Api.TxOutDatumInline ReferenceTxInsScriptsInlineDatumsSupportedInEra BabbageEra
_ HashableScriptData
dat -> forall {m :: * -> *}.
MonadState MockChainState m =>
HashableScriptData -> m ()
insertHashableScriptData HashableScriptData
dat
    TxOutDatum CtxTx BabbageEra
_                                  -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

  case TxBodyScriptData BabbageEra
scriptData of
    Cardano.Api.TxBodyScriptData ScriptDataSupportedInEra BabbageEra
Cardano.Api.ScriptDataInBabbageEra (forall era. TxDats era -> Map (DataHash (EraCrypto era)) (Data era)
unTxDats -> Map (DataHash (EraCrypto ERA)) (Data ERA)
txDats) Redeemers (ShelleyLedgerEra BabbageEra)
_redeemers -> do
      forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (forall {m :: * -> *}.
MonadState MockChainState m =>
HashableScriptData -> m ()
insertHashableScriptData forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall ledgerera. Data ledgerera -> HashableScriptData
Cardano.Api.fromAlonzoData) Map (DataHash (EraCrypto ERA)) (Data ERA)
txDats
    TxBodyScriptData BabbageEra
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

{-| All transaction outputs
-}
utxoSet :: MonadMockchain m => m (UtxoSet Cardano.Api.CtxUTxO ())
utxoSet :: forall (m :: * -> *). MonadMockchain m => m (UtxoSet CtxUTxO ())
utxoSet =
  let f :: UTxO ERA -> (UTxO ERA, UtxoSet CtxUTxO ())
f (UTxO ERA
utxos) = (UTxO ERA
utxos, UTxO BabbageEra -> UtxoSet CtxUTxO ()
fromApiUtxo forall a b. (a -> b) -> a -> b
$ forall era ledgerera.
(ShelleyLedgerEra era ~ ledgerera,
 EraCrypto ledgerera ~ StandardCrypto) =>
ShelleyBasedEra era -> UTxO ledgerera -> UTxO era
fromLedgerUTxO ShelleyBasedEra BabbageEra
Cardano.Api.ShelleyBasedEraBabbage UTxO ERA
utxos)
  in forall (m :: * -> *) a.
MonadMockchain m =>
(UTxO ERA -> (UTxO ERA, a)) -> m a
modifyUtxo UTxO ERA -> (UTxO ERA, UtxoSet CtxUTxO ())
f

{-| The wallet's transaction outputs on the mockchain
-}
walletUtxo :: MonadMockchain m => Wallet -> m (UtxoSet Cardano.Api.CtxUTxO ())
walletUtxo :: forall (m :: * -> *).
MonadMockchain m =>
Wallet -> m (UtxoSet CtxUTxO ())
walletUtxo Wallet
wallet = do
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall ctx a. PaymentCredential -> UtxoSet ctx a -> UtxoSet ctx a
onlyCredential (Wallet -> PaymentCredential
paymentCredential Wallet
wallet)) forall (m :: * -> *). MonadMockchain m => m (UtxoSet CtxUTxO ())
utxoSet

{-| Run the 'MockchainT' action with the @NodeParams@ from an initial state
-}
runMockchainT :: MockchainT m a -> NodeParams -> MockChainState -> m (Either MockchainError (a, MockChainState))
runMockchainT :: forall (m :: * -> *) a.
MockchainT m a
-> NodeParams
-> MockChainState
-> m (Either MockchainError (a, MockChainState))
runMockchainT (MockchainT ReaderT
  NodeParams (StateT MockChainState (ExceptT MockchainError m)) a
action) NodeParams
nps MockChainState
state =
  forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT
  NodeParams (StateT MockChainState (ExceptT MockchainError m)) a
action NodeParams
nps) MockChainState
state)

type Mockchain a = MockchainT Identity a

runMockchain :: Mockchain a -> NodeParams -> MockChainState -> Either MockchainError (a, MockChainState)
runMockchain :: forall a.
Mockchain a
-> NodeParams
-> MockChainState
-> Either MockchainError (a, MockChainState)
runMockchain Mockchain a
action NodeParams
nps = forall a. Identity a -> a
runIdentity forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a.
MockchainT m a
-> NodeParams
-> MockChainState
-> m (Either MockchainError (a, MockChainState))
runMockchainT Mockchain a
action NodeParams
nps

{-| Run the mockchain action with an initial distribution, using the default node parameters
-}
runMockchain0 :: InitialUTXOs -> Mockchain a -> Either MockchainError (a, MockChainState)
runMockchain0 :: forall a.
InitialUTXOs
-> Mockchain a -> Either MockchainError (a, MockChainState)
runMockchain0 InitialUTXOs
dist = forall a.
InitialUTXOs
-> NodeParams
-> Mockchain a
-> Either MockchainError (a, MockChainState)
runMockchain0With InitialUTXOs
dist NodeParams
Defaults.nodeParams

{-| Run the mockchain action with an initial distribution and a given set of node params
-}
runMockchain0With :: InitialUTXOs -> NodeParams -> Mockchain a -> Either MockchainError (a, MockChainState)
runMockchain0With :: forall a.
InitialUTXOs
-> NodeParams
-> Mockchain a
-> Either MockchainError (a, MockChainState)
runMockchain0With InitialUTXOs
dist NodeParams
params Mockchain a
action = forall a.
Mockchain a
-> NodeParams
-> MockChainState
-> Either MockchainError (a, MockChainState)
runMockchain Mockchain a
action NodeParams
params (NodeParams -> InitialUTXOs -> MockChainState
initialStateFor NodeParams
params InitialUTXOs
dist)

evalMockchainT :: Functor m => MockchainT m a -> NodeParams -> MockChainState -> m (Either MockchainError a)
evalMockchainT :: forall (m :: * -> *) a.
Functor m =>
MockchainT m a
-> NodeParams -> MockChainState -> m (Either MockchainError a)
evalMockchainT MockchainT m a
action NodeParams
nps = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a.
MockchainT m a
-> NodeParams
-> MockChainState
-> m (Either MockchainError (a, MockChainState))
runMockchainT MockchainT m a
action NodeParams
nps

evalMockchain :: Mockchain a -> NodeParams -> MockChainState -> Either MockchainError a
evalMockchain :: forall a.
Mockchain a
-> NodeParams -> MockChainState -> Either MockchainError a
evalMockchain Mockchain a
action NodeParams
nps = forall a. Identity a -> a
runIdentity forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a.
Functor m =>
MockchainT m a
-> NodeParams -> MockChainState -> m (Either MockchainError a)
evalMockchainT Mockchain a
action NodeParams
nps

evalMockchain0 :: InitialUTXOs -> Mockchain a -> Either MockchainError a
evalMockchain0 :: forall a. InitialUTXOs -> Mockchain a -> Either MockchainError a
evalMockchain0 InitialUTXOs
dist Mockchain a
action = forall a.
Mockchain a
-> NodeParams -> MockChainState -> Either MockchainError a
evalMockchain Mockchain a
action NodeParams
Defaults.nodeParams (NodeParams -> InitialUTXOs -> MockChainState
initialStateFor NodeParams
Defaults.nodeParams InitialUTXOs
dist)

execMockchainT :: Functor m => MockchainT m a -> NodeParams -> MockChainState -> m (Either MockchainError MockChainState)
execMockchainT :: forall (m :: * -> *) a.
Functor m =>
MockchainT m a
-> NodeParams
-> MockChainState
-> m (Either MockchainError MockChainState)
execMockchainT MockchainT m a
action NodeParams
nps = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a.
MockchainT m a
-> NodeParams
-> MockChainState
-> m (Either MockchainError (a, MockChainState))
runMockchainT MockchainT m a
action NodeParams
nps

execMockchain :: Mockchain a -> NodeParams -> MockChainState -> Either MockchainError MockChainState
execMockchain :: forall a.
Mockchain a
-> NodeParams
-> MockChainState
-> Either MockchainError MockChainState
execMockchain Mockchain a
action NodeParams
nps = forall a. Identity a -> a
runIdentity forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a.
Functor m =>
MockchainT m a
-> NodeParams
-> MockChainState
-> m (Either MockchainError MockChainState)
execMockchainT Mockchain a
action NodeParams
nps

execMockchain0 :: InitialUTXOs -> Mockchain a -> Either MockchainError MockChainState
execMockchain0 :: forall a.
InitialUTXOs -> Mockchain a -> Either MockchainError MockChainState
execMockchain0 InitialUTXOs
dist Mockchain a
action = forall a.
Mockchain a
-> NodeParams
-> MockChainState
-> Either MockchainError MockChainState
execMockchain Mockchain a
action NodeParams
Defaults.nodeParams (NodeParams -> InitialUTXOs -> MockChainState
initialStateFor NodeParams
Defaults.nodeParams InitialUTXOs
dist)

type MockchainIO a = MockchainT IO a

runMockchainIO :: MockchainIO a -> NodeParams -> MockChainState -> IO (Either MockchainError (a, MockChainState))
runMockchainIO :: forall a.
MockchainIO a
-> NodeParams
-> MockChainState
-> IO (Either MockchainError (a, MockChainState))
runMockchainIO MockchainIO a
action NodeParams
nps = forall (m :: * -> *) a.
MockchainT m a
-> NodeParams
-> MockChainState
-> m (Either MockchainError (a, MockChainState))
runMockchainT MockchainIO a
action NodeParams
nps

{-| Run the mockchain IO action with an initial distribution, using the default node parameters
-}
runMockchain0IO :: InitialUTXOs -> MockchainIO a -> IO (Either MockchainError (a, MockChainState))
runMockchain0IO :: forall a.
InitialUTXOs
-> MockchainIO a -> IO (Either MockchainError (a, MockChainState))
runMockchain0IO InitialUTXOs
dist = forall a.
InitialUTXOs
-> NodeParams
-> MockchainIO a
-> IO (Either MockchainError (a, MockChainState))
runMockchain0IOWith InitialUTXOs
dist NodeParams
Defaults.nodeParams

{-| Run the mockchain IO action with an initial distribution and a given set of node params
-}
runMockchain0IOWith :: InitialUTXOs -> NodeParams -> MockchainIO a -> IO (Either MockchainError (a, MockChainState))
runMockchain0IOWith :: forall a.
InitialUTXOs
-> NodeParams
-> MockchainIO a
-> IO (Either MockchainError (a, MockChainState))
runMockchain0IOWith InitialUTXOs
dist NodeParams
params MockchainIO a
action = forall a.
MockchainIO a
-> NodeParams
-> MockChainState
-> IO (Either MockchainError (a, MockChainState))
runMockchainIO MockchainIO a
action NodeParams
params (NodeParams -> InitialUTXOs -> MockChainState
initialStateFor NodeParams
params InitialUTXOs
dist)

evalMockchainIO :: MockchainIO a -> NodeParams -> MockChainState -> IO (Either MockchainError a)
evalMockchainIO :: forall a.
MockchainIO a
-> NodeParams -> MockChainState -> IO (Either MockchainError a)
evalMockchainIO MockchainIO a
action NodeParams
nps = forall (m :: * -> *) a.
Functor m =>
MockchainT m a
-> NodeParams -> MockChainState -> m (Either MockchainError a)
evalMockchainT MockchainIO a
action NodeParams
nps

evalMockchain0IO :: InitialUTXOs -> MockchainIO a -> IO (Either MockchainError a)
evalMockchain0IO :: forall a.
InitialUTXOs -> MockchainIO a -> IO (Either MockchainError a)
evalMockchain0IO InitialUTXOs
dist MockchainIO a
action = forall a.
MockchainIO a
-> NodeParams -> MockChainState -> IO (Either MockchainError a)
evalMockchainIO MockchainIO a
action NodeParams
Defaults.nodeParams (NodeParams -> InitialUTXOs -> MockChainState
initialStateFor NodeParams
Defaults.nodeParams InitialUTXOs
dist)

execMockchainIO :: MockchainIO a -> NodeParams -> MockChainState -> IO (Either MockchainError MockChainState)
execMockchainIO :: forall a.
MockchainIO a
-> NodeParams
-> MockChainState
-> IO (Either MockchainError MockChainState)
execMockchainIO MockchainIO a
action NodeParams
nps = forall (m :: * -> *) a.
Functor m =>
MockchainT m a
-> NodeParams
-> MockChainState
-> m (Either MockchainError MockChainState)
execMockchainT MockchainIO a
action NodeParams
nps

execMockchain0IO :: InitialUTXOs -> MockchainIO a -> IO (Either MockchainError MockChainState)
execMockchain0IO :: forall a.
InitialUTXOs
-> MockchainIO a -> IO (Either MockchainError MockChainState)
execMockchain0IO InitialUTXOs
dist MockchainIO a
action = forall a.
MockchainIO a
-> NodeParams
-> MockChainState
-> IO (Either MockchainError MockChainState)
execMockchainIO MockchainIO a
action NodeParams
Defaults.nodeParams (NodeParams -> InitialUTXOs -> MockChainState
initialStateFor NodeParams
Defaults.nodeParams InitialUTXOs
dist)

-- not exported by cardano-api 1.35.3 (though it seems like it's exported in 1.36)
fromLedgerUTxO :: ShelleyLedgerEra era ~ ledgerera
               => EraCrypto ledgerera ~ StandardCrypto
               => Cardano.Api.ShelleyBasedEra era
               -> UTxO ledgerera
               -> Cardano.Api.UTxO era
fromLedgerUTxO :: forall era ledgerera.
(ShelleyLedgerEra era ~ ledgerera,
 EraCrypto ledgerera ~ StandardCrypto) =>
ShelleyBasedEra era -> UTxO ledgerera -> UTxO era
fromLedgerUTxO ShelleyBasedEra era
era (UTxO Map (TxIn (EraCrypto ledgerera)) (TxOut ledgerera)
utxo) =
  forall era. Map TxIn (TxOut CtxUTxO era) -> UTxO era
Cardano.Api.UTxO
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap TxIn StandardCrypto -> TxIn
Cardano.Api.fromShelleyTxIn (forall era ledgerera ctx.
(ShelleyLedgerEra era ~ ledgerera) =>
ShelleyBasedEra era -> TxOut ledgerera -> TxOut ctx era
Cardano.Api.fromShelleyTxOut ShelleyBasedEra era
era))
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [(k, a)]
Map.toList
  forall a b. (a -> b) -> a -> b
$ Map (TxIn (EraCrypto ledgerera)) (TxOut ledgerera)
utxo

-- not exported by cardano-api
unbundleLedgerShelleyBasedProtocolParams
  :: Cardano.Api.ShelleyBasedEra era
  -> Cardano.Api.BundledProtocolParameters era
  -> Core.PParams (ShelleyLedgerEra era)
unbundleLedgerShelleyBasedProtocolParams :: forall era.
ShelleyBasedEra era
-> BundledProtocolParameters era -> PParams (ShelleyLedgerEra era)
unbundleLedgerShelleyBasedProtocolParams = \case
  ShelleyBasedEra era
Cardano.Api.ShelleyBasedEraShelley -> \(Cardano.Api.BundleAsShelleyBasedProtocolParameters ShelleyBasedEra era
_ ProtocolParameters
_ PParams (ShelleyLedgerEra era)
lpp) -> PParams (ShelleyLedgerEra era)
lpp
  ShelleyBasedEra era
Cardano.Api.ShelleyBasedEraAllegra -> \(Cardano.Api.BundleAsShelleyBasedProtocolParameters ShelleyBasedEra era
_ ProtocolParameters
_ PParams (ShelleyLedgerEra era)
lpp) -> PParams (ShelleyLedgerEra era)
lpp
  ShelleyBasedEra era
Cardano.Api.ShelleyBasedEraMary -> \(Cardano.Api.BundleAsShelleyBasedProtocolParameters ShelleyBasedEra era
_ ProtocolParameters
_ PParams (ShelleyLedgerEra era)
lpp) -> PParams (ShelleyLedgerEra era)
lpp
  ShelleyBasedEra era
Cardano.Api.ShelleyBasedEraAlonzo -> \(Cardano.Api.BundleAsShelleyBasedProtocolParameters ShelleyBasedEra era
_ ProtocolParameters
_ PParams (ShelleyLedgerEra era)
lpp) -> PParams (ShelleyLedgerEra era)
lpp
  ShelleyBasedEra era
Cardano.Api.ShelleyBasedEraBabbage -> \(Cardano.Api.BundleAsShelleyBasedProtocolParameters ShelleyBasedEra era
_ ProtocolParameters
_ PParams (ShelleyLedgerEra era)
lpp) -> PParams (ShelleyLedgerEra era)
lpp
  ShelleyBasedEra era
Cardano.Api.ShelleyBasedEraConway -> \(Cardano.Api.BundleAsShelleyBasedProtocolParameters ShelleyBasedEra era
_ ProtocolParameters
_ PParams (ShelleyLedgerEra era)
lpp) -> PParams (ShelleyLedgerEra era)
lpp