Change a representation of witnesses in transaction's certificates to…

… an ordered map where a certificate is the key

cardano-api/cardano-api.cabal

@@ -207,6 +207,7 @@ library internal
     mtl,
     network,
     network-mux,
+    ordered-containers,
     ouroboros-consensus ^>=0.22,
     ouroboros-consensus-cardano ^>=0.21,
     ouroboros-consensus-diffusion ^>=0.19,

cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs

@@ -621,7 +621,7 @@ genTxCertificates =
         certs <- Gen.list (Range.constant 0 3) $ genCertificate w
         Gen.choice
           [ pure TxCertificatesNone
-          , pure (TxCertificates w certs $ BuildTxWith mempty)
+          , pure (TxCertificates w $ fromList ((,BuildTxWith Nothing) <$> certs))
           -- TODO: Generate certificates
           ]
     )

cardano-api/internal/Cardano/Api/Certificate.hs

@@ -142,6 +142,8 @@ data Certificate era where
 
 deriving instance Eq (Certificate era)
 
+deriving instance Ord (Certificate era)
+
 deriving instance Show (Certificate era)
 
 instance Typeable era => HasTypeProxy (Certificate era) where

cardano-api/internal/Cardano/Api/Eon/ConwayEraOnwards.hs

@@ -55,6 +55,8 @@ deriving instance Show (ConwayEraOnwards era)
 
 deriving instance Eq (ConwayEraOnwards era)
 
+deriving instance Ord (ConwayEraOnwards era)
+
 instance Eon ConwayEraOnwards where
   inEonForEra no yes = \case
     ByronEra -> no

cardano-api/internal/Cardano/Api/Eon/ShelleyToBabbageEra.hs

@@ -50,6 +50,8 @@ deriving instance Show (ShelleyToBabbageEra era)
 
 deriving instance Eq (ShelleyToBabbageEra era)
 
+deriving instance Ord (ShelleyToBabbageEra era)
+
 instance Eon ShelleyToBabbageEra where
   inEonForEra no yes = \case
     ByronEra -> no

cardano-api/internal/Cardano/Api/Fees.hs

@@ -245,10 +245,7 @@ estimateBalancedTxBody
     --  1. Subtract certificate and proposal deposits
     -- from the total available Ada value!
     -- Page 24 Shelley ledger spec
-    let certificates =
-          case txCertificates txbodycontent1 of
-            TxCertificatesNone -> []
-            TxCertificates _ certs _ -> map toShelleyCertificate certs
+    let certificates = convCertificates sbe $ txCertificates txbodycontent1
 
         proposalProcedures :: OSet.OSet (L.ProposalProcedure (ShelleyLedgerEra era))
         proposalProcedures =
@@ -478,8 +475,9 @@ estimateTransactionKeyWitnessCount
             length [() | (_, _, BuildTxWith KeyWitness{}) <- withdrawals]
           _ -> 0
         + case txCertificates of
-          TxCertificates _ _ (BuildTxWith witnesses) ->
-            length [() | (_, KeyWitness{}) <- witnesses]
+          TxCertificates _ credWits ->
+            length
+              [() | (_, BuildTxWith (Just (_, KeyWitness{}))) <- toList credWits]
           _ -> 0
         + case txUpdateProposal of
           TxUpdateProposal _ (UpdateProposal updatePerGenesisKey _) ->
@@ -1500,18 +1498,27 @@ substituteExecutionUnits
       :: TxCertificates BuildTx era
       -> Either (TxBodyErrorAutoBalance era) (TxCertificates BuildTx era)
     mapScriptWitnessesCertificates TxCertificatesNone = Right TxCertificatesNone
-    mapScriptWitnessesCertificates txCertificates'@(TxCertificates supported certs _) =
+    mapScriptWitnessesCertificates txCertificates'@(TxCertificates supported _) = do
       let mappedScriptWitnesses
-            :: [(StakeCredential, Either (TxBodyErrorAutoBalance era) (Witness WitCtxStake era))]
+            :: [ ( Certificate era
+                 , Either
+                    (TxBodyErrorAutoBalance era)
+                    ( BuildTxWith
+                        BuildTx
+                        ( Maybe
+                            ( StakeCredential
+                            , Witness WitCtxStake era
+                            )
+                        )
+                    )
+                 )
+               ]
           mappedScriptWitnesses =
