Add certs support in compatible Tx building

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

@@ -83,6 +83,11 @@ instance Convert BabbageEraOnwards MaryEraOnwards where
     BabbageEraOnwardsBabbage -> MaryEraOnwardsBabbage
     BabbageEraOnwardsConway -> MaryEraOnwardsConway
 
+instance Convert BabbageEraOnwards AlonzoEraOnwards where
+  convert = \case
+    BabbageEraOnwardsBabbage -> AlonzoEraOnwardsBabbage
+    BabbageEraOnwardsConway -> AlonzoEraOnwardsConway
+
 type BabbageEraOnwardsConstraints era =
   ( C.HashAlgorithm (L.HASH (L.EraCrypto (ShelleyLedgerEra era)))
   , C.Signable (L.VRF (L.EraCrypto (ShelleyLedgerEra era))) L.Seed

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

@@ -19,6 +19,7 @@ module Cardano.Api.Eon.ConwayEraOnwards
   )
 where
 
+import           Cardano.Api.Eon.AllegraEraOnwards (AllegraEraOnwards (..))
 import           Cardano.Api.Eon.BabbageEraOnwards
 import           Cardano.Api.Eon.Convert
 import           Cardano.Api.Eon.ShelleyBasedEra
@@ -75,6 +76,10 @@ instance Convert ConwayEraOnwards ShelleyBasedEra where
   convert = \case
     ConwayEraOnwardsConway -> ShelleyBasedEraConway
 
+instance Convert ConwayEraOnwards AllegraEraOnwards where
+  convert = \case
+    ConwayEraOnwardsConway -> AllegraEraOnwardsConway
+
 instance Convert ConwayEraOnwards BabbageEraOnwards where
   convert = \case
     ConwayEraOnwardsConway -> BabbageEraOnwardsConway

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

@@ -185,7 +185,6 @@ module Cardano.Api.Tx.Body
   , convWithdrawals
   , getScriptIntegrityHash
   , mkCommonTxBody
-  , scriptWitnessesProposing
   , toAuxiliaryData
   , toByronTxId
   , toShelleyTxId
@@ -3626,15 +3625,15 @@ collectTxBodyScriptWitnesses
         | (ix, _, witness) <- indexTxVotingProcedures txv
         ]
 
-scriptWitnessesProposing
-  :: TxProposalProcedures BuildTx era
-  -> [(ScriptWitnessIndex, AnyScriptWitness era)]
-scriptWitnessesProposing TxProposalProceduresNone = []
-scriptWitnessesProposing txp =
-  List.nub
-    [ (ix, AnyScriptWitness witness)
-    | (ix, _, witness) <- indexTxProposalProcedures txp
-    ]
+    scriptWitnessesProposing
+      :: TxProposalProcedures BuildTx era
+      -> [(ScriptWitnessIndex, AnyScriptWitness era)]
+    scriptWitnessesProposing TxProposalProceduresNone = []
+    scriptWitnessesProposing txp =
+      List.nub
+        [ (ix, AnyScriptWitness witness)
+        | (ix, _, witness) <- indexTxProposalProcedures txp
+        ]
 
 -- TODO: Investigate if we need
 toShelleyWithdrawal :: [(StakeAddress, L.Coin, a)] -> L.Withdrawals StandardCrypto

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

@@ -2,6 +2,8 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeOperators #-}
 
 -- | This module provides a way to construct a simple transaction over all eras.
@@ -13,10 +15,15 @@ module Cardano.Api.Tx.Compatible
   )
 where
 
-import           Cardano.Api.Eon.Convert
+import           Cardano.Api.Address (StakeCredential)
+import           Cardano.Api.Certificate (Certificate)
+import           Cardano.Api.Eon.AlonzoEraOnwards
+import           Cardano.Api.Eon.BabbageEraOnwards
 import           Cardano.Api.Eon.ConwayEraOnwards
 import           Cardano.Api.Eon.ShelleyBasedEra
 import           Cardano.Api.Eon.ShelleyToBabbageEra
+import           Cardano.Api.Eras
+import           Cardano.Api.Eras.Case
 import           Cardano.Api.ProtocolParameters
 import           Cardano.Api.Script
 import           Cardano.Api.Tx.Body
