Modify extract* functions with more specific types and expose them for

testing

Author: Jimbo4350

cardano-api/src/Cardano/Api/Experimental/Plutus/Internal/ScriptWitness.hs

@@ -60,8 +60,8 @@ type ScriptRedeemer = HashableScriptData
 data PlutusScriptWitness (lang :: L.Language) (purpose :: PlutusScriptPurpose) era where
   PlutusScriptWitness
     :: L.SLanguage lang
-    -> (PlutusScriptOrReferenceInput lang era)
-    -> (PlutusScriptDatum lang purpose)
+    -> PlutusScriptOrReferenceInput lang era
+    -> PlutusScriptDatum lang purpose
     -> ScriptRedeemer
     -> ExecutionUnits
     -> PlutusScriptWitness lang purpose era

cardano-api/src/Cardano/Api/Experimental/Tx/Internal/Body.hs

@@ -25,21 +25,21 @@ extractAllIndexedPlutusScriptWitnesses
 extractAllIndexedPlutusScriptWitnesses era b = obtainCommonConstraints era $ do
   let sbe = convert era
       aeon = convert era
-      legacyTxInWits = extractWitnessableTxIns aeon b
-      legacyCertWits = extractWitnessableCertificates aeon b
-      legacyMintWits = extractWitnessableMints aeon b
+      legacyTxInWits = extractWitnessableTxIns aeon $ txIns b
+      legacyCertWits = extractWitnessableCertificates aeon $ txCertificates b
+      legacyMintWits = extractWitnessableMints aeon $ txMintValue b
       proposalWits
         :: [(Witnessable ProposalItem (ShelleyLedgerEra era), BuildTxWith BuildTx (Witness WitCtxStake era))] =
           caseShelleyToBabbageOrConwayEraOnwards
             (const [])
-            (`extractWitnessableProposals` b)
+            (`extractWitnessableProposals` txProposalProcedures b)
             sbe
-      legacyWithdrawalWits = extractWitnessableWithdrawals aeon b
+      legacyWithdrawalWits = extractWitnessableWithdrawals aeon $ txWithdrawals b
       legacyVoteWits
         :: [(Witnessable VoterItem (ShelleyLedgerEra era), BuildTxWith BuildTx (Witness WitCtxStake era))] =
           caseShelleyToBabbageOrConwayEraOnwards
             (const [])
-            (`extractWitnessableVotes` b)
+            (`extractWitnessableVotes` txVotingProcedures b)
             sbe
 
   txInWits <- legacyWitnessConversion aeon legacyTxInWits

cardano-api/src/Cardano/Api/Tx.hs

@@ -844,6 +844,13 @@ module Cardano.Api.Tx
   , fromShelleyMetadata
   , toShelleyMetadatum
   , fromShelleyMetadatum
+  -- Exported for testing
+  , extractWitnessableCertificates
+  , extractWitnessableMints
+  , extractWitnessableProposals
+  , extractWitnessableTxIns
+  , extractWitnessableVotes
+  , extractWitnessableWithdrawals
   -- Exporting for testing. Deprecate in the future.
   , legacyKeyWitnessEncode
 

cardano-api/src/Cardano/Api/Tx/Internal/Body.hs

@@ -2852,9 +2852,15 @@ collectTxBodyScriptWitnessRequirements
        (TxScriptWitnessRequirements (ShelleyLedgerEra era))
 collectTxBodyScriptWitnessRequirements
   aEon
