Fix review remarks

IntersectMBO · Dec 30, 2024 · 3f14ab0 · 3f14ab0
1 parent cba75e6
commit 3f14ab0
Show file tree

Hide file tree

Showing 3 changed files with 84 additions and 59 deletions.
diff --git a/cardano-api/internal/Cardano/Api/Fees.hs b/cardano-api/internal/Cardano/Api/Fees.hs
@@ -1450,12 +1450,12 @@ substituteExecutionUnits
               redeemer
               exunits
 
-    adjustWitness
+    adjustScriptWitness
       :: (ScriptWitness witctx era -> Either (TxBodyErrorAutoBalance era) (ScriptWitness witctx era))
       -> Witness witctx era
       -> Either (TxBodyErrorAutoBalance era) (Witness witctx era)
-    adjustWitness _ (KeyWitness ctx) = Right $ KeyWitness ctx
-    adjustWitness g (ScriptWitness ctx witness') = ScriptWitness ctx <$> g witness'
+    adjustScriptWitness _ (KeyWitness ctx) = Right $ KeyWitness ctx
+    adjustScriptWitness g (ScriptWitness ctx witness') = ScriptWitness ctx <$> g witness'
 
     mapScriptWitnessesTxIns
       :: [(TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn era))]
@@ -1468,8 +1468,8 @@ substituteExecutionUnits
                ]
           mappedScriptWitnesses =
             [ (txin, BuildTxWith <$> wit')
-            | (ix, txin, wit) <- txInsToIndexed txins
-            , let wit' = adjustWitness (substituteExecUnits ix) wit
+            | (ix, txin, wit) <- indexTxIns txins
+            , let wit' = adjustScriptWitness (substituteExecUnits ix) wit
             ]
        in traverse
             (\(txIn, eWitness) -> (txIn,) <$> eWitness)
@@ -1488,8 +1488,8 @@ substituteExecutionUnits
                ]
           mappedWithdrawals =
             [ (addr, withdrawal, BuildTxWith <$> mappedWitness)
-            | (ix, addr, withdrawal, wit) <- txWithdrawalsToIndexed txWithdrawals'
-            , let mappedWitness = adjustWitness (substituteExecUnits ix) wit
+            | (ix, addr, withdrawal, wit) <- indexTxWithdrawals txWithdrawals'
+            , let mappedWitness = adjustScriptWitness (substituteExecUnits ix) wit
             ]
        in TxWithdrawals supported
             <$> traverse
