From 78c921dd6375dc2c00596ed18af4cb46298946da Mon Sep 17 00:00:00 2001 From: Konstantinos Lambrou-Latreille Date: Thu, 14 Nov 2024 14:17:51 -0500 Subject: [PATCH 1/3] Make Conway era specific function more general * Change signature of unTransAddressInEra, transAddressInEra, unTransTxOutValue, unTransTxOutDatumHash * Change signature of sendFaucetFundsTo, createSeededWallet, balanceAndSubmit, balanceAndSubmitReturn --- src/base/lib/Convex/PlutusLedger.hs | 25 +++++++++++++++--------- src/base/test/Convex/PlutusLedgerSpec.hs | 17 ++++++++-------- src/devnet/lib/Convex/Devnet/Wallet.hs | 15 +++++++------- src/devnet/test/Spec.hs | 10 +++++----- 4 files changed, 38 insertions(+), 29 deletions(-) diff --git a/src/base/lib/Convex/PlutusLedger.hs b/src/base/lib/Convex/PlutusLedger.hs index 12012dc5..5d5ba980 100644 --- a/src/base/lib/Convex/PlutusLedger.hs +++ b/src/base/lib/Convex/PlutusLedger.hs @@ -68,6 +68,7 @@ module Convex.PlutusLedger( ) where +import qualified Cardano.Api.Ledger as Ledger import qualified Cardano.Api.Shelley as C import Cardano.Ledger.BaseTypes (CertIx (..), TxIx (..)) import Cardano.Ledger.Credential (Ptr (..)) @@ -115,7 +116,7 @@ transAssetId :: C.AssetId -> Value.AssetClass transAssetId C.AdaAssetId = Value.assetClass PV1.adaSymbol PV1.adaToken transAssetId (C.AssetId policyId assetName) = Value.assetClass - (transPolicyId $ policyId) + (transPolicyId policyId) (transAssetName $ toMaryAssetName assetName) toMaryAssetName :: C.AssetName -> Mary.AssetName @@ -185,16 +186,16 @@ unTransStakeAddressReference (Just (PV1.StakingHash credential)) = unTransStakeAddressReference (Just (PV1.StakingPtr slotNo txIx ptrIx)) = Right (C.StakeAddressByPointer (C.StakeAddressPointer (Ptr (C.SlotNo $ fromIntegral slotNo) (TxIx $ fromIntegral txIx) (CertIx $ fromIntegral ptrIx)))) -unTransAddressInEra :: C.NetworkId -> PV1.Address -> Either C.SerialiseAsRawBytesError (C.AddressInEra C.ConwayEra) +unTransAddressInEra :: C.IsShelleyBasedEra era => C.NetworkId -> PV1.Address -> Either C.SerialiseAsRawBytesError (C.AddressInEra era) unTransAddressInEra networkId addr = - C.AddressInEra (C.ShelleyAddressInEra C.ShelleyBasedEraConway) <$> + C.AddressInEra (C.ShelleyAddressInEra C.shelleyBasedEra) <$> unTransAddressShelley networkId addr -- | @cardano-api@ address to @plutus@ address. Returns 'Nothing' for -- | byron addresses. -transAddressInEra :: C.AddressInEra C.ConwayEra -> Maybe PV1.Address +transAddressInEra :: C.AddressInEra era -> Maybe PV1.Address transAddressInEra = \case - C.AddressInEra (C.ShelleyAddressInEra C.ShelleyBasedEraConway) shelleyAddr -> + C.AddressInEra (C.ShelleyAddressInEra _) shelleyAddr -> Just $ transAddressShelley shelleyAddr C.AddressInEra C.ByronAddressInAnyEra _ -> Nothing @@ -227,8 +228,14 @@ transPOSIXTime posixTimeSeconds = PV1.POSIXTime (floor @Rational (1000 * realToF unTransPOSIXTime :: PV1.POSIXTime -> POSIXTime unTransPOSIXTime (PV1.POSIXTime pt) = realToFrac @Rational $ fromIntegral pt / 1000 -unTransTxOutValue :: PV1.Value -> Either C.SerialiseAsRawBytesError (C.TxOutValue C.ConwayEra) -unTransTxOutValue value = C.TxOutValueShelleyBased C.ShelleyBasedEraConway . C.toMaryValue <$> unTransValue value +unTransTxOutValue :: forall era. + ( C.IsBabbageBasedEra era + , Eq (Ledger.Value (C.ShelleyLedgerEra era)) + , Show (Ledger.Value (C.ShelleyLedgerEra era)) + ) + => PV1.Value + -> Either C.SerialiseAsRawBytesError (C.TxOutValue era) +unTransTxOutValue value = C.TxOutValueShelleyBased C.shelleyBasedEra . C.toLedgerValue @era C.maryBasedEra <$> unTransValue value unTransValue :: PV1.Value -> Either C.SerialiseAsRawBytesError C.Value unTransValue = @@ -256,5 +263,5 @@ unTransScriptDataHash :: P.DatumHash -> Either C.SerialiseAsRawBytesError (C.Has unTransScriptDataHash (P.DatumHash bs) = C.deserialiseFromRawBytes (C.AsHash C.AsScriptData) (PlutusTx.fromBuiltin bs) -unTransTxOutDatumHash :: P.DatumHash -> Either C.SerialiseAsRawBytesError (C.TxOutDatum ctx C.ConwayEra) -unTransTxOutDatumHash datumHash = C.TxOutDatumHash C.AlonzoEraOnwardsConway <$> unTransScriptDataHash datumHash +unTransTxOutDatumHash :: C.IsAlonzoBasedEra era => P.DatumHash -> Either C.SerialiseAsRawBytesError (C.TxOutDatum ctx era) +unTransTxOutDatumHash datumHash = C.TxOutDatumHash C.alonzoBasedEra <$> unTransScriptDataHash datumHash diff --git a/src/base/test/Convex/PlutusLedgerSpec.hs b/src/base/test/Convex/PlutusLedgerSpec.hs index 4b594715..3b71bb1c 100644 --- a/src/base/test/Convex/PlutusLedgerSpec.hs +++ b/src/base/test/Convex/PlutusLedgerSpec.hs @@ -1,14 +1,15 @@ {-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE GADTs #-} +{-# LANGUAGE GADTs #-} module Convex.PlutusLedgerSpec where -import qualified Cardano.Api.Shelley as C -import Test.Gen.Cardano.Api.Typed qualified as CGen -import Convex.PlutusLedger (transAddressShelley, unTransAddressShelley) -import Test.QuickCheck qualified as QC -import Test.QuickCheck.Hedgehog qualified as QC -import qualified Cardano.Api.Ledger as Shelley +import qualified Cardano.Api.Ledger as Shelley +import qualified Cardano.Api.Shelley as C +import Convex.PlutusLedger (transAddressShelley, + unTransAddressShelley) +import qualified Test.Gen.Cardano.Api.Typed as CGen +import qualified Test.QuickCheck as QC +import qualified Test.QuickCheck.Hedgehog as QC newtype ArbitraryNetworkMagic = ArbitraryNetworkMagic C.NetworkMagic deriving stock (Show) @@ -29,5 +30,5 @@ prop_rountripAddressShelleyPlutusTranslation = do let nid = case n of Shelley.Mainnet -> C.Mainnet; Shelley.Testnet -> C.Testnet nm case unTransAddressShelley nid (transAddressShelley addr) of - Left _err -> False + Left _err -> False Right addr' -> addr' == addr diff --git a/src/devnet/lib/Convex/Devnet/Wallet.hs b/src/devnet/lib/Convex/Devnet/Wallet.hs index 4a3092aa..928e7b0a 100644 --- a/src/devnet/lib/Convex/Devnet/Wallet.hs +++ b/src/devnet/lib/Convex/Devnet/Wallet.hs @@ -23,7 +23,7 @@ module Convex.Devnet.Wallet( runningNodeBlockchain ) where -import Cardano.Api (AddressInEra, ConwayEra, +import Cardano.Api (AddressInEra, Quantity, Tx) import qualified Cardano.Api as C import Control.Monad (replicateM) @@ -64,7 +64,7 @@ walletUtxos RunningNode{rnConnectInfo, rnNetworkId} wllt = {-| Send @n@ times the given amount of lovelace to the address -} -sendFaucetFundsTo :: Tracer IO WalletLog -> RunningNode -> AddressInEra ConwayEra -> Int -> Quantity -> IO (Tx ConwayEra) +sendFaucetFundsTo :: forall era. C.IsBabbageBasedEra era => Tracer IO WalletLog -> RunningNode -> AddressInEra era -> Int -> Quantity -> IO (Tx era) sendFaucetFundsTo tracer node destination n amount = do fct <- faucet balanceAndSubmit tracer node fct (BuildTx.execBuildTx $ replicateM n (BuildTx.payToAddress destination (C.lovelaceToValue $ C.quantityToLovelace amount))) TrailingChange [] @@ -72,11 +72,11 @@ sendFaucetFundsTo tracer node destination n amount = do {-| Create a new wallet and send @n@ times the given amount of lovelace to it. Returns when the seed txn has been registered on the chain. -} -createSeededWallet :: Tracer IO WalletLog -> RunningNode -> Int -> Quantity -> IO Wallet -createSeededWallet tracer node@RunningNode{rnNetworkId, rnConnectInfo} n amount = do +createSeededWallet :: forall era. C.IsBabbageBasedEra era => C.BabbageEraOnwards era -> Tracer IO WalletLog -> RunningNode -> Int -> Quantity -> IO Wallet +createSeededWallet _babbageEraOnwards tracer node@RunningNode{rnNetworkId, rnConnectInfo} n amount = do wallet <- Wallet.generateWallet traceWith tracer (GeneratedWallet wallet) - sendFaucetFundsTo tracer node (Wallet.addressInEra rnNetworkId wallet) n amount >>= NodeQueries.waitForTx rnConnectInfo + sendFaucetFundsTo tracer node (Wallet.addressInEra @era rnNetworkId wallet) n amount >>= NodeQueries.waitForTx rnConnectInfo pure wallet {-| Run a 'MonadBlockchain' action, using the @Tracer@ for log messages and the @@ -93,7 +93,7 @@ runningNodeBlockchain tracer RunningNode{rnConnectInfo} = {-| Balance and submit the transaction using the wallet's UTXOs -} -balanceAndSubmit :: forall era. (C.IsBabbageBasedEra era) => Tracer IO WalletLog -> RunningNode -> Wallet -> TxBuilder era -> ChangeOutputPosition -> [C.ShelleyWitnessSigningKey] -> IO (Tx era) +balanceAndSubmit :: forall era. C.IsBabbageBasedEra era => Tracer IO WalletLog -> RunningNode -> Wallet -> TxBuilder era -> ChangeOutputPosition -> [C.ShelleyWitnessSigningKey] -> IO (Tx era) balanceAndSubmit tracer node wallet tx changePosition keys = do n <- runningNodeBlockchain @era tracer node queryNetworkId let walletAddress = Wallet.addressInEra n wallet @@ -103,7 +103,8 @@ balanceAndSubmit tracer node wallet tx changePosition keys = do {-| Balance and submit the transaction using the wallet's UTXOs -} balanceAndSubmitReturn - :: forall era. (C.IsBabbageBasedEra era) + :: forall era. + C.IsBabbageBasedEra era => Tracer IO WalletLog -> RunningNode -> Wallet diff --git a/src/devnet/test/Spec.hs b/src/devnet/test/Spec.hs index 673c440f..8e8c8256 100644 --- a/src/devnet/test/Spec.hs +++ b/src/devnet/test/Spec.hs @@ -115,7 +115,7 @@ checkTransitionToConway = do Queries.queryEra rnConnectInfo >>= assertEqual "Should be in conway era" (C.anyCardanoEra C.ConwayEra) let lovelacePerUtxo = 100_000_000 numUtxos = 10 - void $ W.createSeededWallet (contramap TLWallet tr) runningNode numUtxos lovelacePerUtxo + void $ W.createSeededWallet C.BabbageEraOnwardsConway (contramap TLWallet tr) runningNode numUtxos lovelacePerUtxo majorProtVersionsRef <- newIORef [] res <- C.liftIO $ runExceptT $ runNodeClient rnNodeConfigFile rnNodeSocket $ \_localNodeConnectInfo env -> do pure $ foldClient () NoLedgerStateArgs env $ \_catchingUp _ _ bim -> do @@ -146,7 +146,7 @@ startLocalStakePoolNode = do let lovelacePerUtxo = 100_000_000 numUtxos = 10 nodeConfigFile = tmp "cardano-node.json" - wllt <- W.createSeededWallet (contramap TLWallet tr) runningNode numUtxos lovelacePerUtxo + wllt <- W.createSeededWallet C.BabbageEraOnwardsConway (contramap TLWallet tr) runningNode numUtxos lovelacePerUtxo withTempDir "cardano-cluster-stakepool" $ \tmp' -> do withCardanoStakePoolNodeDevnetConfig (contramap TLNode tr) tmp' wllt defaultStakePoolNodeParams nodeConfigFile (PortsConfig 3002 [3001]) runningNode $ \RunningStakePoolNode{rspnNode} -> do runExceptT (loadConnectInfo (rnNodeConfigFile rspnNode) (rnNodeSocket rspnNode)) >>= \case @@ -162,7 +162,7 @@ registeredStakePoolNode = do let lovelacePerUtxo = 100_000_000 numUtxos = 10 nodeConfigFile = tmp "cardano-node.json" - wllt <- W.createSeededWallet (contramap TLWallet tr) runningNode numUtxos lovelacePerUtxo + wllt <- W.createSeededWallet C.BabbageEraOnwardsConway (contramap TLWallet tr) runningNode numUtxos lovelacePerUtxo initialStakePools <- queryStakePools rnConnectInfo withTempDir "cardano-cluster-stakepool" $ \tmp' -> do withCardanoStakePoolNodeDevnetConfig (contramap TLNode tr) tmp' wllt defaultStakePoolNodeParams nodeConfigFile (PortsConfig 3002 [3001]) runningNode $ \_ -> do @@ -181,7 +181,7 @@ stakePoolRewards = do let lovelacePerUtxo = 10_000_000_000 numUtxos = 4 nodeConfigFile = tmp "cardano-node.json" - wllt <- W.createSeededWallet (contramap TLWallet tr) runningNode numUtxos lovelacePerUtxo + wllt <- W.createSeededWallet C.BabbageEraOnwardsConway (contramap TLWallet tr) runningNode numUtxos lovelacePerUtxo let stakepoolParams = StakePoolNodeParams { spnCost = 340_000_000 , spnMargin = 1 % 100 @@ -232,7 +232,7 @@ makePayment = do withCardanoNodeDevnet (contramap TLNode tr) tmp $ \runningNode -> do let lovelacePerUtxo = 100_000_000 numUtxos = 10 - wllt <- W.createSeededWallet (contramap TLWallet tr) runningNode numUtxos lovelacePerUtxo + wllt <- W.createSeededWallet C.BabbageEraOnwardsConway (contramap TLWallet tr) runningNode numUtxos lovelacePerUtxo bal <- Utxos.totalBalance <$> W.walletUtxos runningNode wllt assertEqual "Wallet should have the expected balance" (fromIntegral numUtxos * lovelacePerUtxo) (C.lovelaceToQuantity $ C.selectLovelace bal) From d1ed87bb6e318a0a1c3d400050edc54dfe54b79e Mon Sep 17 00:00:00 2001 From: Konstantinos Lambrou-Latreille Date: Sat, 16 Nov 2024 12:48:56 -0500 Subject: [PATCH 2/3] Add transaction building functions for correctly adding registration, deregistration and delegation certificates in Conway era. * Add functions for adding certificates in transactions such as: * `addPreConwayStakeCredentialRegistrationCertificate` * `addPreConwayStakeCredentialUnregistrationCertificate` * `addConwayStakeCredentialRegistrationCertificate` * `addConwayStakeCredentialRegistrationAndDelegationCertificate` * `addConwayStakeCredentialDeRegistrationCertificate` * Add `addStakeScriptWitness` which adds a script stake address witness in the transaction. This is a simplified version of `addStakeWitness`. * Add Convex.Eon.IsShelleyToBabbageEra typeclass for building certificates in pre-conway eras. * Modifies mockchain and devnet protocol parameter default values to reflect actual certificate deposits in current mainnet. * A stake address registration requires 20_000_000 lovelace as deposit. * A stake pool certification requires 500_000_000 lovelace as deposit. * Fix tests given new Conway rules for: * registering stake address * registering stake pool * delegating to stake pools and DReps * withdrawal --- src/base/convex-base.cabal | 1 + src/base/lib/Convex/BuildTx.hs | 205 ++++++++++++++++-- src/base/lib/Convex/Eon.hs | 26 +++ .../convex-coin-selection.cabal | 2 +- .../lib/Convex/MockChain/Staking.hs | 13 +- src/coin-selection/test/Spec.hs | 115 +++++++--- src/devnet/config/devnet/genesis-shelley.json | 2 +- src/devnet/lib/Convex/Devnet/Wallet.hs | 10 +- .../lib/Convex/MockChain/Defaults.hs | 2 + 9 files changed, 316 insertions(+), 60 deletions(-) create mode 100644 src/base/lib/Convex/Eon.hs diff --git a/src/base/convex-base.cabal b/src/base/convex-base.cabal index 70113e5e..eb898875 100644 --- a/src/base/convex-base.cabal +++ b/src/base/convex-base.cabal @@ -31,6 +31,7 @@ library Convex.BuildTx Convex.Class Convex.Constants + Convex.Eon Convex.MonadLog Convex.NodeQueries Convex.NodeQueries.Debug diff --git a/src/base/lib/Convex/BuildTx.hs b/src/base/lib/Convex/BuildTx.hs index c4e87a4f..e14c7389 100644 --- a/src/base/lib/Convex/BuildTx.hs +++ b/src/base/lib/Convex/BuildTx.hs @@ -44,7 +44,6 @@ module Convex.BuildTx( addInputWithTxBody, addMintWithTxBody, addWithdrawalWithTxBody, - addStakeWitnessWithTxBody, addReference, addCollateral, addAuxScript, @@ -81,9 +80,17 @@ module Convex.BuildTx( addWithdrawZeroPlutusV2InTransaction, addWithdrawZeroPlutusV2Reference, addCertificate, - addStakeCredentialCertificate, - addStakeCredentialUnregCertificate, + addShelleyStakeCredentialRegistrationCertificatePreConway, + addShelleyStakeCredentialUnregistrationCertificatePreConway, + addShelleyStakeCredentialRegistrationCertificateInConway, + addShelleyStakeCredentialUnregistrationCertificateInConway, + addConwayStakeCredentialRegistrationCertificate, + addConwayStakeCredentialDelegationCertificate, + addConwayStakeCredentialRegistrationAndDelegationCertificate, + addConwayStakeCredentialUnRegistrationCertificate, addStakeWitness, + addStakeScriptWitness, + addStakeWitnessWithTxBody, -- ** Minting and burning tokens mintPlutus, @@ -107,11 +114,13 @@ module Convex.BuildTx( mkTxOutValue ) where +import qualified Cardano.Api.Ledger as Ledger import Cardano.Api.Shelley (Hash, HashableScriptData, NetworkId, PaymentKey, PlutusScript, PlutusScriptV2, ScriptHash, WitCtxTxIn) import qualified Cardano.Api.Shelley as C +import qualified Cardano.Ledger.Conway.TxCert as ConwayTxCert (Delegatee (..)) import qualified Cardano.Ledger.Shelley.TxCert as TxCert import Control.Lens (_1, _2, at, mapped, over, set, view, (&)) @@ -131,6 +140,7 @@ import Convex.Class (MonadBlockchain (..), MonadBlockchainCardanoNodeT, MonadDatumQuery (queryDatumFromHash), MonadMockchain (..)) +import Convex.Eon (IsShelleyToBabbageEra (shelleyToBabbageEra)) import Convex.MonadLog (MonadLog (..), MonadLogIgnoreT, MonadLogKatipT) import Convex.Scripts (toHashableScriptData) @@ -327,7 +337,40 @@ addWithdrawalWithTxBody :: (MonadBuildTx era m, C.IsShelleyBasedEra era) => C.St addWithdrawalWithTxBody address amount f = addTxBuilder (TxBuilder $ \body -> over (L.txWithdrawals . L._TxWithdrawals) ((address, C.quantityToLovelace amount, C.BuildTxWith $ f body) :)) +{-| Add a stake witness to the transaction. +TODO We should probably remove this as the `addStakeScriptWitness` is more useful. +-} +addStakeWitness :: + ( MonadBuildTx era m + , C.IsShelleyBasedEra era + ) + => C.StakeCredential + -> C.Witness C.WitCtxStake era + -> m () +addStakeWitness credential witness = + addBtx (over (L.txCertificates . L._TxCertificates . _2) ((:) (credential, witness))) + +-- mintPlutus :: forall redeemer lang era m. (Plutus.ToData redeemer, MonadBuildTx era m, C.HasScriptLanguageInEra lang era, C.IsAlonzoBasedEra era, C.IsPlutusScriptLanguage lang) => PlutusScript lang -> redeemer -> C.AssetName -> C.Quantity -> m () +{-| Add a stake script witness to the transaction. +-} +addStakeScriptWitness :: + ( MonadBuildTx era m + , Plutus.ToData redeemer + , C.IsShelleyBasedEra era + , C.IsPlutusScriptLanguage lang + , C.HasScriptLanguageInEra lang era + ) + => C.StakeCredential + -> C.PlutusScript lang + -> redeemer + -> m () +addStakeScriptWitness credential script redeemer = do + let scriptWitness = buildScriptWitness script C.NoScriptDatumForStake redeemer + let witness = C.ScriptWitness C.ScriptWitnessForStakeAddr scriptWitness + addBtx (over (L.txCertificates . L._TxCertificates . _2) ((:) (credential, witness))) + {- | Like @addStakeWitness@ but uses a function that takes a @TxBody@ to build the witness. +TODO Give an example of why this is useful. We should just remove it. -} addStakeWitnessWithTxBody :: (MonadBuildTx era m, C.IsShelleyBasedEra era) => C.StakeCredential -> (TxBody era -> C.Witness C.WitCtxStake era) -> m () addStakeWitnessWithTxBody credential buildWitness = @@ -340,7 +383,7 @@ spendPublicKeyOutput txIn = do let wit = C.BuildTxWith (C.KeyWitness C.KeyWitnessForSpending) addBtx (over L.txIns ((txIn, wit) :)) -{-| Utility function to build a v1 script witness +{-| Utility function to build a script witness -} buildScriptWitness :: forall era lang redeemer witctx. (Plutus.ToData redeemer, C.HasScriptLanguageInEra lang era, C.IsPlutusScriptLanguage lang) => @@ -431,7 +474,18 @@ spendPlutusRefWithoutInRefInlineDatum :: forall redeemer lang era m. => C.TxIn -> C.TxIn -> C.PlutusScriptVersion lang -> redeemer -> m () spendPlutusRefWithoutInRefInlineDatum txIn refTxIn scrVer red = spendPlutusRefBase txIn refTxIn scrVer C.InlineScriptDatum (const red) -mintPlutus :: forall redeemer lang era m. (Plutus.ToData redeemer, MonadBuildTx era m, C.HasScriptLanguageInEra lang era, C.IsAlonzoBasedEra era, C.IsPlutusScriptLanguage lang) => PlutusScript lang -> redeemer -> C.AssetName -> C.Quantity -> m () +mintPlutus :: forall redeemer lang era m. + ( Plutus.ToData redeemer + , MonadBuildTx era m + , C.HasScriptLanguageInEra lang era + , C.IsAlonzoBasedEra era + , C.IsPlutusScriptLanguage lang + ) + => PlutusScript lang + -> redeemer + -> C.AssetName + -> C.Quantity + -> m () mintPlutus script red assetName quantity = let sh = C.hashScript (C.PlutusScript C.plutusScriptVersion script) v = assetValue sh assetName quantity @@ -448,8 +502,18 @@ assetValue hsh assetName quantity = fromList [(C.AssetId (C.PolicyId hsh) assetName, quantity)] mintPlutusRef :: forall redeemer lang era m. - (Plutus.ToData redeemer, MonadBuildTx era m, C.HasScriptLanguageInEra lang era, C.IsBabbageBasedEra era) - => C.TxIn -> C.PlutusScriptVersion lang -> C.ScriptHash -> redeemer -> C.AssetName -> C.Quantity -> m () + ( Plutus.ToData redeemer + , MonadBuildTx era m + , C.HasScriptLanguageInEra lang era + , C.IsBabbageBasedEra era + ) + => C.TxIn + -> C.PlutusScriptVersion lang + -> C.ScriptHash + -> redeemer + -> C.AssetName + -> C.Quantity + -> m () mintPlutusRef refTxIn scrVer sh red assetName quantity = inBabbage @era $ let v = assetValue sh assetName quantity wit = buildRefScriptWitness refTxIn scrVer C.NoScriptDatumForMint red @@ -609,9 +673,16 @@ addScriptWithdrawal sh quantity witness = do {-| Add a withdrawal of 0 Lovelace from the rewards account locked by the given Plutus V2 script. Includes the script in the transaction. -} -addWithdrawZeroPlutusV2InTransaction - :: (MonadBlockchain era m, MonadBuildTx era m, C.HasScriptLanguageInEra PlutusScriptV2 era, Plutus.ToData redeemer, C.IsShelleyBasedEra era) - => PlutusScript PlutusScriptV2 -> redeemer -> m () +addWithdrawZeroPlutusV2InTransaction :: + ( MonadBlockchain era m + , MonadBuildTx era m + , C.HasScriptLanguageInEra PlutusScriptV2 era + , Plutus.ToData redeemer + , C.IsShelleyBasedEra era + ) + => PlutusScript PlutusScriptV2 + -> redeemer + -> m () addWithdrawZeroPlutusV2InTransaction script redeemer = do let sh = C.hashScript $ C.PlutusScript C.PlutusScriptV2 script addScriptWithdrawal sh 0 $ buildScriptWitness script C.NoScriptDatumForStake redeemer @@ -631,20 +702,108 @@ addCertificate :: (MonadBuildTx era m, C.IsShelleyBasedEra era) => C.Certificate addCertificate cert = addBtx (over (L.txCertificates . L._TxCertificates . _1) ((:) cert)) -{-| Add a 'C.StakeCredential' as a certificate to the transaction --} -addStakeCredentialCertificate :: forall era m. C.IsConwayBasedEra era => MonadBuildTx era m => C.StakeCredential -> m () -addStakeCredentialCertificate stk = +{-| Add a 'C.StakeCredential' registration as a ShelleyRelatedCerticate to the transaction in a pre-Conway era. +-} +addShelleyStakeCredentialRegistrationCertificatePreConway :: forall era m. + ( IsShelleyToBabbageEra era + , MonadBuildTx era m + ) + => C.StakeCredential + -> m () +addShelleyStakeCredentialRegistrationCertificatePreConway stakeCred = do + let cert = C.makeStakeAddressRegistrationCertificate $ C.StakeAddrRegistrationPreConway shelleyToBabbageEra stakeCred + addCertificate cert + +{-| Add a 'C.StakeCredential' deregistration as a ShelleyRelatedCerticate to the transaction in a pre-Conway era. +-} +addShelleyStakeCredentialUnregistrationCertificatePreConway :: forall era m. + ( IsShelleyToBabbageEra era + , MonadBuildTx era m + ) + => C.StakeCredential + -> m () +addShelleyStakeCredentialUnregistrationCertificatePreConway stakeCred = do + let cert = C.makeStakeAddressUnregistrationCertificate $ C.StakeAddrRegistrationPreConway shelleyToBabbageEra stakeCred + addCertificate cert + +{-| Add a 'C.StakeCredential' registration as a ShelleyRelatedCerticate to the transaction in Conway era. +-} +addShelleyStakeCredentialRegistrationCertificateInConway :: forall era m. + ( MonadBuildTx era m + , C.IsConwayBasedEra era + ) + => C.StakeCredential + -> m () +addShelleyStakeCredentialRegistrationCertificateInConway stakeCred = do C.conwayEraOnwardsConstraints @era C.conwayBasedEra $ - addCertificate $ C.ConwayCertificate C.conwayBasedEra $ TxCert.RegTxCert $ C.toShelleyStakeCredential stk + addCertificate $ C.ConwayCertificate C.conwayBasedEra $ TxCert.RegTxCert $ C.toShelleyStakeCredential stakeCred -addStakeCredentialUnregCertificate :: forall era m. C.IsConwayBasedEra era => MonadBuildTx era m => C.StakeCredential -> m () -addStakeCredentialUnregCertificate stk = +{-| Add a 'C.StakeCredential' deregistration as a ShelleyRelatedCerticate to the transaction in Conway era. +-} +addShelleyStakeCredentialUnregistrationCertificateInConway :: forall era m. + ( MonadBuildTx era m + , C.IsConwayBasedEra era + ) + => C.StakeCredential + -> m () +addShelleyStakeCredentialUnregistrationCertificateInConway stakeCred = do C.conwayEraOnwardsConstraints @era C.conwayBasedEra $ - addCertificate $ C.ConwayCertificate C.conwayBasedEra $ TxCert.UnRegTxCert $ C.toShelleyStakeCredential stk + addCertificate $ C.ConwayCertificate C.conwayBasedEra $ TxCert.UnRegTxCert $ C.toShelleyStakeCredential stakeCred + +{-| Add a 'C.StakeCredential' registration as a ConwayCerticate to the transaction. +-} +addConwayStakeCredentialRegistrationCertificate :: forall era m. + ( C.IsConwayBasedEra era + , MonadBuildTx era m + ) + => C.StakeCredential + -> Ledger.Coin + -- ^ Deposit, when present, must match the expected deposit amount specified by `ppKeyDepositL` in the protocol parameters. + -> m () +addConwayStakeCredentialRegistrationCertificate stakeCred deposit = do + addCertificate $ C.makeStakeAddressRegistrationCertificate $ C.StakeAddrRegistrationConway C.conwayBasedEra deposit stakeCred + +{-| Delegate to some delegatee in a ConwayCerticate to the transaction. +-} +addConwayStakeCredentialDelegationCertificate :: forall era m. + ( C.IsConwayBasedEra era + , MonadBuildTx era m + ) + => C.StakeCredential + -> ConwayTxCert.Delegatee (Ledger.EraCrypto (C.ShelleyLedgerEra era)) + -> m () +addConwayStakeCredentialDelegationCertificate stakeCred delegatee = do + let cert = + C.makeStakeAddressDelegationCertificate $ + C.StakeDelegationRequirementsConwayOnwards C.conwayBasedEra stakeCred delegatee + addCertificate cert + +{-| Register a 'C.StakeCredential' and delegate to some delegatee in a single ConwayCerticate to the transaction. +-} +addConwayStakeCredentialRegistrationAndDelegationCertificate :: forall era m. + ( C.IsConwayBasedEra era + , MonadBuildTx era m + ) + => C.StakeCredential + -> ConwayTxCert.Delegatee (Ledger.EraCrypto (C.ShelleyLedgerEra era)) + -> Ledger.Coin + -- Deposit is required and must match the expected deposit amount specified by `ppKeyDepositL` in the protocol parameters. + -> m () +addConwayStakeCredentialRegistrationAndDelegationCertificate stakeCred delegatee deposit = do + let cert = C.makeStakeAddressAndDRepDelegationCertificate C.conwayBasedEra stakeCred delegatee deposit + addCertificate cert + +{-| Add a 'C.StakeCredential' as a ConwayEra and onwards deregistration certificate to the transaction. +-} +addConwayStakeCredentialUnRegistrationCertificate :: forall era m. + ( C.IsConwayBasedEra era + , MonadBuildTx era m + ) + => C.StakeCredential + -> Ledger.Coin + -- ^ Deposit, if present, must match the amount that was left as a deposit upon stake credential registration. + -> m () +addConwayStakeCredentialUnRegistrationCertificate stakeCred deposit = do + let cert = C.makeStakeAddressUnregistrationCertificate $ C.StakeAddrRegistrationConway C.conwayBasedEra deposit stakeCred + addCertificate cert -{-| Add a stake witness to the transaction --} -addStakeWitness :: (MonadBuildTx era m, C.IsShelleyBasedEra era) => C.StakeCredential -> C.Witness C.WitCtxStake era -> m () -addStakeWitness credential witness = - addBtx (over (L.txCertificates . L._TxCertificates . _2) ((:) (credential, witness))) diff --git a/src/base/lib/Convex/Eon.hs b/src/base/lib/Convex/Eon.hs new file mode 100644 index 00000000..483b16dc --- /dev/null +++ b/src/base/lib/Convex/Eon.hs @@ -0,0 +1,26 @@ +module Convex.Eon ( + IsShelleyToBabbageEra(shelleyToBabbageEra) +) where + +import qualified Cardano.Api as C + +-- TODO This was deleted from cardano-api because they said it was unused. See +-- https://github.com/IntersectMBO/cardano-api/pull/256. However, because of the +-- Certificate type starting at ConwayEra, that typeclass is a nice to have. +class C.IsShelleyBasedEra era => IsShelleyToBabbageEra era where + shelleyToBabbageEra :: C.ShelleyToBabbageEra era + +instance IsShelleyToBabbageEra C.ShelleyEra where + shelleyToBabbageEra = C.ShelleyToBabbageEraShelley + +instance IsShelleyToBabbageEra C.AllegraEra where + shelleyToBabbageEra = C.ShelleyToBabbageEraAllegra + +instance IsShelleyToBabbageEra C.MaryEra where + shelleyToBabbageEra = C.ShelleyToBabbageEraMary + +instance IsShelleyToBabbageEra C.AlonzoEra where + shelleyToBabbageEra = C.ShelleyToBabbageEraAlonzo + +instance IsShelleyToBabbageEra C.BabbageEra where + shelleyToBabbageEra = C.ShelleyToBabbageEraBabbage diff --git a/src/coin-selection/convex-coin-selection.cabal b/src/coin-selection/convex-coin-selection.cabal index eb5ec636..0982b199 100644 --- a/src/coin-selection/convex-coin-selection.cabal +++ b/src/coin-selection/convex-coin-selection.cabal @@ -54,6 +54,7 @@ library -- cardano dependencies build-depends: cardano-api, + cardano-ledger-api, cardano-ledger-core -any, cardano-ledger-shelley, cardano-slotting, @@ -78,7 +79,6 @@ test-suite convex-coin-selection-test QuickCheck, lens, cardano-ledger-api, - cardano-ledger-core, cardano-ledger-conway, cardano-ledger-shelley, convex-coin-selection, diff --git a/src/coin-selection/lib/Convex/MockChain/Staking.hs b/src/coin-selection/lib/Convex/MockChain/Staking.hs index e429c07d..3d54c7ed 100644 --- a/src/coin-selection/lib/Convex/MockChain/Staking.hs +++ b/src/coin-selection/lib/Convex/MockChain/Staking.hs @@ -3,13 +3,16 @@ {-# LANGUAGE TypeApplications #-} module Convex.MockChain.Staking (registerPool) where -import qualified Cardano.Api.Ledger as C +import qualified Cardano.Api.Ledger as Ledger import qualified Cardano.Api.Shelley as C +import qualified Cardano.Ledger.Core as Ledger +import Control.Lens ((^.)) import Control.Monad (void) import Control.Monad.Except (MonadError) import Control.Monad.IO.Class (MonadIO (..)) import qualified Convex.BuildTx as BuildTx -import Convex.Class (MonadMockchain) +import Convex.Class (MonadBlockchain (queryProtocolParameters), + MonadMockchain) import Convex.CoinSelection (BalanceTxError, ChangeOutputPosition (TrailingChange)) import Convex.MockChain.CoinSelection (tryBalanceAndSubmit) @@ -35,9 +38,11 @@ registerPool wallet = case C.conwayBasedEra @era of stakeCred = C.StakeCredentialByKey stakeHash + pp <- fmap C.unLedgerProtocolParameters queryProtocolParameters + let stakeCert = C.makeStakeAddressRegistrationCertificate - . C.StakeAddrRegistrationConway C.ConwayEraOnwardsConway 0 + . C.StakeAddrRegistrationConway C.ConwayEraOnwardsConway (pp ^. Ledger.ppKeyDepositL) $ stakeCred stakeAddress = C.makeStakeAddress Defaults.networkId stakeCred @@ -46,7 +51,7 @@ registerPool wallet = case C.conwayBasedEra @era of delegationCert = C.makeStakeAddressDelegationCertificate - $ C.StakeDelegationRequirementsConwayOnwards C.ConwayEraOnwardsConway stakeCred (C.DelegStake $ C.unStakePoolKeyHash poolId) + $ C.StakeDelegationRequirementsConwayOnwards C.ConwayEraOnwardsConway stakeCred (Ledger.DelegStake $ C.unStakePoolKeyHash poolId) stakePoolParams = C.StakePoolParameters diff --git a/src/coin-selection/test/Spec.hs b/src/coin-selection/test/Spec.hs index b5d82442..175ad707 100644 --- a/src/coin-selection/test/Spec.hs +++ b/src/coin-selection/test/Spec.hs @@ -6,13 +6,12 @@ module Main(main) where import qualified Cardano.Api as C -import qualified Cardano.Api.Ledger as Ledger hiding (PlutusScript, - TxId, TxIn) +import qualified Cardano.Api.Ledger as Ledger import qualified Cardano.Api.Shelley as C import qualified Cardano.Ledger.Api as Ledger import qualified Cardano.Ledger.Conway.Rules as Rules import Cardano.Ledger.Shelley.API (ApplyTxError (..)) -import Control.Lens (_3, _4, view, (&), (.~)) +import Control.Lens (_3, _4, view, (&), (.~), (^.)) import Control.Monad (replicateM, void, when) import Control.Monad.Except (MonadError, runExceptT) import Control.Monad.IO.Class (MonadIO (..)) @@ -52,8 +51,7 @@ import Convex.MockChain.Utils (mockchainSucceeds, import Convex.NodeParams (ledgerProtocolParameters, protocolParameters) import Convex.Query (balancePaymentCredentials) -import Convex.Utils (failOnError, inBabbage, - inConway) +import Convex.Utils (failOnError, inBabbage) import qualified Convex.Utxos as Utxos import Convex.Wallet (Wallet) import qualified Convex.Wallet as Wallet @@ -68,7 +66,6 @@ import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.Map as Map import qualified Data.Set as Set import qualified PlutusLedgerApi.V2 as PV2 -import qualified Scripts import qualified Test.QuickCheck.Gen as Gen import Test.Tasty (TestTree, defaultMain, testGroup) @@ -76,6 +73,7 @@ import Test.Tasty.HUnit (Assertion, testCase) import qualified Test.Tasty.QuickCheck as QC import Test.Tasty.QuickCheck (Property, classify, testProperty) +import qualified Scripts main :: IO () main = defaultMain tests @@ -106,11 +104,13 @@ tests = testGroup "unit tests" , testCase "large transactions" largeTransactionTest ] , testGroup "staking" - [ testCase "register a staking credential" (mockchainSucceeds $ failOnError registerStakingCredential) - , testCase "zero withdrawal" (mockchainSucceeds $ failOnError $ registerStakingCredential >> withdrawZero) + [ testCase "register a script staking credential with ShelleyCert" (mockchainSucceeds $ failOnError registerScriptStakingCredentialAsShelleyCert) + , testCase "register a script staking credential with ConwayCert" (mockchainSucceeds $ failOnError registerScriptStakingCredentialAsConwayCert) + , testCase "withdrawal zero trick with ShelleyCert" (mockchainSucceeds $ failOnError withdrawZeroTrickWithShelleyCert) + , testCase "withdrawal zero trick with ConwayCert" (mockchainSucceeds $ failOnError withdrawZeroTrickWithConwayCert) , testCase "register a stake pool" (mockchainSucceeds $ failOnError $ registerPool Wallet.w1) , testCase "query stake addresses" (mockchainSucceeds $ failOnError queryStakeAddressesTest) - , testCase "withdrawal" (mockchainSucceeds $ failOnError withdrawalTest) + , testCase "stake key withdrawal" (mockchainSucceeds $ failOnError stakeKeyWithdrawalTest) ] ] @@ -373,22 +373,83 @@ matchingIndex = inBabbage @era $ do -- Spend the outputs in a single transaction void (tryBalanceAndSubmit mempty Wallet.w1 (execBuildTx $ traverse_ Scripts.spendMatchingIndex inputs) TrailingChange []) -stakingCredential :: C.StakeCredential -stakingCredential = C.StakeCredentialByScript $ C.hashScript (C.PlutusScript C.PlutusScriptV2 Scripts.v2StakingScript) +scriptStakingCredential :: C.StakeCredential +scriptStakingCredential = C.StakeCredentialByScript $ C.hashScript (C.PlutusScript C.PlutusScriptV2 Scripts.v2StakingScript) + +registerScriptStakingCredentialAsShelleyCert :: forall era m. + ( MonadMockchain era m + , MonadError (BalanceTxError era) m + , MonadFail m + , C.IsConwayBasedEra era + ) + => m C.TxIn +registerScriptStakingCredentialAsShelleyCert = do + txBody <- BuildTx.execBuildTxT $ BuildTx.addShelleyStakeCredentialRegistrationCertificateInConway scriptStakingCredential + C.TxIn . C.getTxId . C.getTxBody <$> tryBalanceAndSubmit mempty Wallet.w1 txBody TrailingChange [] <*> pure (C.TxIx 0) -registerStakingCredential :: forall era m. (MonadMockchain era m, MonadError (BalanceTxError era) m, MonadFail m, C.IsConwayBasedEra era) => m C.TxIn -registerStakingCredential = inConway @era $ do - let txBody = execBuildTx (BuildTx.addStakeCredentialCertificate stakingCredential) +registerScriptStakingCredentialAsConwayCert :: forall era m. + ( MonadMockchain era m + , MonadError (BalanceTxError era) m + , MonadFail m + , C.IsConwayBasedEra era + , C.HasScriptLanguageInEra C.PlutusScriptV2 era + ) + => m C.TxIn +registerScriptStakingCredentialAsConwayCert = C.conwayEraOnwardsConstraints @era C.conwayBasedEra $ do + pp <- fmap C.unLedgerProtocolParameters queryProtocolParameters + txBody <- BuildTx.execBuildTxT $ do + -- Need this for Conway certificates or we'll be getting 'MissingScriptWitnessesUTXOW'. + BuildTx.addStakeScriptWitness scriptStakingCredential Scripts.v2StakingScript () + BuildTx.addConwayStakeCredentialRegistrationCertificate scriptStakingCredential (pp ^. Ledger.ppKeyDepositL) C.TxIn . C.getTxId . C.getTxBody <$> tryBalanceAndSubmit mempty Wallet.w1 txBody TrailingChange [] <*> pure (C.TxIx 0) -withdrawZero :: forall era m. (MonadIO m, MonadMockchain era m, MonadError (BalanceTxError era) m, MonadFail m, C.IsBabbageBasedEra era, C.HasScriptLanguageInEra C.PlutusScriptV2 era) => m () -withdrawZero = inBabbage @era $ do +withdrawZeroTrickWithShelleyCert :: forall era m. + ( MonadIO m + , MonadMockchain era m + , MonadError (BalanceTxError era) m + , MonadFail m + , C.IsConwayBasedEra era + , C.HasScriptLanguageInEra C.PlutusScriptV2 era + ) + => m () +withdrawZeroTrickWithShelleyCert = inBabbage @era $ do + void registerScriptStakingCredentialAsShelleyCert + + txBody <- execBuildTxT (BuildTx.addWithdrawZeroPlutusV2InTransaction Scripts.v2StakingScript ()) + txI <- C.TxIn . C.getTxId . C.getTxBody <$> tryBalanceAndSubmit mempty Wallet.w1 txBody TrailingChange [] <*> pure (C.TxIx 0) + singleUTxO txI >>= \case + Nothing -> fail "txI not found" + Just{} -> pure () + + unregisterTx <- BuildTx.execBuildTxT $ do + BuildTx.addStakeScriptWitness scriptStakingCredential Scripts.v2StakingScript () + BuildTx.addShelleyStakeCredentialUnregistrationCertificateInConway scriptStakingCredential + void $ tryBalanceAndSubmit mempty Wallet.w1 unregisterTx TrailingChange [] + +withdrawZeroTrickWithConwayCert :: forall era m. + ( MonadIO m + , MonadMockchain era m + , MonadError (BalanceTxError era) m + , MonadFail m + , C.IsConwayBasedEra era + , C.HasScriptLanguageInEra C.PlutusScriptV2 era + ) + => m () +withdrawZeroTrickWithConwayCert = C.conwayEraOnwardsConstraints @era C.conwayBasedEra $ do + void registerScriptStakingCredentialAsConwayCert + txBody <- execBuildTxT (BuildTx.addWithdrawZeroPlutusV2InTransaction Scripts.v2StakingScript ()) txI <- C.TxIn . C.getTxId . C.getTxBody <$> tryBalanceAndSubmit mempty Wallet.w1 txBody TrailingChange [] <*> pure (C.TxIx 0) singleUTxO txI >>= \case Nothing -> fail "txI not found" Just{} -> pure () + pp <- fmap C.unLedgerProtocolParameters queryProtocolParameters + unregisterTx <- BuildTx.execBuildTxT $ do + BuildTx.addStakeScriptWitness scriptStakingCredential Scripts.v2StakingScript () + BuildTx.addConwayStakeCredentialUnRegistrationCertificate scriptStakingCredential (pp ^. Ledger.ppKeyDepositL) + void $ tryBalanceAndSubmit mempty Wallet.w1 unregisterTx TrailingChange [] + matchingIndexMP :: forall m. (MonadMockchain C.ConwayEra m, MonadError (BalanceTxError C.ConwayEra) m, MonadFail m) => m () matchingIndexMP = do let sh = C.hashScript (C.PlutusScript C.PlutusScriptV3 Scripts.matchingIndexMPScript) @@ -408,9 +469,11 @@ queryStakeAddressesTest = do stakeCred = C.StakeCredentialByKey stakeHash + pp <- fmap C.unLedgerProtocolParameters queryProtocolParameters + let stakeCert = C.makeStakeAddressRegistrationCertificate - . C.StakeAddrRegistrationConway C.ConwayEraOnwardsConway 0 + . C.StakeAddrRegistrationConway C.ConwayEraOnwardsConway (pp ^. Ledger.ppKeyDepositL) $ stakeCred delegationCert = @@ -436,8 +499,8 @@ queryStakeAddressesTest = do when (length rewards /= 1) $ fail "Expected 1 reward" when (length delegations /= 1) $ fail "Expected 1 delegation" -withdrawalTest :: forall m. (MonadIO m, MonadMockchain C.ConwayEra m, MonadError (BalanceTxError C.ConwayEra) m, MonadFail m) => m () -withdrawalTest = do +stakeKeyWithdrawalTest :: forall m. (MonadIO m, MonadMockchain C.ConwayEra m, MonadError (BalanceTxError C.ConwayEra) m, MonadFail m) => m () +stakeKeyWithdrawalTest = do stakeKey <- C.generateSigningKey C.AsStakeKey let withdrawalAmount = 10_000_000 @@ -446,12 +509,14 @@ withdrawalTest = do stakeCred = C.StakeCredentialByKey stakeHash - delegationDrepCert = C.makeStakeAddressAndDRepDelegationCertificate - C.ConwayEraOnwardsConway - stakeCred - (Ledger.DelegVote Ledger.DRepAlwaysAbstain) - 0 - delegDrepCertTx = BuildTx.execBuildTx $ BuildTx.addCertificate delegationDrepCert + pp <- fmap C.unLedgerProtocolParameters queryProtocolParameters + let + delegDrepCertTx = + BuildTx.execBuildTx $ + BuildTx.addConwayStakeCredentialRegistrationAndDelegationCertificate + stakeCred + (Ledger.DelegVote Ledger.DRepAlwaysAbstain) + (pp ^. Ledger.ppKeyDepositL) -- activate stake and delegate to drep with a single certificate void $ tryBalanceAndSubmit mempty Wallet.w2 delegDrepCertTx TrailingChange [C.WitnessStakeKey stakeKey] diff --git a/src/devnet/config/devnet/genesis-shelley.json b/src/devnet/config/devnet/genesis-shelley.json index 1b207a58..33fe3bb4 100644 --- a/src/devnet/config/devnet/genesis-shelley.json +++ b/src/devnet/config/devnet/genesis-shelley.json @@ -28,7 +28,7 @@ "minPoolCost": 0, "minUTxOValue": 0, "nOpt": 100, - "poolDeposit": 0, + "poolDeposit": 500000000, "protocolVersion": { "major": 10, "minor": 0 diff --git a/src/devnet/lib/Convex/Devnet/Wallet.hs b/src/devnet/lib/Convex/Devnet/Wallet.hs index 928e7b0a..439ec66f 100644 --- a/src/devnet/lib/Convex/Devnet/Wallet.hs +++ b/src/devnet/lib/Convex/Devnet/Wallet.hs @@ -23,8 +23,6 @@ module Convex.Devnet.Wallet( runningNodeBlockchain ) where -import Cardano.Api (AddressInEra, - Quantity, Tx) import qualified Cardano.Api as C import Control.Monad (replicateM) import Control.Monad.IO.Class (MonadIO (..)) @@ -64,7 +62,7 @@ walletUtxos RunningNode{rnConnectInfo, rnNetworkId} wllt = {-| Send @n@ times the given amount of lovelace to the address -} -sendFaucetFundsTo :: forall era. C.IsBabbageBasedEra era => Tracer IO WalletLog -> RunningNode -> AddressInEra era -> Int -> Quantity -> IO (Tx era) +sendFaucetFundsTo :: forall era. C.IsBabbageBasedEra era => Tracer IO WalletLog -> RunningNode -> C.AddressInEra era -> Int -> C.Quantity -> IO (C.Tx era) sendFaucetFundsTo tracer node destination n amount = do fct <- faucet balanceAndSubmit tracer node fct (BuildTx.execBuildTx $ replicateM n (BuildTx.payToAddress destination (C.lovelaceToValue $ C.quantityToLovelace amount))) TrailingChange [] @@ -72,7 +70,7 @@ sendFaucetFundsTo tracer node destination n amount = do {-| Create a new wallet and send @n@ times the given amount of lovelace to it. Returns when the seed txn has been registered on the chain. -} -createSeededWallet :: forall era. C.IsBabbageBasedEra era => C.BabbageEraOnwards era -> Tracer IO WalletLog -> RunningNode -> Int -> Quantity -> IO Wallet +createSeededWallet :: forall era. C.IsBabbageBasedEra era => C.BabbageEraOnwards era -> Tracer IO WalletLog -> RunningNode -> Int -> C.Quantity -> IO Wallet createSeededWallet _babbageEraOnwards tracer node@RunningNode{rnNetworkId, rnConnectInfo} n amount = do wallet <- Wallet.generateWallet traceWith tracer (GeneratedWallet wallet) @@ -93,7 +91,7 @@ runningNodeBlockchain tracer RunningNode{rnConnectInfo} = {-| Balance and submit the transaction using the wallet's UTXOs -} -balanceAndSubmit :: forall era. C.IsBabbageBasedEra era => Tracer IO WalletLog -> RunningNode -> Wallet -> TxBuilder era -> ChangeOutputPosition -> [C.ShelleyWitnessSigningKey] -> IO (Tx era) +balanceAndSubmit :: forall era. C.IsBabbageBasedEra era => Tracer IO WalletLog -> RunningNode -> Wallet -> TxBuilder era -> ChangeOutputPosition -> [C.ShelleyWitnessSigningKey] -> IO (C.Tx era) balanceAndSubmit tracer node wallet tx changePosition keys = do n <- runningNodeBlockchain @era tracer node queryNetworkId let walletAddress = Wallet.addressInEra n wallet @@ -112,7 +110,7 @@ balanceAndSubmitReturn -> TxBuilder era -> ChangeOutputPosition -> [C.ShelleyWitnessSigningKey] - -> IO (Tx era) + -> IO (C.Tx era) balanceAndSubmitReturn tracer node wallet returnOutput tx changePosition keys = do utxos <- walletUtxos node wallet runningNodeBlockchain tracer node $ do diff --git a/src/mockchain/lib/Convex/MockChain/Defaults.hs b/src/mockchain/lib/Convex/MockChain/Defaults.hs index c3b8ebcd..761102bc 100644 --- a/src/mockchain/lib/Convex/MockChain/Defaults.hs +++ b/src/mockchain/lib/Convex/MockChain/Defaults.hs @@ -105,7 +105,9 @@ protocolParameters = & L.hkdMaxTxSizeL .~ 16_384 & L.hkdMinFeeAL .~ 44 & L.hkdMinFeeBL .~ 155_381 + & L.hkdKeyDepositL .~ 2_000_000 & L.hkdPoolDepositL .~ 500_000_000 + & L.hkdDRepDepositL .~ 500_000_000 & L.hkdCoinsPerUTxOByteL .~ L.CoinPerByte 4_310 & L.hkdPricesL .~ L.Prices { L.prMem = C.unsafeBoundedRational (577 % 10_000) From c18d8357c1b9a0eef042a1056504c4611e9d5883 Mon Sep 17 00:00:00 2001 From: Konstantinos Lambrou-Latreille Date: Tue, 19 Nov 2024 12:07:50 -0500 Subject: [PATCH 3/3] Add addStakeScriptWitnessRef --- src/base/lib/Convex/BuildTx.hs | 20 +++++++++++++++++++- 1 file changed, 19 insertions(+), 1 deletion(-) diff --git a/src/base/lib/Convex/BuildTx.hs b/src/base/lib/Convex/BuildTx.hs index e14c7389..1d6cdc33 100644 --- a/src/base/lib/Convex/BuildTx.hs +++ b/src/base/lib/Convex/BuildTx.hs @@ -90,6 +90,7 @@ module Convex.BuildTx( addConwayStakeCredentialUnRegistrationCertificate, addStakeWitness, addStakeScriptWitness, + addStakeScriptWitnessRef, addStakeWitnessWithTxBody, -- ** Minting and burning tokens @@ -350,7 +351,6 @@ addStakeWitness :: addStakeWitness credential witness = addBtx (over (L.txCertificates . L._TxCertificates . _2) ((:) (credential, witness))) --- mintPlutus :: forall redeemer lang era m. (Plutus.ToData redeemer, MonadBuildTx era m, C.HasScriptLanguageInEra lang era, C.IsAlonzoBasedEra era, C.IsPlutusScriptLanguage lang) => PlutusScript lang -> redeemer -> C.AssetName -> C.Quantity -> m () {-| Add a stake script witness to the transaction. -} addStakeScriptWitness :: @@ -369,6 +369,24 @@ addStakeScriptWitness credential script redeemer = do let witness = C.ScriptWitness C.ScriptWitnessForStakeAddr scriptWitness addBtx (over (L.txCertificates . L._TxCertificates . _2) ((:) (credential, witness))) +{-| Add a stake script reference witness to the transaction. +-} +addStakeScriptWitnessRef :: + ( MonadBuildTx era m + , Plutus.ToData redeemer + , C.IsShelleyBasedEra era + , C.HasScriptLanguageInEra lang era + ) + => C.StakeCredential + -> C.TxIn + -> C.PlutusScriptVersion lang + -> redeemer + -> m () +addStakeScriptWitnessRef credential txIn plutusScriptVersion redeemer = do + let scriptWitness = buildRefScriptWitness txIn plutusScriptVersion C.NoScriptDatumForStake redeemer + let witness = C.ScriptWitness C.ScriptWitnessForStakeAddr scriptWitness + addBtx (over (L.txCertificates . L._TxCertificates . _2) ((:) (credential, witness))) + {- | Like @addStakeWitness@ but uses a function that takes a @TxBody@ to build the witness. TODO Give an example of why this is useful. We should just remove it. -}