-  bc@TxBodyContent
-    { txInsReference
+  TxBodyContent
+    { txIns
+    , txInsReference
     , txOuts
+    , txCertificates
+    , txMintValue
+    , txWithdrawals
+    , txVotingProcedures
+    , txProposalProcedures
     } =
     obtainAlonzoScriptPurposeConstraints aEon $ do
       let sbe = shelleyBasedEra @era
@@ -2867,22 +2873,22 @@ collectTxBodyScriptWitnessRequirements
       txInWits <-
         first TxBodyPlutusScriptDecodeError $
           legacyWitnessToScriptRequirements aEon $
-            extractWitnessableTxIns aEon bc
+            extractWitnessableTxIns aEon txIns
 
       txWithdrawalWits <-
         first TxBodyPlutusScriptDecodeError $
           legacyWitnessToScriptRequirements aEon $
-            extractWitnessableWithdrawals aEon bc
+            extractWitnessableWithdrawals aEon txWithdrawals
 
       txCertWits <-
         first TxBodyPlutusScriptDecodeError $
           legacyWitnessToScriptRequirements aEon $
-            extractWitnessableCertificates aEon bc
+            extractWitnessableCertificates aEon txCertificates
 
       txMintWits <-
         first TxBodyPlutusScriptDecodeError $
           legacyWitnessToScriptRequirements aEon $
-            extractWitnessableMints aEon bc
+            extractWitnessableMints aEon txMintValue
 
       txVotingWits <-
         caseShelleyToBabbageOrConwayEraOnwards
@@ -2892,7 +2898,7 @@ collectTxBodyScriptWitnessRequirements
           ( \eon ->
               first TxBodyPlutusScriptDecodeError $
                 legacyWitnessToScriptRequirements aEon $
-                  extractWitnessableVotes eon bc
+                  extractWitnessableVotes eon txVotingProcedures
           )
           sbe
       txProposalWits <-
@@ -2901,7 +2907,7 @@ collectTxBodyScriptWitnessRequirements
           ( \eon ->
               first TxBodyPlutusScriptDecodeError $
                 legacyWitnessToScriptRequirements aEon $
-                  extractWitnessableProposals eon bc
+                  extractWitnessableProposals eon txProposalProcedures
           )
           sbe
 
@@ -2946,17 +2952,17 @@ getDatums eon txInsRef txOutsFromTx = alonzoEraOnwardsConstraints eon $ do
 
 extractWitnessableTxIns
   :: AlonzoEraOnwards era
-  -> TxBodyContent BuildTx era
+  -> TxIns BuildTx era
   -> [(Witnessable TxInItem (ShelleyLedgerEra era), BuildTxWith BuildTx (Witness WitCtxTxIn era))]
-extractWitnessableTxIns aeon TxBodyContent{txIns} =
+extractWitnessableTxIns aeon txIns =
   alonzoEraOnwardsConstraints aeon $
     List.nub [(WitTxIn txin, wit) | (txin, wit) <- txIns]
 
 extractWitnessableWithdrawals
   :: AlonzoEraOnwards era
-  -> TxBodyContent BuildTx era
+  -> TxWithdrawals BuildTx era
   -> [(Witnessable WithdrawalItem (ShelleyLedgerEra era), BuildTxWith BuildTx (Witness WitCtxStake era))]
-extractWitnessableWithdrawals aeon TxBodyContent{txWithdrawals} =
+extractWitnessableWithdrawals aeon txWithdrawals =
   alonzoEraOnwardsConstraints aeon $
     List.nub
       [ (WitWithdrawal addr withAmt, wit)
@@ -2968,9 +2974,9 @@ extractWitnessableWithdrawals aeon TxBodyContent{txWithdrawals} =
 
 extractWitnessableCertificates
   :: AlonzoEraOnwards era
-  -> TxBodyContent BuildTx era
+  -> TxCertificates BuildTx era
   -> [(Witnessable CertItem (ShelleyLedgerEra era), BuildTxWith BuildTx (Witness WitCtxStake era))]
-extractWitnessableCertificates aeon TxBodyContent{txCertificates} =
+extractWitnessableCertificates aeon txCertificates =
   alonzoEraOnwardsConstraints aeon $
     List.nub
       [ ( WitTxCert (certificateToTxCert cert) stakeCred
@@ -2984,9 +2990,9 @@ extractWitnessableCertificates aeon TxBodyContent{txCertificates} =
 
 extractWitnessableMints
   :: AlonzoEraOnwards era
-  -> TxBodyContent BuildTx era
+  -> TxMintValue build era
   -> [(Witnessable MintItem (ShelleyLedgerEra era), BuildTxWith BuildTx (Witness WitCtxMint era))]
-extractWitnessableMints aeon TxBodyContent{txMintValue} =
+extractWitnessableMints aeon txMintValue =
   alonzoEraOnwardsConstraints aeon $
     List.nub
       [ (WitMint policyId policyAssets, BuildTxWith $ ScriptWitness ScriptWitnessForMinting wit)
@@ -2998,9 +3004,9 @@ extractWitnessableMints aeon TxBodyContent{txMintValue} =
 
 extractWitnessableVotes
   :: ConwayEraOnwards era
-  -> TxBodyContent BuildTx era
+  -> Maybe (Featured eon era (TxVotingProcedures BuildTx era))
   -> [(Witnessable VoterItem (ShelleyLedgerEra era), BuildTxWith BuildTx (Witness WitCtxStake era))]
-extractWitnessableVotes e@ConwayEraOnwardsConway TxBodyContent{txVotingProcedures} =
+extractWitnessableVotes e@ConwayEraOnwardsConway txVotingProcedures =
   List.nub
     [ (WitVote vote, BuildTxWith wit)
     | (vote, wit) <- getVotes e $ maybe TxVotingProceduresNone unFeatured txVotingProcedures
@@ -3021,9 +3027,10 @@ extractWitnessableVotes e@ConwayEraOnwardsConway TxBodyContent{txVotingProcedure
 
 extractWitnessableProposals
   :: ConwayEraOnwards era
-  -> TxBodyContent BuildTx era
+  -> Maybe
+       (Featured eon era (TxProposalProcedures BuildTx era))
   -> [(Witnessable ProposalItem (ShelleyLedgerEra era), BuildTxWith BuildTx (Witness WitCtxStake era))]
-extractWitnessableProposals e@ConwayEraOnwardsConway TxBodyContent{txProposalProcedures} =
+extractWitnessableProposals e@ConwayEraOnwardsConway txProposalProcedures =
   List.nub
     [ (WitProposal prop, BuildTxWith wit)
     | (Proposal prop, wit) <-