Merge pull request #648 from IntersectMBO/jordan/add-voting-to-simple…

…-tx-interface Add voting to simple tx interface
IntersectMBO · Oct 3, 2024 · 7fe253e · 7fe253e
2 parents b5e8819 + 237063f
commit 7fe253e
Showing 1 changed file with 32 additions and 7 deletions.
diff --git a/cardano-api/internal/Cardano/Api/Tx/Compatible.hs b/cardano-api/internal/Cardano/Api/Tx/Compatible.hs
@@ -31,18 +31,25 @@ 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
   NoPParamsUpdate
     :: 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,11 +59,12 @@ createCompatibleSignedTx
   -> Lovelace
   -- ^ Fee
   -> AnyProtocolUpdate era
+  -> AnyVote era
   -> Either ProtocolParametersConversionError (Tx era)
-createCompatibleSignedTx sbeF ins outs witnesses txFee' anyProtocolUpdate =
-  shelleyBasedEraConstraints sbeF $
-    case anyProtocolUpdate of
-      ShelleyToBabbageProtocolUpdate shelleyToBabbageEra updateProposal -> do
+createCompatibleSignedTx sbeF ins outs witnesses txFee' anyProtocolUpdate anyVote =
+  shelleyBasedEraConstraints sbeF $ do
+    tx <- case anyProtocolUpdate of
+      ProtocolUpdate shelleyToBabbageEra updateProposal -> do
         let sbe = shelleyToBabbageEraToShelleyBasedEra shelleyToBabbageEra
 
         ledgerPParamsUpdate <- toLedgerUpdate sbe updateProposal
@@ -75,7 +83,7 @@ createCompatibleSignedTx sbeF ins outs witnesses txFee' anyProtocolUpdate =
             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
@@ -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]