Add transaction building functions for correctly adding registration deregistration and delegation certificates in Conway era.

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,18 @@ module Convex.BuildTx(
   addWithdrawZeroPlutusV2InTransaction,
   addWithdrawZeroPlutusV2Reference,
   addCertificate,
-  addStakeCredentialCertificate,
-  addStakeCredentialUnregCertificate,
+  addShelleyStakeCredentialRegistrationCertificatePreConway,
+  addShelleyStakeCredentialUnregistrationCertificatePreConway,
+  addShelleyStakeCredentialRegistrationCertificateInConway,
+  addShelleyStakeCredentialUnregistrationCertificateInConway,
+  addConwayStakeCredentialRegistrationCertificate,
+  addConwayStakeCredentialDelegationCertificate,
+  addConwayStakeCredentialRegistrationAndDelegationCertificate,
+  addConwayStakeCredentialUnRegistrationCertificate,
   addStakeWitness,
+  addStakeScriptWitness,
+  addStakeScriptWitnessRef,
+  addStakeWitnessWithTxBody,
 
   -- ** Minting and burning tokens
   mintPlutus,
@@ -107,11 +115,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 +141,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 +338,57 @@ 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)))
+
+{-| 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)))
+
+{-| 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.
 -}
 addStakeWitnessWithTxBody :: (MonadBuildTx era m, C.IsShelleyBasedEra era) => C.StakeCredential -> (TxBody era -> C.Witness C.WitCtxStake era) -> m ()
 addStakeWitnessWithTxBody credential buildWitness =
@@ -340,7 +401,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 +492,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 +520,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 +691,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 +720,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)))

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/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