From 079aaf291e3ae2244f2e8ca867908ee7dcf2fb7c Mon Sep 17 00:00:00 2001
From: Jordan Millar <jordan.millar@iohk.io>
Date: Thu, 3 Oct 2024 12:05:38 -0400
Subject: [PATCH 1/2] Enable votes in createCompatibleSignedTx

---
 .../internal/Cardano/Api/Tx/Compatible.hs     | 31 +++++++++++++++++--
 1 file changed, 28 insertions(+), 3 deletions(-)

diff --git a/cardano-api/internal/Cardano/Api/Tx/Compatible.hs b/cardano-api/internal/Cardano/Api/Tx/Compatible.hs
index 585436a7e8..908e9388ca 100644
--- a/cardano-api/internal/Cardano/Api/Tx/Compatible.hs
+++ b/cardano-api/internal/Cardano/Api/Tx/Compatible.hs
@@ -43,6 +43,13 @@ data AnyProtocolUpdate era where
     :: ShelleyBasedEra era
     -> AnyProtocolUpdate era
 
+data AnyVote era where
+  VotingProcedures
+    :: ConwayEraOnwards era
+    -> TxVotingProcedures BuildTx era
+    -> AnyVote era
+  NoVotes :: AnyVote era
+
 createCompatibleSignedTx
   :: forall era
    . ShelleyBasedEra era
@@ -52,10 +59,11 @@ createCompatibleSignedTx
   -> Lovelace
   -- ^ Fee
   -> AnyProtocolUpdate era
+  -> AnyVote era
   -> Either ProtocolParametersConversionError (Tx era)
-createCompatibleSignedTx sbeF ins outs witnesses txFee' anyProtocolUpdate =
-  shelleyBasedEraConstraints sbeF $
-    case anyProtocolUpdate of
+createCompatibleSignedTx sbeF ins outs witnesses txFee' anyProtocolUpdate anyVote =
+  shelleyBasedEraConstraints sbeF $ do
+    tx <- case anyProtocolUpdate of
       ShelleyToBabbageProtocolUpdate shelleyToBabbageEra updateProposal -> do
         let sbe = shelleyToBabbageEraToShelleyBasedEra shelleyToBabbageEra
 
@@ -97,7 +105,24 @@ createCompatibleSignedTx sbeF ins outs witnesses txFee' anyProtocolUpdate =
                   .~ 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
  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]
 

From 237063fd7758159a31d515ae760c161086ff6d3b Mon Sep 17 00:00:00 2001
From: Jordan Millar <jordan.millar@iohk.io>
Date: Thu, 3 Oct 2024 12:07:21 -0400
Subject: [PATCH 2/2] Rename constructors in AnyProtocolUpdate

---
 cardano-api/internal/Cardano/Api/Tx/Compatible.hs | 8 ++++----
 1 file changed, 4 insertions(+), 4 deletions(-)

diff --git a/cardano-api/internal/Cardano/Api/Tx/Compatible.hs b/cardano-api/internal/Cardano/Api/Tx/Compatible.hs
index 908e9388ca..ca58de07d0 100644
--- a/cardano-api/internal/Cardano/Api/Tx/Compatible.hs
+++ b/cardano-api/internal/Cardano/Api/Tx/Compatible.hs
@@ -31,11 +31,11 @@ import           Data.Set (fromList)
 import           Lens.Micro
 
 data AnyProtocolUpdate era where
-  ShelleyToBabbageProtocolUpdate
+  ProtocolUpdate
     :: ShelleyToBabbageEra era
     -> UpdateProposal
     -> AnyProtocolUpdate era
-  ConwayEraOnwardsProtocolUpdate
+  ProposalProcedures
     :: ConwayEraOnwards era
     -> TxProposalProcedures BuildTx era
     -> AnyProtocolUpdate era
@@ -64,7 +64,7 @@ createCompatibleSignedTx
 createCompatibleSignedTx sbeF ins outs witnesses txFee' anyProtocolUpdate anyVote =
   shelleyBasedEraConstraints sbeF $ do
     tx <- case anyProtocolUpdate of
-      ShelleyToBabbageProtocolUpdate shelleyToBabbageEra updateProposal -> do
+      ProtocolUpdate shelleyToBabbageEra updateProposal -> do
         let sbe = shelleyToBabbageEraToShelleyBasedEra shelleyToBabbageEra
 
         ledgerPParamsUpdate <- toLedgerUpdate sbe updateProposal
@@ -83,7 +83,7 @@ createCompatibleSignedTx sbeF ins outs witnesses txFee' anyProtocolUpdate anyVot
             finalTx = L.mkBasicTx txbody & L.witsTxL .~ shelleyBasedEraConstraints sbe allShelleyToBabbageWitnesses
 
         return $ ShelleyTx sbe finalTx
-      ConwayEraOnwardsProtocolUpdate conwayOnwards proposalProcedures -> do
+      ProposalProcedures conwayOnwards proposalProcedures -> do
         let sbe = conwayEraOnwardsToShelleyBasedEra conwayOnwards
             proposals = convProposalProcedures proposalProcedures
             apiScriptWitnesses = scriptWitnessesProposing proposalProcedures