-            [ (stakeCred, witness')
-            | (ix, _, stakeCred, witness) <- indexTxCertificates txCertificates'
-            , let witness' = adjustScriptWitness (substituteExecUnits ix) witness
+            [ (cert, BuildTxWith . Just . (stakeCred,) <$> eWitness')
+            | (ix, cert, stakeCred, witness) <- indexTxCertificates txCertificates'
+            , let eWitness' = adjustScriptWitness (substituteExecUnits ix) witness
             ]
-       in TxCertificates supported certs . BuildTxWith
-            <$> traverse
-              (\(sCred, eScriptWitness) -> (sCred,) <$> eScriptWitness)
-              mappedScriptWitnesses
+      TxCertificates supported . fromList <$> traverseScriptWitnesses mappedScriptWitnesses
 
     mapScriptWitnessesVotes
       :: Maybe (Featured ConwayEraOnwards era (TxVotingProcedures build era))

cardano-api/internal/Cardano/Api/Script.hs

@@ -565,6 +565,8 @@ data ScriptLanguageInEra lang era where
 
 deriving instance Eq (ScriptLanguageInEra lang era)
 
+deriving instance Ord (ScriptLanguageInEra lang era)
+
 deriving instance Show (ScriptLanguageInEra lang era)
 
 instance ToJSON (ScriptLanguageInEra lang era) where
@@ -742,7 +744,7 @@ data ScriptWitness witctx era where
 
 deriving instance Show (ScriptWitness witctx era)
 
--- The GADT in the SimpleScriptWitness constructor requires a custom instance
+-- The existential in the SimpleScriptWitness constructor requires a custom instance
 instance Eq (ScriptWitness witctx era) where
   (==)
     (SimpleScriptWitness langInEra script)

cardano-api/internal/Cardano/Api/Tx/Body.hs

@@ -11,6 +11,7 @@
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TupleSections #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE TypeOperators #-}
@@ -135,6 +136,7 @@ module Cardano.Api.Tx.Body
   , TxWithdrawals (..)
   , indexTxWithdrawals
   , TxCertificates (..)
+  , mkTxCertificates
   , indexTxCertificates
   , TxUpdateProposal (..)
   , TxMintValue (..)
@@ -302,6 +304,7 @@ import           Data.Functor (($>))
 import           Data.List (sortBy)
 import qualified Data.List as List
 import qualified Data.List.NonEmpty as NonEmpty
+import           Data.Map.Ordered.Strict (OMap)
 import           Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
 import           Data.Maybe
@@ -1280,38 +1283,56 @@ indexTxWithdrawals (TxWithdrawals _ withdrawals) =
 --
 
 data TxCertificates build era where
+  -- | No certificates
   TxCertificatesNone
     :: TxCertificates build era
+  -- | Represents certificates present in transaction. Prefer using 'mkTxCertificates' to constructing
+  -- this type with a constructor
   TxCertificates
     :: ShelleyBasedEra era
-    -> [Certificate era]
-    -> BuildTxWith build [(StakeCredential, Witness WitCtxStake era)]
-    -- ^ There can be more than one script witness per stake credential
+    -> OMap
+        (Certificate era)
+        ( BuildTxWith
+            build
+            (Maybe (StakeCredential, Witness WitCtxStake era))
+        )
     -> TxCertificates build era
 
 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 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
+-- | 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)]
 indexTxCertificates TxCertificatesNone = []
-indexTxCertificates (TxCertificates _ certs (BuildTxWith witnesses)) =
-  [ (ScriptWitnessIndexCertificate ix, cert, stakeCred, wit)
-  | (ix, cert) <- zip [0 ..] certs
-  , stakeCred <- maybeToList (selectStakeCredentialWitness cert)
-  , wit <- findAll stakeCred witnesses
+indexTxCertificates (TxCertificates _ certsWits) =
+  [ (ScriptWitnessIndexCertificate ix, cert, stakeCred, witness)
+  | (ix, (cert, BuildTxWith (Just (stakeCred, witness)))) <- zip [0 ..] $ toList certsWits
   ]
- where
-  findAll needle = map snd . filter ((==) needle . fst)
-
--- ----------------------------------------------------------------------------
--- Transaction update proposal (era-dependent)
---
 
 data TxUpdateProposal era where
   TxUpdateProposalNone :: TxUpdateProposal era
@@ -2537,7 +2558,8 @@ fromLedgerTxCertificates sbe body =
     let certificates = body ^. L.certsTxBodyL
      in if null certificates
           then TxCertificatesNone
-          else TxCertificates sbe (map (fromShelleyCertificate sbe) $ toList certificates) ViewTx
+          else
+            TxCertificates sbe . fromList $ map ((,ViewTx) . fromShelleyCertificate sbe) $ toList certificates
 
 maybeFromLedgerTxUpdateProposal
   :: ()
@@ -2645,7 +2667,7 @@ convCertificates
   -> Seq.StrictSeq (Shelley.TxCert (ShelleyLedgerEra era))
 convCertificates _ = \case
   TxCertificatesNone -> Seq.empty
-  TxCertificates _ cs _ -> fromList (map toShelleyCertificate cs)
+  TxCertificates _ cs -> fromList . map (toShelleyCertificate . fst) $ toList cs
 
 convWithdrawals :: TxWithdrawals build era -> L.Withdrawals StandardCrypto
 convWithdrawals txWithdrawals =

cardano-api/internal/Cardano/Api/Tx/Compatible.hs

@@ -159,7 +159,8 @@ createCompatibleSignedTx sbe ins outs witnesses txFee' anyProtocolUpdate anyVote
     conwayEraOnwardsConstraints conwayOnwards $
       (L.bodyTxL . L.votingProceduresTxBodyL) .~ votingProcedures
 
-  indexedTxCerts :: [(ScriptWitnessIndex, Certificate era, StakeCredential, Witness WitCtxStake era)]
+  indexedTxCerts
+    :: [(ScriptWitnessIndex, Certificate era, StakeCredential, Witness WitCtxStake era)]
   indexedTxCerts = indexTxCertificates txCertificates'
 
   allWitnesses

cardano-api/src/Cardano/Api.hs

@@ -391,6 +391,7 @@ module Cardano.Api
   , TxExtraKeyWitnesses (..)
   , TxWithdrawals (..)
   , TxCertificates (..)
+  , mkTxCertificates
   , TxUpdateProposal (..)
   , TxMintValue (..)
   , txMintValueToValue