Use correct representation of witnesses in transaction's certificates

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,
@@ -217,6 +218,7 @@ library internal
     ouroboros-network-protocols,
     parsec,
     plutus-ledger-api:{plutus-ledger-api, plutus-ledger-api-testlib} ^>=1.37,
+    pretty-simple,
     prettyprinter,
     prettyprinter-ansi-terminal,
     prettyprinter-configurable ^>=1.36,

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

@@ -97,8 +97,12 @@ 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)
+
+import           Debug.Trace
 
 -- | Type synonym for logs returned by the ledger's @evalTxExUnitsWithLogs@ function.
 -- for scripts in transactions.
@@ -245,10 +249,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 +479,12 @@ estimateTransactionKeyWitnessCount
             length [() | (_, _, BuildTxWith KeyWitness{}) <- withdrawals]
           _ -> 0
         + case txCertificates of
-          TxCertificates _ _ (BuildTxWith witnesses) ->
-            length [() | (_, KeyWitness{}) <- witnesses]
+          TxCertificates _ credWits ->
+            length
+              [ ()
+              | (_, BuildTxWith (Just (_, witnesses))) <- toList credWits
+              , KeyWitness{} <- witnesses
+              ]
           _ -> 0
         + case txUpdateProposal of
           TxUpdateProposal _ (UpdateProposal updatePerGenesisKey _) ->
@@ -1049,34 +1054,85 @@ makeTransactionBodyAutoBalance
             monoidForEraInEon (toCardanoEra sbe) $ \w ->
               toLedgerValue w $ calculateChangeValue sbe totalValueAtSpendableUTxO txbodycontent
 
