Merge pull request #456 from IntersectMBO/jordan/implement-getScriptC…

…redential Enable deposit return scripts and constitutional scripts
IntersectMBO · Feb 23, 2024 · 68e4956 · 68e4956
2 parents 71eb17f + 83c47ea
commit 68e4956
Show file tree

Hide file tree

Showing 2 changed files with 26 additions and 33 deletions.
diff --git a/cardano-api/internal/Cardano/Api/Certificate.hs b/cardano-api/internal/Cardano/Api/Certificate.hs
@@ -85,12 +85,15 @@ import           Cardano.Api.Keys.Praos
 import           Cardano.Api.Keys.Shelley
 import           Cardano.Api.ReexposeLedger (EraCrypto, StandardCrypto)
 import qualified Cardano.Api.ReexposeLedger as Ledger
+import           Cardano.Api.Script
 import           Cardano.Api.SerialiseCBOR
 import           Cardano.Api.SerialiseTextEnvelope
 import           Cardano.Api.StakePoolMetadata
 import           Cardano.Api.Utils (noInlineMaybeToStrictMaybe)
 import           Cardano.Api.Value
 
+import qualified Cardano.Ledger.Keys as Ledger
+
 import           Data.ByteString (ByteString)
 import qualified Data.ByteString as BS
 import qualified Data.Foldable as Foldable
@@ -487,40 +490,27 @@ makeDrepUpdateCertificate (DRepUpdateRequirements conwayOnwards vcred) mAnchor =
 -- Helper functions
 --
 
+getTxCertWitness
+  :: ShelleyBasedEra era
+  -> Ledger.TxCert (ShelleyLedgerEra era)
+  -> Maybe StakeCredential
+getTxCertWitness sbe ledgerCert = shelleyBasedEraConstraints sbe $
+  case Ledger.getVKeyWitnessTxCert ledgerCert of
+    Just keyHash -> Just $ StakeCredentialByKey $ StakeKeyHash $ Ledger.coerceKeyRole keyHash
+    Nothing ->
+      StakeCredentialByScript . fromShelleyScriptHash
+        <$> Ledger.getScriptWitnessTxCert ledgerCert
+
 -- | Get the stake credential witness for a certificate that requires it.
 -- Only stake address deregistration and delegation requires witnessing (witness can be script or key).
 selectStakeCredentialWitness
   :: Certificate era
   -> Maybe StakeCredential
-selectStakeCredentialWitness = fmap fromShelleyStakeCredential . \case
+selectStakeCredentialWitness = \case
   ShelleyRelatedCertificate stbEra shelleyCert -> shelleyToBabbageEraConstraints stbEra $
-    case shelleyCert of
-      Ledger.RegTxCert _               -> Nothing -- contains stake cred
-      Ledger.UnRegTxCert sCred         -> Just sCred
-      Ledger.DelegStakeTxCert sCred _  -> Just sCred
-      -- StakePool is always controlled by key, i.e. it is never a script. In other words,
-      -- @Credential StakePool@ cannot exist, because @ScriptHashObj@ constructor can't be used for that type.
-      Ledger.RegPoolTxCert _           -> Nothing -- contains StakePool key which cannot be a credential
-      Ledger.RetirePoolTxCert _ _      -> Nothing -- contains StakePool key which cannot be a credential
-      Ledger.MirTxCert _               -> Nothing
-      Ledger.GenesisDelegTxCert{}      -> Nothing
-
+    getTxCertWitness (shelleyToBabbageEraToShelleyBasedEra stbEra) shelleyCert
   ConwayCertificate cEra conwayCert -> conwayEraOnwardsConstraints cEra $
