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

@@ -31,6 +31,7 @@ library
       Convex.BuildTx
       Convex.Class
       Convex.Constants
+      Convex.Eon
       Convex.MonadLog
       Convex.NodeQueries
       Convex.NodeQueries.Debug

src/base/lib/Convex/BuildTx.hs

@@ -44,7 +44,6 @@ module Convex.BuildTx(
   addInputWithTxBody,
   addMintWithTxBody,
   addWithdrawalWithTxBody,
-  addStakeWitnessWithTxBody,
   addReference,
   addCollateral,
   addAuxScript,
@@ -81,9 +80,14 @@ module Convex.BuildTx(
   addWithdrawZeroPlutusV2InTransaction,
   addWithdrawZeroPlutusV2Reference,
   addCertificate,
-  addStakeCredentialCertificate,
-  addStakeCredentialUnregCertificate,
+  addPreConwayStakeCredentialRegistrationCertificate,
+  addPreConwayStakeCredentialUnregistrationCertificate ,
+  addConwayStakeCredentialRegistrationCertificate,
+  addConwayStakeCredentialRegistrationAndDelegationCertificate,
+  addConwayStakeCredentialDeRegistrationCertificate,
   addStakeWitness,
+  addStakeScriptWitness,
+  addStakeWitnessWithTxBody,
 
   -- ** Minting and burning tokens
   mintPlutus,
@@ -111,8 +115,9 @@ import           Cardano.Api.Shelley            (Hash, HashableScriptData,
                                                  NetworkId, PaymentKey,
                                                  PlutusScript, PlutusScriptV2,
                                                  ScriptHash, WitCtxTxIn)
+import qualified Cardano.Api.Ledger             as Ledger
 import qualified Cardano.Api.Shelley            as C
-import qualified Cardano.Ledger.Shelley.TxCert  as TxCert
+import qualified Cardano.Ledger.Conway.TxCert   as ConwayTxCert (Delegatee (..))
 import           Control.Lens                   (_1, _2, at, mapped, over, set,
                                                  view, (&))
 import qualified Control.Lens                   as L
@@ -131,6 +136,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 +333,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 +379,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 +470,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 +498,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
@@ -631,20 +691,71 @@ 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 =
-  C.conwayEraOnwardsConstraints @era C.conwayBasedEra $
-  addCertificate $ C.ConwayCertificate C.conwayBasedEra $ TxCert.RegTxCert $ C.toShelleyStakeCredential stk
-
-addStakeCredentialUnregCertificate :: forall era m. C.IsConwayBasedEra era => MonadBuildTx era m => C.StakeCredential -> m ()
-addStakeCredentialUnregCertificate stk =
-  C.conwayEraOnwardsConstraints @era C.conwayBasedEra $
-  addCertificate $ C.ConwayCertificate C.conwayBasedEra $ TxCert.UnRegTxCert $ C.toShelleyStakeCredential stk
+{-| Add a 'C.StakeCredential' registration as a ShelleyRelatedCerticate to the transaction.
+-}
+addPreConwayStakeCredentialRegistrationCertificate :: forall era m.
+  ( IsShelleyToBabbageEra era
+  , MonadBuildTx era m
+  )
+  => C.StakeCredential
+  -> m ()
+addPreConwayStakeCredentialRegistrationCertificate stakeCred = do
+  let cert = C.makeStakeAddressRegistrationCertificate $ C.StakeAddrRegistrationPreConway shelleyToBabbageEra stakeCred
+  addCertificate cert
+
+{-| Add a 'C.StakeCredential' deregistration as a ShelleyRelatedCerticate to the transaction.
+-}
+addPreConwayStakeCredentialUnregistrationCertificate :: forall era m.
+  ( IsShelleyToBabbageEra era
+  , MonadBuildTx era m
+  )
+  => C.StakeCredential
+  -> m ()
+addPreConwayStakeCredentialUnregistrationCertificate stakeCred = do
+  let cert = C.makeStakeAddressUnregistrationCertificate $ C.StakeAddrRegistrationPreConway shelleyToBabbageEra stakeCred
+  addCertificate cert
+
+{-| 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
+  C.conwayEraOnwardsConstraints @era C.conwayBasedEra $ do
+    addCertificate $ C.makeStakeAddressRegistrationCertificate $ C.StakeAddrRegistrationConway C.conwayBasedEra deposit stakeCred
+    -- addCertificate $ C.ConwayCertificate C.conwayBasedEra $ TxCert.RegTxCert $ C.toShelleyStakeCredential stakeCred
+
+{-| 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.
+-}
+addConwayStakeCredentialDeRegistrationCertificate :: 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 ()
+addConwayStakeCredentialDeRegistrationCertificate 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)))

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

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,

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