Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Add voting to simple tx interface #648

Merged
merged 2 commits into from
Oct 3, 2024
Merged

Add voting to simple tx interface #648

Changes from all commits
Commits
Show all changes
2 commits
Select commit Hold shift + click to select a range
079aaf2
Enable votes in createCompatibleSignedTx
Jimbo4350 Oct 3, 2024
237063f
Rename constructors in AnyProtocolUpdate
Jimbo4350 Oct 3, 2024
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
39 changes: 32 additions & 7 deletions cardano-api/internal/Cardano/Api/Tx/Compatible.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand All @@ -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
Expand All @@ -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
Expand All @@ -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]

Expand Down
Loading