-    case conwayCert of
-      Ledger.RegPoolTxCert _                 -> Nothing -- contains StakePool key which cannot be a credential
-      Ledger.RetirePoolTxCert _ _            -> Nothing -- contains StakePool key which cannot be a credential
-      Ledger.RegTxCert{}                     -> Nothing -- contains stake cred
-      Ledger.UnRegTxCert sCred               -> Just sCred
-      Ledger.RegDepositTxCert{}              -> Nothing -- contains stake cred
-      Ledger.UnRegDepositTxCert sCred _      -> Just sCred
-      Ledger.DelegTxCert sCred _             -> Just sCred
-      Ledger.RegDepositDelegTxCert sCred _ _ -> Just sCred
-      Ledger.AuthCommitteeHotKeyTxCert{}     -> Nothing
-      Ledger.ResignCommitteeColdTxCert _ _   -> Nothing
-      Ledger.RegDRepTxCert{}                 -> Nothing
-      Ledger.UnRegDRepTxCert{}               -> Nothing
-      Ledger.UpdateDRepTxCert{}              -> Nothing
-
+    getTxCertWitness (conwayEraOnwardsToShelleyBasedEra cEra) conwayCert
 
 filterUnRegCreds
   :: Certificate era -> Maybe StakeCredential

diff --git a/cardano-api/internal/Cardano/Api/Governance/Actions/ProposalProcedure.hs b/cardano-api/internal/Cardano/Api/Governance/Actions/ProposalProcedure.hs
@@ -51,6 +51,7 @@ data GovernanceAction era
   | ProposeNewConstitution
       (StrictMaybe (Ledger.GovPurposeId Ledger.ConstitutionPurpose (ShelleyLedgerEra era)))
       (Ledger.Anchor StandardCrypto)
+      (StrictMaybe (Shelley.ScriptHash StandardCrypto))
   | ProposeNewCommittee
       (StrictMaybe (Ledger.GovPurposeId Ledger.CommitteePurpose (ShelleyLedgerEra era)))
       [Hash CommitteeColdKey] -- ^ Old constitutional committee
@@ -76,10 +77,10 @@ toGovernanceAction sbe =
   shelleyBasedEraConstraints sbe $ \case
     MotionOfNoConfidence prevGovId ->
       Gov.NoConfidence prevGovId
-    ProposeNewConstitution prevGovAction anchor ->
+    ProposeNewConstitution prevGovAction anchor mConstitutionScriptHash ->
       Gov.NewConstitution prevGovAction Gov.Constitution
         { Gov.constitutionAnchor = anchor
-        , Gov.constitutionScript = SNothing   -- TODO: Conway era
+        , Gov.constitutionScript = mConstitutionScriptHash
         }
     ProposeNewCommittee prevGovId oldCommitteeMembers newCommitteeMembers quor ->
       Gov.UpdateCommittee
@@ -109,7 +110,9 @@ fromGovernanceAction = \case
   Gov.NoConfidence prevGovId ->
     MotionOfNoConfidence prevGovId
   Gov.NewConstitution prevGovId constitution ->
-    ProposeNewConstitution prevGovId $ Gov.constitutionAnchor constitution
+    ProposeNewConstitution prevGovId
+      (Gov.constitutionAnchor constitution)
+      (Gov.constitutionScript constitution)
   Gov.ParameterChange prevGovId pparams govPolicy ->
     UpdatePParams prevGovId pparams govPolicy
   Gov.HardForkInitiation prevGovId pVer ->
@@ -160,15 +163,15 @@ createProposalProcedure
   :: ShelleyBasedEra era
   -> Network
   -> Lovelace -- ^ Deposit
-  -> Hash StakeKey -- ^ Return address
+  -> StakeCredential -- ^ Credential to return the deposit to.
   -> GovernanceAction era
   -> Ledger.Anchor StandardCrypto
   -> Proposal era
-createProposalProcedure sbe nw dep (StakeKeyHash retAddrh) govAct anchor =
+createProposalProcedure sbe nw dep cred govAct anchor =
   shelleyBasedEraConstraints sbe $
     Proposal Gov.ProposalProcedure
       { Gov.pProcDeposit = toShelleyLovelace dep
-      , Gov.pProcReturnAddr = L.RewardAcnt nw (L.KeyHashObj retAddrh)
+      , Gov.pProcReturnAddr = L.RewardAcnt nw $ toShelleyStakeCredential cred
       , Gov.pProcGovAction = toGovernanceAction sbe govAct
       , Gov.pProcAnchor = anchor
       }