diff --git a/cardano-api/internal/Cardano/Api/Tx/Compatible.hs b/cardano-api/internal/Cardano/Api/Tx/Compatible.hs index 585436a7e8..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 @@ -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,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]