@@ -25,12 +32,14 @@ import           Cardano.Api.Value
 
 import qualified Cardano.Ledger.Api as L
 
-import           Control.Error (catMaybes)
 import qualified Data.Map.Strict as Map
+import           Data.Maybe
 import           Data.Maybe.Strict
+import           Data.Monoid
 import qualified Data.Sequence.Strict as Seq
-import           Data.Set (fromList)
-import           Lens.Micro
+import           Data.Set (Set)
+import           GHC.Exts (IsList (..))
+import           Lens.Micro hiding (ix)
 
 data AnyProtocolUpdate era where
   ProtocolUpdate
@@ -62,101 +71,148 @@ createCompatibleSignedTx
   -- ^ Fee
   -> AnyProtocolUpdate era
   -> AnyVote era
+  -> TxCertificates BuildTx era
   -> Either ProtocolParametersConversionError (Tx era)
-createCompatibleSignedTx sbeF ins outs witnesses txFee' anyProtocolUpdate anyVote =
-  shelleyBasedEraConstraints sbeF $ do
-    tx <- case anyProtocolUpdate of
-      ProtocolUpdate shelleyToBabbageEra updateProposal -> do
-        let sbe = convert shelleyToBabbageEra
-
-        ledgerPParamsUpdate <- toLedgerUpdate sbe updateProposal
-
-        let txbody = createCommonTxBody sbe ins outs txFee'
-            bodyWithProtocolUpdate =
-              shelleyToBabbageEraConstraints shelleyToBabbageEra $
-                txbody & L.updateTxBodyL .~ SJust ledgerPParamsUpdate
-            finalTx =
-              L.mkBasicTx bodyWithProtocolUpdate
-                & L.witsTxL .~ shelleyToBabbageEraConstraints shelleyToBabbageEra allShelleyToBabbageWitnesses
-
-        return $ ShelleyTx sbe finalTx
-      NoPParamsUpdate sbe -> do
-        let txbody = createCommonTxBody sbe ins outs txFee'
-            finalTx = L.mkBasicTx txbody & L.witsTxL .~ shelleyBasedEraConstraints sbe allShelleyToBabbageWitnesses
-
-        return $ ShelleyTx sbe finalTx
-      ProposalProcedures conwayOnwards proposalProcedures -> do
-        let sbe = convert conwayOnwards
-            proposals = convProposalProcedures proposalProcedures
-            apiScriptWitnesses = scriptWitnessesProposing proposalProcedures
-            ledgerScripts = convScripts apiScriptWitnesses
-            referenceInputs =
-              map toShelleyTxIn $
-                catMaybes [getScriptWitnessReferenceInput sWit | (_, AnyScriptWitness sWit) <- apiScriptWitnesses]
-            sData = convScriptData sbe outs apiScriptWitnesses
-            txbody =
-              conwayEraOnwardsConstraints conwayOnwards $
-                createCommonTxBody sbe ins outs txFee'
-                  & L.referenceInputsTxBodyL .~ fromList referenceInputs
-                  & L.proposalProceduresTxBodyL
-                    .~ proposals
-
-            finalTx =
-              L.mkBasicTx txbody
-                & L.witsTxL
-                  .~ conwayEraOnwardsConstraints conwayOnwards (allConwayEraOnwardsWitnesses sData ledgerScripts)
-
-        return $ ShelleyTx sbe finalTx
-
-    case anyVote of
-      NoVotes -> return tx
-      VotingProcedures conwayOnwards procedures -> do
-        let ledgerVotingProcedures = convVotingProcedures procedures
-            ShelleyTx sbe' fTx = tx
-            updatedTx =
-              conwayEraOnwardsConstraints conwayOnwards $
-                overwriteVotingProcedures fTx ledgerVotingProcedures
-        return $ ShelleyTx sbe' updatedTx
+createCompatibleSignedTx sbe ins outs witnesses txFee' anyProtocolUpdate anyVote txCertificates' =
+  shelleyBasedEraConstraints sbe $ do
+    let apiScriptWitnesses =
+          [ (ix, AnyScriptWitness witness)
+          | (ix, _, _, ScriptWitness _ witness) <- indexedTxCerts
+          ]
+
+    (updateTxBody, extraScriptWitnesses) <-
+      case anyProtocolUpdate of
+        ProtocolUpdate shelleyToBabbageEra updateProposal -> do
+          ledgerPParamsUpdate <- toLedgerUpdate sbe updateProposal
+          let updateTxBody :: Endo (L.TxBody (ShelleyLedgerEra era)) =
+                Endo $ \txb ->
+                  shelleyToBabbageEraConstraints shelleyToBabbageEra $
+                    txb & L.updateTxBodyL .~ SJust ledgerPParamsUpdate
+
+          pure (updateTxBody, [])
+        NoPParamsUpdate _ -> do
+          let referenceInputs =
+                fromList @(Set _)
+                  [ toShelleyTxIn txIn
+                  | (_, AnyScriptWitness sWit) <- apiScriptWitnesses
+                  , txIn <- maybeToList $ getScriptWitnessReferenceInput sWit
+                  ]
+
+              updateTxBody :: Endo (L.TxBody (ShelleyLedgerEra era)) =
+                monoidForEraInEon era $ \eon ->
+                  babbageEraOnwardsConstraints eon $
+                    Endo $
+                      L.referenceInputsTxBodyL %~ (<> referenceInputs)
+          pure (updateTxBody, [])
+        ProposalProcedures conwayOnwards proposalProcedures -> do
+          let proposals = convProposalProcedures proposalProcedures
+              proposalWitnesses =
+                [ (ix, AnyScriptWitness witness)
+                | (ix, _, witness) <- indexTxProposalProcedures proposalProcedures
+                ]
+              referenceInputs =
+                [ toShelleyTxIn txIn
+                | (_, AnyScriptWitness sWit) <- proposalWitnesses <> apiScriptWitnesses
+                , txIn <- maybeToList $ getScriptWitnessReferenceInput sWit
+                ]
+              updateTxBody :: Endo (L.TxBody (ShelleyLedgerEra era)) =
+                conwayEraOnwardsConstraints conwayOnwards $
+                  Endo $
+                    (L.referenceInputsTxBodyL %~ (<> fromList referenceInputs))
+                      . (L.proposalProceduresTxBodyL .~ proposals)
+
+          pure (updateTxBody, proposalWitnesses)
+
+    let txbody =
+          createCommonTxBody sbe ins outs txFee'
+            & appEndos [setCerts, setRefInputs, updateTxBody]
+
+        updateVotingProcedures =
+          case anyVote of
+            NoVotes -> id
+            VotingProcedures conwayOnwards procedures ->
+              overwriteVotingProcedures conwayOnwards (convVotingProcedures procedures)
+
+    pure
+      . ShelleyTx sbe
+      $ L.mkBasicTx txbody
+        & L.witsTxL
+          .~ allWitnesses (apiScriptWitnesses <> extraScriptWitnesses) allShelleyToBabbageWitnesses
+        & updateVotingProcedures
  where