-      txbody0 <-
-        first TxBodyError
-          $ createTransactionBody
-            sbe
-          $ txbodycontent
-            & modTxOuts
-              (<> [TxOut changeaddr (TxOutValueShelleyBased sbe change) TxOutDatumNone ReferenceScriptNone])
-      exUnitsMapWithLogs <-
-        first TxBodyErrorValidityInterval $
-          evaluateTransactionExecutionUnits
-            era
-            systemstart
-            history
-            lpp
-            utxo
-            txbody0
-
-      let exUnitsMap = Map.map (fmap snd) exUnitsMapWithLogs
-
-      exUnitsMap' <-
-        case Map.mapEither id exUnitsMap of
-          (failures, exUnitsMap') ->
-            handleExUnitsErrors
-              (txScriptValidityToScriptValidity (txScriptValidity txbodycontent))
-              failures
-              exUnitsMap'
-
-      txbodycontent1 <- substituteExecutionUnits exUnitsMap' txbodycontent
+      -- do
+      --   let TxCertificates _ cs (BuildTxWith ws) = txCertificates txbodycontent
+      --   traceM $ "\nCerts count: " <> show (length cs)
+      --   traceM $ "\nCerts wits count: " <> show (length ws)
+      --
+      --   traceM . T.unpack $ "\ntxbc0 ixed certs: " <> pShow [(ix, cert, cred) | (ix, cert, cred, _)<- indexTxCertificates $ txCertificates txbodycontent ]
+
+      txbodycontent1 <- do
+        txbody0 <-
+          first TxBodyError
+            $ createTransactionBody
+              sbe
+            $ txbodycontent
+              & modTxOuts
+                (<> [TxOut changeaddr (TxOutValueShelleyBased sbe change) TxOutDatumNone ReferenceScriptNone])
+        exUnitsMapWithLogs <-
+          first TxBodyErrorValidityInterval $
+            evaluateTransactionExecutionUnits
+              era
+              systemstart
+              history
+              lpp
+              utxo
+              txbody0
+
+        let exUnitsMap = Map.map (fmap snd) exUnitsMapWithLogs
+
+        exUnitsMap' <-
+          case Map.mapEither id exUnitsMap of
+            (failures, exUnitsMap') ->
+              handleExUnitsErrors
+                (txScriptValidityToScriptValidity (txScriptValidity txbodycontent))
+                failures
+                exUnitsMap'
+
+        traceM . T.unpack $ "\nExecution units: " <> pShow exUnitsMap' <> "\n"
+
+        txbodycontent1 <- substituteExecutionUnits exUnitsMap' txbodycontent
+        traceM . T.unpack $
+          "\ntxbc1 ixed certs: "
+            <> pShow
+              [(ix, cert, cred) | (ix, cert, cred, _) <- indexTxCertificates $ txCertificates txbodycontent1]
+        pure txbodycontent1
+
+      when False $ do
+        txbody0' <-
+          first TxBodyError $
+            createTransactionBody
+              sbe
+              txbodycontent1
+        exUnitsMapWithLogs' <-
+          first TxBodyErrorValidityInterval $
+            evaluateTransactionExecutionUnits
+              era
+              systemstart
+              history
+              lpp
+              utxo
+              txbody0'
+
+        let exUnitsMap1' = Map.map (fmap snd) exUnitsMapWithLogs'
+
+        exUnitsMap'' <-
+          case Map.mapEither id exUnitsMap1' of
+            (failures, exUnitsMap_') ->
+              handleExUnitsErrors
+                (txScriptValidityToScriptValidity (txScriptValidity txbodycontent))
+                failures
+                exUnitsMap_'
+
+        traceM . T.unpack $ "\nExecution units X2 : " <> pShow exUnitsMap'' <> "\n"
+
+      -- do
+      --   let TxCertificates _ cs (BuildTxWith ws) = txCertificates txbodycontent1
+      --   traceM $ "\nCerts count: " <> show (length cs)
+      --   traceM $ "\nCerts wits count: " <> show (length ws)
+      --   traceM . T.unpack $ pShow ws
+
+      -- traceM . T.unpack $ "\ntxbc1 wits: " <> pShow ws <> "\n"
 
       -- Make a txbody that we will use for calculating the fees. For the purpose
       -- of fees we just need to make a txbody of the right size in bytes. We do
@@ -1500,17 +1556,28 @@ 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
+                 , ( StakeCredential
+                   , [ Either
+                        (TxBodyErrorAutoBalance era)
+                        (Witness WitCtxStake era)
+                     ]
+                   )
+                 )
+               ]
           mappedScriptWitnesses =
-            [ (stakeCred, witness')
-            | (ix, _, stakeCred, witness) <- indexTxCertificates txCertificates'
-            , let witness' = adjustScriptWitness (substituteExecUnits ix) witness
+            [ (cert, (stakeCred, eWitnesses'))
+            | (ix, cert, stakeCred, witnesses) <- indexTxCertificates txCertificates'
+            , let eWitnesses' = adjustScriptWitness (substituteExecUnits ix) <$> witnesses
             ]
-       in TxCertificates supported certs . BuildTxWith
+       in TxCertificates supported . fromList
             <$> traverse
-              (\(sCred, eScriptWitness) -> (sCred,) <$> eScriptWitness)
+              ( \(cert, (sCred, eWitnesses)) -> do
+                  wits <- sequenceA eWitnesses
+                  pure (cert, BuildTxWith $ Just (sCred, wits))
+              )
               mappedScriptWitnesses
 
     mapScriptWitnessesVotes

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 #-}
@@ -302,6 +303,8 @@ 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 qualified Data.Map.Ordered.Strict as OMap
 import           Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
 import           Data.Maybe
@@ -327,6 +330,8 @@ import qualified Text.Parsec as Parsec
 import           Text.Parsec ((<?>))
 import qualified Text.Parsec.String as Parsec
 
+import           Debug.Trace
+
 -- ----------------------------------------------------------------------------
 -- Transaction outputs
 --
@@ -1282,36 +1287,61 @@ indexTxWithdrawals (TxWithdrawals _ withdrawals) =
 data TxCertificates build era where
   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.
   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
+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.
 -- 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 _ 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, witnesses)
+  | (ix, (cert, BuildTxWith (Just (stakeCred, witnesses)))) <- 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 +2567,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 +2676,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 =
@@ -3602,7 +3633,8 @@ collectTxBodyScriptWitnesses
     scriptWitnessesCertificates txc =
       List.nub
         [ (ix, AnyScriptWitness witness)
-        | (ix, _, _, ScriptWitness _ witness) <- indexTxCertificates txc
+        | (ix, _, _, witnesses) <- indexTxCertificates txc
+        , ScriptWitness _ witness <- witnesses
         ]
 
     scriptWitnessesMinting