cleanup 2

IntersectMBO · Jan 23, 2025 · 9b2bcb4 · 9b2bcb4
1 parent 3a27ebc
commit 9b2bcb4
Show file tree

Hide file tree

Showing 4 changed files with 50 additions and 68 deletions.
diff --git a/cardano-api/internal/Cardano/Api/Fees.hs b/cardano-api/internal/Cardano/Api/Fees.hs
@@ -97,10 +97,8 @@ import           Data.Ratio
 import           Data.Set (Set)
 import qualified Data.Set as Set
 import           Data.Text (Text)
-import qualified Data.Text.Lazy as T
 import           GHC.Exts (IsList (..))
 import           Lens.Micro ((.~), (^.))
-import           Text.Pretty.Simple (pShow)
 
 -- | Type synonym for logs returned by the ledger's @evalTxExUnitsWithLogs@ function.
 -- for scripts in transactions.
@@ -479,10 +477,7 @@ estimateTransactionKeyWitnessCount
         + case txCertificates of
           TxCertificates _ credWits ->
             length
-              [ ()
-              | (_, BuildTxWith (Just (_, witnesses))) <- toList credWits
-              , KeyWitness{} <- witnesses
-              ]
+              [() | (_, BuildTxWith (Just (_, KeyWitness{}))) <- toList credWits]
           _ -> 0
         + case txUpdateProposal of
           TxUpdateProposal _ (UpdateProposal updatePerGenesisKey _) ->
@@ -1506,26 +1501,24 @@ substituteExecutionUnits
     mapScriptWitnessesCertificates txCertificates'@(TxCertificates supported _) = do
       let mappedScriptWitnesses
             :: [ ( Certificate era
-                 , ( StakeCredential
-                   , [ Either
-                        (TxBodyErrorAutoBalance era)
-                        (Witness WitCtxStake era)
-                     ]
-                   )
+                 , Either
+                    (TxBodyErrorAutoBalance era)
+                    ( BuildTxWith
+                        BuildTx
+                        ( Maybe
+                            ( StakeCredential
+                            , Witness WitCtxStake era
+                            )
+                        )
+                    )
                  )
                ]
           mappedScriptWitnesses =