@@ -1505,8 +1505,8 @@ substituteExecutionUnits
             :: [(StakeCredential, Either (TxBodyErrorAutoBalance era) (Witness WitCtxStake era))]
           mappedScriptWitnesses =
             [ (stakeCred, witness')
-            | (ix, _, stakeCred, witness) <- txCertificatesToIndexed txCertificates'
-            , let witness' = adjustWitness (substituteExecUnits ix) witness
+            | (ix, _, stakeCred, witness) <- indexTxCertificates txCertificates'
+            , let witness' = adjustScriptWitness (substituteExecUnits ix) witness
             ]
        in TxCertificates supported certs . BuildTxWith
             <$> traverse
@@ -1524,7 +1524,7 @@ substituteExecutionUnits
     mapScriptWitnessesVotes (Just (Featured era txVotingProcedures'@(TxVotingProcedures vProcedures (BuildTxWith _)))) = do
       let eSubstitutedExecutionUnits =
             [ (vote, updatedWitness)
-            | (ix, vote, witness) <- txVotingProceduresToIndexed txVotingProcedures'
+            | (ix, vote, witness) <- indexTxVotingProcedures txVotingProcedures'
             , let updatedWitness = substituteExecUnits ix witness
             ]
 
@@ -1545,7 +1545,7 @@ substituteExecutionUnits
     mapScriptWitnessesProposals (Just (Featured era txpp@(TxProposalProcedures osetProposalProcedures (BuildTxWith _)))) = do
       let eSubstitutedExecutionUnits =
             [ (proposal, updatedWitness)
-            | (ix, proposal, scriptWitness) <- txProposalProceduresToIndexed txpp
+            | (ix, proposal, scriptWitness) <- indexTxProposalProcedures txpp
             , let updatedWitness = substituteExecUnits ix scriptWitness
             ]
 
@@ -1565,7 +1565,7 @@ substituteExecutionUnits
     mapScriptWitnessesMinting txMintValue'@(TxMintValue w _) = do
       let mappedScriptWitnesses =
             [ (policyId, pure . (assetName',quantity,) <$> substitutedWitness)
-            | (ix, policyId, assetName', quantity, BuildTxWith witness) <- txMintValueToIndexed txMintValue'
+            | (ix, policyId, assetName', quantity, BuildTxWith witness) <- indexTxMintValue txMintValue'
             , let substitutedWitness = BuildTxWith <$> substituteExecUnits ix witness
             ]
       final <- Map.fromListWith (<>) <$> traverseScriptWitnesses mappedScriptWitnesses

diff --git a/cardano-api/internal/Cardano/Api/Tx/Body.hs b/cardano-api/internal/Cardano/Api/Tx/Body.hs
@@ -101,7 +101,7 @@ module Cardano.Api.Tx.Body
     -- * Transaction inputs
   , TxIn (..)
   , TxIns
-  , txInsToIndexed
+  , indexTxIns
   , TxIx (..)
   , genesisUTxOPseudoTxIn
   , getReferenceInputsSizeForTxIds
@@ -133,19 +133,19 @@ module Cardano.Api.Tx.Body
   , TxAuxScripts (..)
   , TxExtraKeyWitnesses (..)
   , TxWithdrawals (..)
-  , txWithdrawalsToIndexed
+  , indexTxWithdrawals
   , TxCertificates (..)
-  , txCertificatesToIndexed
+  , indexTxCertificates
   , TxUpdateProposal (..)
   , TxMintValue (..)
   , txMintValueToValue
-  , txMintValueToIndexed
+  , indexTxMintValue
   , TxVotingProcedures (..)
   , mkTxVotingProcedures
-  , txVotingProceduresToIndexed
+  , indexTxVotingProcedures
   , TxProposalProcedures (..)
   , mkTxProposalProcedures
-  , txProposalProceduresToIndexed
+  , indexTxProposalProcedures
   , convProposalProcedures
 
     -- ** Building vs viewing transactions
@@ -317,7 +317,8 @@ import           Data.String
 import           Data.Text (Text)
 import qualified Data.Text as Text
 import qualified Data.Text.Encoding as Text
-import           Data.Type.Equality (TestEquality (..), (:~:) (Refl))
+import           Data.Type.Equality
+import           Data.Typeable
 import           Data.Word (Word16, Word32, Word64)
 import           GHC.Exts (IsList (..))
 import           GHC.Stack
@@ -939,10 +940,10 @@ type TxIns build era = [(TxIn, BuildTxWith build (Witness WitCtxTxIn era))]
 
 -- | Index transaction inputs ordered by TxIn
 -- See section 4.1 of https://github.com/intersectmbo/cardano-ledger/releases/latest/download/alonzo-ledger.pdf
-txInsToIndexed
+indexTxIns
   :: TxIns BuildTx era
   -> [(ScriptWitnessIndex, TxIn, Witness WitCtxTxIn era)]
-txInsToIndexed txins =
+indexTxIns txins =
   [ (ScriptWitnessIndexTxIn ix, txIn, witness)
   | (ix, (txIn, BuildTxWith witness)) <- zip [0 ..] $ orderTxIns txins
   ]
@@ -1259,11 +1260,11 @@ deriving instance Show (TxWithdrawals build era)
 
 -- | Index the withdrawals with witnesses in the order of stake addresses.
 -- See section 4.1 of https://github.com/intersectmbo/cardano-ledger/releases/latest/download/alonzo-ledger.pdf
-txWithdrawalsToIndexed
+indexTxWithdrawals
   :: TxWithdrawals BuildTx era
   -> [(ScriptWitnessIndex, StakeAddress, L.Coin, Witness WitCtxStake era)]
-txWithdrawalsToIndexed TxWithdrawalsNone = []
-txWithdrawalsToIndexed (TxWithdrawals _ withdrawals) =
+indexTxWithdrawals TxWithdrawalsNone = []
+indexTxWithdrawals (TxWithdrawals _ withdrawals) =
   [ (ScriptWitnessIndexWithdrawal ix, addr, coin, witness)
   | (ix, (addr, coin, BuildTxWith witness)) <- zip [0 ..] (orderStakeAddrs withdrawals)
   ]
@@ -1292,19 +1293,21 @@ deriving instance Eq (TxCertificates build era)
 
 deriving instance Show (TxCertificates build era)
 
--- | Index certificates with witnesses by the order they appear in the list (in the transaction). If there
--- are multiple witnesses for the credential, the last one is returned.
+-- | Index certificates with witnesses by the order they appear in the list (in the transaction). If there are multiple witnesses for the same stake credential, they will be present multiple times with the same index.
+-- are multiple witnesses for the credential, there will be multiple entries for
 -- See section 4.1 of https://github.com/intersectmbo/cardano-ledger/releases/latest/download/alonzo-ledger.pdf
-txCertificatesToIndexed
+indexTxCertificates
   :: TxCertificates BuildTx era
   -> [(ScriptWitnessIndex, Certificate era, StakeCredential, Witness WitCtxStake era)]
-txCertificatesToIndexed TxCertificatesNone = []
-txCertificatesToIndexed (TxCertificates _ certs (BuildTxWith witnesses)) =
+indexTxCertificates TxCertificatesNone = []
+indexTxCertificates (TxCertificates _ certs (BuildTxWith witnesses)) =
   [ (ScriptWitnessIndexCertificate ix, cert, stakeCred, wit)
   | (ix, cert) <- zip [0 ..] certs
   , stakeCred <- maybeToList (selectStakeCredentialWitness cert)
-  , wit <- maybeToList $ List.lookup stakeCred witnesses
+  , wit <- findAll stakeCred witnesses
   ]
+ where
+  findAll needle = map snd . filter ((==) needle . fst)
 
 -- ----------------------------------------------------------------------------
 -- Transaction update proposal (era-dependent)
@@ -1351,7 +1354,7 @@ txMintValueToValue (TxMintValue _ policiesWithAssets) =
 
 -- | Index the assets with witnesses in the order of policy ids.
 -- See section 4.1 of https://github.com/intersectmbo/cardano-ledger/releases/latest/download/alonzo-ledger.pdf
-txMintValueToIndexed
+indexTxMintValue
   :: TxMintValue build era
   -> [ ( ScriptWitnessIndex
        , PolicyId
@@ -1360,8 +1363,8 @@ txMintValueToIndexed
        , BuildTxWith build (ScriptWitness WitCtxMint era)
        )
      ]
-txMintValueToIndexed TxMintNone = []
-txMintValueToIndexed (TxMintValue _ policiesWithAssets) =
+indexTxMintValue TxMintNone = []
+indexTxMintValue (TxMintValue _ policiesWithAssets) =
   [ (ScriptWitnessIndexMint ix, policyId', assetName', quantity, witness)
   | (ix, (policyId', assets)) <- zip [0 ..] $ toList policiesWithAssets
   , (assetName', quantity, witness) <- assets
@@ -1419,15 +1422,15 @@ mkTxVotingProcedures votingProcedures = do
     listToMaybe $ Map.keys m
 
 -- | Index voting procedures by the order of the votes ('Ord').
-txVotingProceduresToIndexed
+indexTxVotingProcedures
   :: TxVotingProcedures BuildTx era
   -> [ ( ScriptWitnessIndex
        , L.Voter (Ledger.EraCrypto (ShelleyLedgerEra era))
        , ScriptWitness WitCtxStake era
        )
      ]
-txVotingProceduresToIndexed TxVotingProceduresNone = []
-txVotingProceduresToIndexed (TxVotingProcedures vProcedures (BuildTxWith sWitMap)) =
+indexTxVotingProcedures TxVotingProceduresNone = []
+indexTxVotingProcedures (TxVotingProcedures vProcedures (BuildTxWith sWitMap)) =
   [ (ScriptWitnessIndexVoting $ fromIntegral index, vote, scriptWitness)
   | let allVoteMap = L.unVotingProcedures vProcedures
   , (vote, scriptWitness) <- toList sWitMap
@@ -1476,11 +1479,11 @@ mkTxProposalProcedures proposalsWithWitnessesList = do
     (DList.snoc ps p, DList.snoc pws (p, w)) -- add a proposal both to the list and to the witnessed list
 
 -- | Index proposal procedures by their order ('Ord').
-txProposalProceduresToIndexed
+indexTxProposalProcedures
   :: TxProposalProcedures BuildTx era
   -> [(ScriptWitnessIndex, L.ProposalProcedure (ShelleyLedgerEra era), ScriptWitness WitCtxStake era)]
-txProposalProceduresToIndexed TxProposalProceduresNone = []
-txProposalProceduresToIndexed txpp@(TxProposalProcedures _ (BuildTxWith witnesses)) = do
+indexTxProposalProcedures TxProposalProceduresNone = []
+indexTxProposalProcedures txpp@(TxProposalProcedures _ (BuildTxWith witnesses)) = do
   let allProposalsList = toList $ convProposalProcedures txpp
   [ (ScriptWitnessIndexProposing $ fromIntegral ix, proposal, scriptWitness)
     | (proposal, scriptWitness) <- toList witnesses
@@ -3389,10 +3392,26 @@ toShelleyTxOutAny _ = \case
 -- | A 'ScriptWitness' in any 'WitCtx'. This lets us handle heterogeneous
 -- collections of script witnesses from multiple contexts.
 data AnyScriptWitness era where
-  AnyScriptWitness :: ScriptWitness witctx era -> AnyScriptWitness era
+  AnyScriptWitness
+    :: Typeable witctx
+    => ScriptWitness witctx era
+    -> AnyScriptWitness era
 
 deriving instance Show (AnyScriptWitness era)
 
+instance Eq (AnyScriptWitness era) where
+  AnyScriptWitness sw1 == AnyScriptWitness sw2 =
+    case eqsw sw1 sw2 of
+      Just Refl -> sw1 == sw2
+      Nothing -> False
+   where
+    eqsw
+      :: (Typeable w1, Typeable w2)
+      => ScriptWitness w1 era
+      -> ScriptWitness w2 era
+      -> Maybe (w1 :~: w2)
+    eqsw _ _ = eqT
+
 -- | Identify the location of a 'ScriptWitness' within the context of a
 -- 'TxBody'. These are indexes of the objects within the transaction that
 -- need or can use script witnesses: inputs, minted assets, withdrawals and
@@ -3561,54 +3580,60 @@ collectTxBodyScriptWitnesses
       :: [(TxIn, BuildTxWith BuildTx (Witness WitCtxTxIn era))]
       -> [(ScriptWitnessIndex, AnyScriptWitness era)]
     scriptWitnessesTxIns txIns' =
-      [ (ix, AnyScriptWitness witness)
-      | (ix, _, ScriptWitness _ witness) <- txInsToIndexed txIns'
-      ]
+      List.nub
+        [ (ix, AnyScriptWitness witness)
+        | (ix, _, ScriptWitness _ witness) <- indexTxIns txIns'
+        ]
 
     scriptWitnessesWithdrawals
       :: TxWithdrawals BuildTx era
       -> [(ScriptWitnessIndex, AnyScriptWitness era)]
     scriptWitnessesWithdrawals TxWithdrawalsNone = []
     scriptWitnessesWithdrawals txw =
-      [ (ix, AnyScriptWitness witness)
-      | (ix, _, _, ScriptWitness _ witness) <- txWithdrawalsToIndexed txw
-      ]
+      List.nub
+        [ (ix, AnyScriptWitness witness)
+        | (ix, _, _, ScriptWitness _ witness) <- indexTxWithdrawals txw
+        ]
 
     scriptWitnessesCertificates
       :: TxCertificates BuildTx era
       -> [(ScriptWitnessIndex, AnyScriptWitness era)]
     scriptWitnessesCertificates TxCertificatesNone = []
     scriptWitnessesCertificates txc =
-      [ (ix, AnyScriptWitness witness)
-      | (ix, _, _, ScriptWitness _ witness) <- txCertificatesToIndexed txc
-      ]
+      List.nub
+        [ (ix, AnyScriptWitness witness)
+        | (ix, _, _, ScriptWitness _ witness) <- indexTxCertificates txc
+        ]
 
     scriptWitnessesMinting
       :: TxMintValue BuildTx era
       -> [(ScriptWitnessIndex, AnyScriptWitness era)]
     scriptWitnessesMinting TxMintNone = []
     scriptWitnessesMinting txMintValue' =
-      [ (ix, AnyScriptWitness witness)
-      | (ix, _, _, _, BuildTxWith witness) <- txMintValueToIndexed txMintValue'
-      ]
+      List.nub
+        [ (ix, AnyScriptWitness witness)
+        | (ix, _, _, _, BuildTxWith witness) <- indexTxMintValue txMintValue'
+        ]
 
     scriptWitnessesVoting
       :: TxVotingProcedures BuildTx era
       -> [(ScriptWitnessIndex, AnyScriptWitness era)]
     scriptWitnessesVoting TxVotingProceduresNone = []
     scriptWitnessesVoting txv =
-      [ (ix, AnyScriptWitness witness)
-      | (ix, _, witness) <- txVotingProceduresToIndexed txv
-      ]
+      List.nub
+        [ (ix, AnyScriptWitness witness)
+        | (ix, _, witness) <- indexTxVotingProcedures txv
+        ]
 
 scriptWitnessesProposing
   :: TxProposalProcedures BuildTx era
   -> [(ScriptWitnessIndex, AnyScriptWitness era)]
 scriptWitnessesProposing TxProposalProceduresNone = []
 scriptWitnessesProposing txp =
-  [ (ix, AnyScriptWitness witness)
-  | (ix, _, witness) <- txProposalProceduresToIndexed txp
-  ]
+  List.nub
+    [ (ix, AnyScriptWitness witness)
+    | (ix, _, witness) <- indexTxProposalProcedures txp
+    ]
 
 -- TODO: Investigate if we need
 toShelleyWithdrawal :: [(StakeAddress, L.Coin, a)] -> L.Withdrawals StandardCrypto

diff --git a/cardano-api/src/Cardano/Api.hs b/cardano-api/src/Cardano/Api.hs
@@ -394,7 +394,7 @@ module Cardano.Api
   , TxUpdateProposal (..)
   , TxMintValue (..)
   , txMintValueToValue
-  , txMintValueToIndexed
+  , indexTxMintValue
   , TxVotingProcedures (..)
   , mkTxVotingProcedures
   , TxProposalProcedures (..)