-  overwriteVotingProcedures
-    :: L.ConwayEraTxBody ledgerera
-    => L.EraTx ledgerera
-    => L.Tx ledgerera -> L.VotingProcedures ledgerera -> L.Tx ledgerera
-  overwriteVotingProcedures lTx vProcedures =
-    lTx & (L.bodyTxL . L.votingProceduresTxBodyL) .~ vProcedures
-
-  shelleyKeywitnesses =
-    fromList [w | ShelleyKeyWitness _ w <- witnesses]
-
-  shelleyBootstrapWitnesses =
-    fromList [w | ShelleyBootstrapWitness _ w <- witnesses]
+  era = toCardanoEra sbe
+  appEndos = appEndo . mconcat
+
+  setCerts :: Endo (L.TxBody (ShelleyLedgerEra era))
+  setCerts =
+    monoidForEraInEon era $ \aeo ->
+      alonzoEraOnwardsConstraints aeo $
+        Endo $
+          L.certsTxBodyL .~ convCertificates sbe txCertificates'
+
+  setRefInputs :: Endo (L.TxBody (ShelleyLedgerEra era))
+  setRefInputs = do
+    let refInputs =
+          [ toShelleyTxIn refInput
+          | (_, _, _, ScriptWitness _ wit) <- indexedTxCerts
+          , refInput <- maybeToList $ getScriptWitnessReferenceInput wit
+          ]
+
+    monoidForEraInEon era $ \beo ->
+      babbageEraOnwardsConstraints beo $
+        Endo $
+          L.referenceInputsTxBodyL .~ fromList refInputs
 