-            [ (cert, (stakeCred, eWitnesses'))
-            | (ix, cert, stakeCred, witnesses) <- indexTxCertificates txCertificates'
-            , let eWitnesses' = adjustScriptWitness (substituteExecUnits ix) <$> witnesses
+            [ (cert, BuildTxWith . Just . (stakeCred,) <$> eWitness')
+            | (ix, cert, stakeCred, witness) <- indexTxCertificates txCertificates'
+            , let eWitness' = adjustScriptWitness (substituteExecUnits ix) witness
             ]
-       in TxCertificates supported . fromList
-            <$> traverse
-              ( \(cert, (sCred, eWitnesses)) -> do
-                  wits <- sequenceA eWitnesses
-                  pure (cert, BuildTxWith $ Just (sCred, wits))
-              )
-              mappedScriptWitnesses
+      TxCertificates supported . fromList <$> traverseScriptWitnesses mappedScriptWitnesses
 
     mapScriptWitnessesVotes
       :: Maybe (Featured ConwayEraOnwards era (TxVotingProcedures build era))

diff --git a/cardano-api/internal/Cardano/Api/Tx/Body.hs b/cardano-api/internal/Cardano/Api/Tx/Body.hs
@@ -136,6 +136,7 @@ module Cardano.Api.Tx.Body
   , TxWithdrawals (..)
   , indexTxWithdrawals
   , TxCertificates (..)
+  , mkTxCertificates
   , indexTxCertificates
   , TxUpdateProposal (..)
   , TxMintValue (..)
@@ -304,7 +305,6 @@ import           Data.List (sortBy)
 import qualified Data.List as List
 import qualified Data.List.NonEmpty as NonEmpty
 import           Data.Map.Ordered.Strict (OMap)
-import qualified Data.Map.Ordered.Strict as OMap
 import           Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
 import           Data.Maybe
@@ -330,8 +330,6 @@ import qualified Text.Parsec as Parsec
 import           Text.Parsec ((<?>))
 import qualified Text.Parsec.String as Parsec
 
-import           Debug.Trace
-
 -- ----------------------------------------------------------------------------
 -- Transaction outputs
 --
@@ -1285,62 +1283,55 @@ indexTxWithdrawals (TxWithdrawals _ withdrawals) =
 --
 
 data TxCertificates build era where
+  -- | No certificates
   TxCertificatesNone
     :: TxCertificates build era
-  -- | Note the following relationships between the types here:
-  -- StakeCredential 1--* Certificate 1--*  Witness
-  -- In other words, you can have multiple certificates with the same stake credential and multiple witnesses
-  -- for a certificate.
+  -- | Represents certificates present in transaction. Prefer using 'mkTxCertificates' to constructing
+  -- this type with a constructor
   TxCertificates
     :: ShelleyBasedEra era
     -> OMap
         (Certificate era)
         ( BuildTxWith
             build
-            (Maybe (StakeCredential, [Witness WitCtxStake era]))
+            (Maybe (StakeCredential, Witness WitCtxStake era))
         )
     -> TxCertificates build era
 
 deriving instance Eq (TxCertificates build era)
 
 deriving instance Show (TxCertificates build era)
 
-instance Semigroup (TxCertificates build era) where
-  TxCertificatesNone <> x = x
-  x <> TxCertificatesNone = x
-  TxCertificates sbe certs1 <> TxCertificates _ certs2 =
-    TxCertificates sbe $ OMap.unionWithL merge certs1 certs2
-   where
-    merge
-      :: Certificate era
-      -> BuildTxWith
-          build
-          (Maybe (StakeCredential, [Witness WitCtxStake era]))
-      -> BuildTxWith
-          build
-          (Maybe (StakeCredential, [Witness WitCtxStake era]))
-      -> BuildTxWith
-          build
-          (Maybe (StakeCredential, [Witness WitCtxStake era]))
-    merge _ ViewTx ViewTx = ViewTx
-    merge _ (BuildTxWith mCredWit) (BuildTxWith Nothing) = BuildTxWith mCredWit
-    merge _ (BuildTxWith Nothing) (BuildTxWith mCredWit) = BuildTxWith mCredWit
-    merge _ (BuildTxWith (Just (sCred, wits1))) (BuildTxWith (Just (_, wits2))) =
-      BuildTxWith $ Just (sCred, wits1 <> wits2)
-
-instance Monoid (TxCertificates build era) where
-  mempty = TxCertificatesNone
-
--- | 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.
+-- | Create 'TxCertificates'. Note that 'Certificate era' will be deduplicated. Only Certificates with a
+-- stake credential will be in the result.
+mkTxCertificates
+  :: Applicative (BuildTxWith build)
+  => ShelleyBasedEra era
+  -> [(Certificate era, Maybe (ScriptWitness WitCtxStake era))]
+  -> TxCertificates build era
+mkTxCertificates _ [] = TxCertificatesNone
+mkTxCertificates sbe certs = TxCertificates sbe . fromList $ map getStakeCred certs
+ where
+  getStakeCred (cert, mWit) = do
+    let wit =
+          maybe
+            (KeyWitness KeyWitnessForStakeAddr)
+            (ScriptWitness ScriptWitnessForStakeAddr)
+            mWit
+    ( cert
+      , pure $
+          (,wit) <$> selectStakeCredentialWitness cert
+      )
+
+-- | Index certificates with witnesses by the order they appear in the list (in the transaction).
 -- See section 4.1 of https://github.com/intersectmbo/cardano-ledger/releases/latest/download/alonzo-ledger.pdf
 indexTxCertificates
   :: TxCertificates BuildTx era
-  -> [(ScriptWitnessIndex, Certificate era, StakeCredential, [Witness WitCtxStake era])]
+  -> [(ScriptWitnessIndex, Certificate era, StakeCredential, Witness WitCtxStake era)]
 indexTxCertificates TxCertificatesNone = []
 indexTxCertificates (TxCertificates _ certsWits) =
-  [ (ScriptWitnessIndexCertificate ix, cert, stakeCred, witnesses)
-  | (ix, (cert, BuildTxWith (Just (stakeCred, witnesses)))) <- zip [0 ..] $ toList certsWits
+  [ (ScriptWitnessIndexCertificate ix, cert, stakeCred, witness)
+  | (ix, (cert, BuildTxWith (Just (stakeCred, witness)))) <- zip [0 ..] $ toList certsWits
   ]
 
 data TxUpdateProposal era where
@@ -3633,8 +3624,7 @@ collectTxBodyScriptWitnesses
     scriptWitnessesCertificates txc =
       List.nub
         [ (ix, AnyScriptWitness witness)
-        | (ix, _, _, witnesses) <- indexTxCertificates txc
-        , ScriptWitness _ witness <- witnesses
+        | (ix, _, _, ScriptWitness _ witness) <- indexTxCertificates txc
         ]
 
     scriptWitnessesMinting

diff --git a/cardano-api/internal/Cardano/Api/Tx/Compatible.hs b/cardano-api/internal/Cardano/Api/Tx/Compatible.hs
@@ -117,8 +117,7 @@ createCompatibleSignedTx sbe ins outs witnesses txFee' anyProtocolUpdate anyVote
 
         apiScriptWitnesses =
           [ (ix, AnyScriptWitness witness)
-          | (ix, _, _, wits) <- indexedTxCerts
-          , ScriptWitness _ witness <- wits
+          | (ix, _, _, ScriptWitness _ witness) <- indexedTxCerts
           ]
 
     pure
@@ -142,8 +141,7 @@ createCompatibleSignedTx sbe ins outs witnesses txFee' anyProtocolUpdate anyVote
   setRefInputs = do
     let refInputs =
           [ toShelleyTxIn refInput
-          | (_, _, _, wits) <- indexedTxCerts
-          , ScriptWitness _ wit <- wits
+          | (_, _, _, ScriptWitness _ wit) <- indexedTxCerts
           , refInput <- maybeToList $ getScriptWitnessReferenceInput wit
           ]
 
@@ -162,7 +160,7 @@ createCompatibleSignedTx sbe ins outs witnesses txFee' anyProtocolUpdate anyVote
       (L.bodyTxL . L.votingProceduresTxBodyL) .~ votingProcedures
 
   indexedTxCerts
-    :: [(ScriptWitnessIndex, Certificate era, StakeCredential, [Witness WitCtxStake era])]
+    :: [(ScriptWitnessIndex, Certificate era, StakeCredential, Witness WitCtxStake era)]
   indexedTxCerts = indexTxCertificates txCertificates'
 
   allWitnesses

diff --git a/cardano-api/src/Cardano/Api.hs b/cardano-api/src/Cardano/Api.hs
@@ -391,6 +391,7 @@ module Cardano.Api
   , TxExtraKeyWitnesses (..)
   , TxWithdrawals (..)
   , TxCertificates (..)
+  , mkTxCertificates
   , TxUpdateProposal (..)
   , TxMintValue (..)
   , txMintValueToValue