-  allConwayEraOnwardsWitnesses
-    :: L.AlonzoEraTxWits (ShelleyLedgerEra era)
-    => L.EraCrypto (ShelleyLedgerEra era) ~ L.StandardCrypto
-    => TxBodyScriptData era -> [L.Script (ShelleyLedgerEra era)] -> L.TxWits (ShelleyLedgerEra era)
-  allConwayEraOnwardsWitnesses sData ledgerScripts =
-    let (datums, redeemers) = case sData of
-          TxBodyScriptData _ ds rs -> (ds, rs)
-          TxBodyNoScriptData -> (mempty, L.Redeemers mempty)
-     in L.mkBasicTxWits
-          & L.addrTxWitsL
-            .~ shelleyKeywitnesses
-          & L.bootAddrTxWitsL
-            .~ shelleyBootstrapWitnesses
-          & L.datsTxWitsL .~ datums
-          & L.rdmrsTxWitsL .~ redeemers
-          & L.scriptTxWitsL
-            .~ Map.fromList
-              [ (L.hashScript sw, sw)
-              | sw <- ledgerScripts
-              ]
+  overwriteVotingProcedures
+    :: ConwayEraOnwards era
+    -> L.VotingProcedures (ShelleyLedgerEra era)
+    -> L.Tx (ShelleyLedgerEra era)
+    -> L.Tx (ShelleyLedgerEra era)
+  overwriteVotingProcedures conwayOnwards votingProcedures =
+    conwayEraOnwardsConstraints conwayOnwards $
+      (L.bodyTxL . L.votingProceduresTxBodyL) .~ votingProcedures
+
+  indexedTxCerts :: [(ScriptWitnessIndex, Certificate era, StakeCredential, Witness WitCtxStake era)]
+  indexedTxCerts = indexTxCertificates txCertificates'
+
+  allWitnesses
+    :: [(ScriptWitnessIndex, AnyScriptWitness era)]
+    -> L.TxWits (ShelleyLedgerEra era)
+    -> L.TxWits (ShelleyLedgerEra era)
+  allWitnesses scriptWitnesses =
+    shelleyBasedEraConstraints sbe $
+      do
+        caseShelleyToMaryOrAlonzoEraOnwards
+          (const id)
+          ( const $ do
+              let sData = convScriptData sbe outs scriptWitnesses
+              let (datums, redeemers) = case sData of
+                    TxBodyScriptData _ ds rs -> (ds, rs)
+                    TxBodyNoScriptData -> (mempty, L.Redeemers mempty)
+              (L.datsTxWitsL .~ datums) . (L.rdmrsTxWitsL %~ (<> redeemers))
+          )
+          sbe
+        . caseShelleyEraOnlyOrAllegraEraOnwards
+          (const id)
+          ( const $ do
+              let ledgerScripts = convScripts scriptWitnesses
+              L.scriptTxWitsL
+                .~ Map.fromList
+                  [ (L.hashScript sw, sw)
+                  | sw <- ledgerScripts
+                  ]
+          )
+          sbe
 
   allShelleyToBabbageWitnesses
     :: L.EraTxWits (ShelleyLedgerEra era)
     => L.EraCrypto (ShelleyLedgerEra era) ~ L.StandardCrypto
     => L.TxWits (ShelleyLedgerEra era)
-  allShelleyToBabbageWitnesses =
+  allShelleyToBabbageWitnesses = do
+    let shelleyKeywitnesses =
+          fromList [w | ShelleyKeyWitness _ w <- witnesses]
+    let shelleyBootstrapWitnesses =
+          fromList [w | ShelleyBootstrapWitness _ w <- witnesses]
     L.mkBasicTxWits
       & L.addrTxWitsL
         .~ shelleyKeywitnesses