From a4e466d79b240fcdaf97c02327c2960417cdbcea Mon Sep 17 00:00:00 2001 From: John Ky Date: Thu, 24 Aug 2023 23:59:56 +1000 Subject: [PATCH 1/3] Delete TxVotes and use VotingProcedures instead --- cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs | 34 +++------- cardano-api/internal/Cardano/Api/Feature.hs | 4 ++ .../Api/Governance/Actions/VotingProcedure.hs | 18 +----- cardano-api/internal/Cardano/Api/TxBody.hs | 62 +++++++------------ cardano-api/src/Cardano/Api.hs | 2 - cardano-api/src/Cardano/Api/Shelley.hs | 1 - 6 files changed, 36 insertions(+), 85 deletions(-) diff --git a/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs b/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs index 06ede3f88c..234cdbe02e 100644 --- a/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs +++ b/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs @@ -148,7 +148,6 @@ import qualified Data.ByteString.Short as SBS import Data.Coerce import Data.Int (Int64) import Data.Map.Strict (Map) -import qualified Data.Map.Strict as Map import Data.Maybe import Data.Ratio (Ratio, (%)) import Data.String @@ -672,7 +671,7 @@ genTxBodyContent era = do txMintValue <- genTxMintValue era txScriptValidity <- genTxScriptValidity era txGovernanceActions <- genTxGovernanceActions era - txVotes <- genTxVotes era + txVotes <- genMaybeFeaturedInEra genVotingProcedures era pure $ TxBodyContent { Api.txIns , Api.txInsCollateral @@ -750,12 +749,12 @@ genFeaturedInEra witness gen = genMaybeFeaturedInEra :: () => FeatureInEra feature => Alternative f - => f a + => (feature era -> f a) -> CardanoEra era -> f (Maybe (Featured feature era a)) -genMaybeFeaturedInEra gen = - featureInEra (pure Nothing) $ \witness -> - pure Nothing <|> fmap Just (genFeaturedInEra witness gen) +genMaybeFeaturedInEra f = + featureInEra (pure Nothing) $ \w -> + pure Nothing <|> fmap Just (genFeaturedInEra w (f w)) genTxScriptValidity :: CardanoEra era -> Gen (TxScriptValidity era) genTxScriptValidity era = case txScriptValiditySupportedInCardanoEra era of @@ -1123,22 +1122,7 @@ genTxGovernanceActions era = fromMaybe (pure TxGovernanceActionsNone) $ do genProposal = \case ConwayEraOnwardsConway -> fmap Proposal Q.arbitrary -genTxVotes :: CardanoEra era -> Gen (TxVotes era) -genTxVotes era = fromMaybe (pure TxVotesNone) $ do - w <- featureInEra Nothing Just era - let votes = Gen.list (Range.constant 0 10) $ genVote w - pure $ TxVotes w . Map.fromList <$> votes - where - genVote - :: ConwayEraOnwards era - -> Gen ( (Voter era, GovernanceActionId era) - , VotingProcedure era - ) - genVote w = - conwayEraOnwardsConstraints w $ - (,) - <$> ((,) - <$> (fromVoterRole (conwayEraOnwardsToShelleyBasedEra w) <$> Q.arbitrary) - <*> (GovernanceActionId <$> Q.arbitrary) - ) - <*> (VotingProcedure <$> Q.arbitrary) +genVotingProcedures :: ConwayEraOnwards era -> Gen (VotingProcedures era) +genVotingProcedures w = + conwayEraOnwardsConstraints w + $ VotingProcedures <$> Q.arbitrary diff --git a/cardano-api/internal/Cardano/Api/Feature.hs b/cardano-api/internal/Cardano/Api/Feature.hs index 85094928e1..27961dfd0e 100644 --- a/cardano-api/internal/Cardano/Api/Feature.hs +++ b/cardano-api/internal/Cardano/Api/Feature.hs @@ -7,6 +7,7 @@ module Cardano.Api.Feature ( Featured (..) + , unFeatured , asFeaturedInEra , asFeaturedInShelleyBasedEra ) where @@ -28,6 +29,9 @@ deriving instance (Show a, Show (feature era)) => Show (Featured feature era a) instance Functor (Featured feature era) where fmap f (Featured feature a) = Featured feature (f a) +unFeatured :: Featured feature era a -> a +unFeatured (Featured _ a) = a + -- | Attempt to construct a 'FeatureValue' from a value and era. -- If the feature is not supported in the era, then 'NoFeatureValue' is returned. asFeaturedInEra :: () diff --git a/cardano-api/internal/Cardano/Api/Governance/Actions/VotingProcedure.hs b/cardano-api/internal/Cardano/Api/Governance/Actions/VotingProcedure.hs index 19b83f96e3..13c3334282 100644 --- a/cardano-api/internal/Cardano/Api/Governance/Actions/VotingProcedure.hs +++ b/cardano-api/internal/Cardano/Api/Governance/Actions/VotingProcedure.hs @@ -20,7 +20,6 @@ module Cardano.Api.Governance.Actions.VotingProcedure where import Cardano.Api.Address import Cardano.Api.Eras.Constraints import Cardano.Api.Eras.Core -import Cardano.Api.Feature.ConwayEraOnwards (ConwayEraOnwards) import Cardano.Api.Governance.Actions.ProposalProcedure import Cardano.Api.HasTypeProxy import Cardano.Api.Keys.Shelley @@ -38,26 +37,11 @@ import Cardano.Ledger.Crypto (StandardCrypto) import Cardano.Ledger.Keys (HasKeyRole (..), KeyRole (DRepRole)) import Data.ByteString.Lazy (ByteString) -import qualified Data.Map.Strict as Map +import qualified Data.Map as Map import Data.Text (Text) import qualified Data.Text.Encoding as Text import GHC.Generics --- | A representation of whether the era supports tx voting on governance actions. --- --- The Conway and subsequent eras support tx voting on governance actions. --- -data TxVotes era where - TxVotesNone :: TxVotes era - - TxVotes - :: ConwayEraOnwards era - -> Map.Map (Voter era, GovernanceActionId era) (VotingProcedure era) - -> TxVotes era - -deriving instance Show (TxVotes era) -deriving instance Eq (TxVotes era) - newtype GovernanceActionId era = GovernanceActionId { unGovernanceActionId :: Ledger.GovActionId (EraCrypto (ShelleyLedgerEra era)) } diff --git a/cardano-api/internal/Cardano/Api/TxBody.hs b/cardano-api/internal/Cardano/Api/TxBody.hs index 2d5018eef0..cb3eb4f6ff 100644 --- a/cardano-api/internal/Cardano/Api/TxBody.hs +++ b/cardano-api/internal/Cardano/Api/TxBody.hs @@ -190,6 +190,7 @@ import Cardano.Api.Convenience.Constraints import Cardano.Api.EraCast import Cardano.Api.Eras import Cardano.Api.Error +import Cardano.Api.Feature import Cardano.Api.Feature.ConwayEraOnwards import Cardano.Api.Governance.Actions.ProposalProcedure import Cardano.Api.Governance.Actions.VotingProcedure @@ -1758,7 +1759,7 @@ data TxBodyContent build era = txMintValue :: TxMintValue build era, txScriptValidity :: TxScriptValidity era, txGovernanceActions :: TxGovernanceActions era, - txVotes :: TxVotes era + txVotes :: Maybe (Featured ConwayEraOnwards era (VotingProcedures era)) } deriving (Eq, Show) @@ -1782,7 +1783,7 @@ defaultTxBodyContent = TxBodyContent , txMintValue = TxMintNone , txScriptValidity = TxScriptValidityNone , txGovernanceActions = TxGovernanceActionsNone - , txVotes = TxVotesNone + , txVotes = Nothing } setTxIns :: TxIns build era -> TxBodyContent build era -> TxBodyContent build era @@ -2718,8 +2719,8 @@ fromLedgerTxBody sbe scriptValidity body scriptdata mAux = , txMetadata , txAuxScripts , txScriptValidity = scriptValidity - , txGovernanceActions = fromLedgerProposalProcedure sbe body - , txVotes = fromLedgerTxVotes sbe body + , txGovernanceActions = fromLedgerProposalProcedure sbe body + , txVotes = fromLedgerVotingProcedures sbe body } where (txMetadata, txAuxScripts) = fromLedgerTxAuxiliaryData sbe mAux @@ -2743,24 +2744,20 @@ fromLedgerProposalProcedure sbe body = $ toList $ body_ ^. L.proposalProceduresTxBodyL -fromLedgerTxVotes :: ShelleyBasedEra era -> Ledger.TxBody (ShelleyLedgerEra era) -> TxVotes era -fromLedgerTxVotes sbe body = - case featureInShelleyBasedEra Nothing Just sbe of - Nothing -> TxVotesNone - Just w -> getVotes w body - where - getVotes :: ConwayEraOnwards era - -> Ledger.TxBody (ShelleyLedgerEra era) - -> TxVotes era - getVotes w body_ = +fromLedgerVotingProcedures :: () + => ShelleyBasedEra era + -> Ledger.TxBody (ShelleyLedgerEra era) + -> Maybe (Featured ConwayEraOnwards era (VotingProcedures era)) +fromLedgerVotingProcedures sbe body = + featureInShelleyBasedEra + Nothing + (\w -> conwayEraOnwardsConstraints w - $ TxVotes w - $ foldMap (\(voter, innerMap) -> - Map.mapKeys (\govActId -> (fromVoterRole (conwayEraOnwardsToShelleyBasedEra w) voter, GovernanceActionId govActId)) - $ Map.map VotingProcedure innerMap - ) - $ (Map.toList . Gov.unVotingProcedures) - $ body_ ^. L.votingProceduresTxBodyL + $ Just + $ Featured w + $ VotingProcedures + $ body ^. L.votingProceduresTxBodyL) + sbe fromLedgerTxIns :: forall era. @@ -3430,7 +3427,7 @@ getByronTxBodyContent (Annotated Byron.UnsafeTx{txInputs, txOutputs} _) = , txMintValue = TxMintNone , txScriptValidity = TxScriptValidityNone , txGovernanceActions = TxGovernanceActionsNone - , txVotes = TxVotesNone + , txVotes = Nothing } convTxIns :: TxIns BuildTx era -> Set (L.TxIn StandardCrypto) @@ -3611,21 +3608,6 @@ convGovActions :: TxGovernanceActions era -> Seq.StrictSeq (Gov.ProposalProcedur convGovActions TxGovernanceActionsNone = Seq.empty convGovActions (TxGovernanceActions _ govActions) = Seq.fromList $ fmap unProposal govActions -convVotes - :: (Ledger.EraCrypto (ShelleyLedgerEra era) ~ StandardCrypto) - => ShelleyBasedEra era - -> TxVotes era - -> Gov.VotingProcedures (ShelleyLedgerEra era) -convVotes sbe = Gov.VotingProcedures . \case - TxVotesNone -> Map.empty - TxVotes _ votes -> - let combine = error "convVotes: impossible! `votes' contained the same key multiple times" - in - Map.fromListWith (Map.unionWith combine) - [ (toVoterRole sbe voter, unGovernanceActionId govActId `Map.singleton` unVotingProcedure vp) - | ((voter, govActId), vp) <- Map.toList votes - ] - guardShelleyTxInsOverflow :: [TxIn] -> Either TxBodyError () guardShelleyTxInsOverflow txIns = do for_ txIns $ \txin@(TxIn _ (TxIx txix)) -> @@ -3654,8 +3636,8 @@ mkCommonTxBody sbe txIns txOuts txFee txWithdrawals txAuxData = & L.auxDataHashTxBodyL .~ maybe SNothing (SJust . Ledger.hashTxAuxData) txAuxData -makeShelleyTransactionBody - :: ShelleyBasedEra era +makeShelleyTransactionBody :: forall era. () + => ShelleyBasedEra era -> TxBodyContent BuildTx era -> Either TxBodyError (TxBody era) makeShelleyTransactionBody sbe@ShelleyBasedEraShelley @@ -3994,7 +3976,7 @@ makeShelleyTransactionBody sbe@ShelleyBasedEraConway & L.reqSignerHashesTxBodyL .~ convExtraKeyWitnesses txExtraKeyWits & L.mintTxBodyL .~ convMintValue txMintValue & L.scriptIntegrityHashTxBodyL .~ scriptIntegrityHash - & L.votingProceduresTxBodyL .~ convVotes sbe txVotes + & L.votingProceduresTxBodyL .~ unVotingProcedures @era (maybe mempty unFeatured txVotes) & L.proposalProceduresTxBodyL .~ convGovActions txGovernanceActions -- TODO Conway: support optional network id in TxBodyContent -- & L.networkIdTxBodyL .~ SNothing diff --git a/cardano-api/src/Cardano/Api.hs b/cardano-api/src/Cardano/Api.hs index 09d0326d10..938f86746e 100644 --- a/cardano-api/src/Cardano/Api.hs +++ b/cardano-api/src/Cardano/Api.hs @@ -285,7 +285,6 @@ module Cardano.Api ( TxCertificates(..), TxUpdateProposal(..), TxMintValue(..), - TxVotes(..), TxGovernanceActions(..), VotingEntry(..), @@ -970,7 +969,6 @@ import Cardano.Api.Genesis import Cardano.Api.GenesisParameters import Cardano.Api.Governance.Actions.ProposalProcedure import Cardano.Api.Governance.Actions.VotingEntry -import Cardano.Api.Governance.Actions.VotingProcedure import Cardano.Api.Hash import Cardano.Api.HasTypeProxy import Cardano.Api.InMode diff --git a/cardano-api/src/Cardano/Api/Shelley.hs b/cardano-api/src/Cardano/Api/Shelley.hs index 288903cdd5..d5a00fc0bc 100644 --- a/cardano-api/src/Cardano/Api/Shelley.hs +++ b/cardano-api/src/Cardano/Api/Shelley.hs @@ -256,7 +256,6 @@ module Cardano.Api.Shelley GovernanceActionId(..), Proposal(..), TxGovernanceActions(..), - TxVotes(..), VotingProcedure(..), VotingProcedures(..), GovernancePoll(..), From 2011e2e5c480e6831a3c376b322e7156365ca795 Mon Sep 17 00:00:00 2001 From: John Ky Date: Fri, 25 Aug 2023 00:08:30 +1000 Subject: [PATCH 2/3] Delete VotingEntry --- cardano-api/cardano-api.cabal | 1 - .../Api/Governance/Actions/VotingEntry.hs | 65 ------------------- cardano-api/src/Cardano/Api.hs | 2 - 3 files changed, 68 deletions(-) delete mode 100644 cardano-api/internal/Cardano/Api/Governance/Actions/VotingEntry.hs diff --git a/cardano-api/cardano-api.cabal b/cardano-api/cardano-api.cabal index 341e8ef27a..b2d554855e 100644 --- a/cardano-api/cardano-api.cabal +++ b/cardano-api/cardano-api.cabal @@ -67,7 +67,6 @@ library internal Cardano.Api.Genesis Cardano.Api.GenesisParameters Cardano.Api.Governance.Actions.ProposalProcedure - Cardano.Api.Governance.Actions.VotingEntry Cardano.Api.Governance.Actions.VotingProcedure Cardano.Api.Governance.Poll Cardano.Api.Hash diff --git a/cardano-api/internal/Cardano/Api/Governance/Actions/VotingEntry.hs b/cardano-api/internal/Cardano/Api/Governance/Actions/VotingEntry.hs deleted file mode 100644 index 6a83e9031a..0000000000 --- a/cardano-api/internal/Cardano/Api/Governance/Actions/VotingEntry.hs +++ /dev/null @@ -1,65 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} - -module Cardano.Api.Governance.Actions.VotingEntry where - -import Cardano.Api.Address -import Cardano.Api.Eras -import Cardano.Api.Governance.Actions.VotingProcedure -import Cardano.Api.HasTypeProxy -import Cardano.Api.SerialiseCBOR (FromCBOR (fromCBOR), SerialiseAsCBOR (..), - ToCBOR (toCBOR)) -import Cardano.Api.SerialiseTextEnvelope - -import qualified Cardano.Binary as CBOR - --- TODO Conway: Ledger needs to provide this triplet as a type. Once that is done, --- this needs to be converted to a newtype wrapper around that type. This will allow --- us to delegate the ToCBOR and FromCBOR instances to the ledger where it can be --- specified in the cddl spec. -data VotingEntry era = VotingEntry - { votingEntryVoter :: Voter era - , votingEntryGovActionId :: GovernanceActionId era - , votingEntryVotingProcedure :: VotingProcedure era - } deriving (Show, Eq) - -instance IsShelleyBasedEra era => ToCBOR (VotingEntry era) where - toCBOR = \case - VotingEntry a b c -> - CBOR.encodeListLen 3 - <> toCBOR a - <> toCBOR b - <> toCBOR c - - encodedSizeExpr size _ = - 1 - + size (Proxy @(Voter era)) - + size (Proxy @(GovernanceActionId era)) - + size (Proxy @(VotingProcedure era)) - -instance IsShelleyBasedEra era => FromCBOR (VotingEntry era) where - fromCBOR = do - CBOR.decodeListLenOf 3 - !votingEntryVoter <- fromCBOR - !votingEntryGovActionId <- fromCBOR - !votingEntryVotingProcedure <- fromCBOR - return VotingEntry - { votingEntryVoter - , votingEntryGovActionId - , votingEntryVotingProcedure - } - -instance IsShelleyBasedEra era => SerialiseAsCBOR (VotingEntry era) where - serialiseToCBOR = shelleyBasedEraConstraints (shelleyBasedEra @era) CBOR.serialize' - deserialiseFromCBOR _proxy = shelleyBasedEraConstraints (shelleyBasedEra @era) CBOR.decodeFull' - -instance IsShelleyBasedEra era => HasTextEnvelope (VotingEntry era) where - textEnvelopeType _ = "Governance voting entry" - -instance HasTypeProxy era => HasTypeProxy (VotingEntry era) where - data AsType (VotingEntry era) = AsVotingEntry - proxyToAsType _ = AsVotingEntry diff --git a/cardano-api/src/Cardano/Api.hs b/cardano-api/src/Cardano/Api.hs index 938f86746e..aff0c23b46 100644 --- a/cardano-api/src/Cardano/Api.hs +++ b/cardano-api/src/Cardano/Api.hs @@ -286,7 +286,6 @@ module Cardano.Api ( TxUpdateProposal(..), TxMintValue(..), TxGovernanceActions(..), - VotingEntry(..), -- ** Building vs viewing transactions BuildTxWith(..), @@ -968,7 +967,6 @@ import Cardano.Api.Fees import Cardano.Api.Genesis import Cardano.Api.GenesisParameters import Cardano.Api.Governance.Actions.ProposalProcedure -import Cardano.Api.Governance.Actions.VotingEntry import Cardano.Api.Hash import Cardano.Api.HasTypeProxy import Cardano.Api.InMode From 7b5d25e90902bf93bb53a166d7cde0aff5b24f8f Mon Sep 17 00:00:00 2001 From: John Ky Date: Fri, 25 Aug 2023 23:56:43 +1000 Subject: [PATCH 3/3] Rename txVotes in TxBodyContents to txVotingProcedures to match ledger --- cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs | 4 ++-- cardano-api/internal/Cardano/Api/TxBody.hs | 12 ++++++------ 2 files changed, 8 insertions(+), 8 deletions(-) diff --git a/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs b/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs index 234cdbe02e..20aea13a4c 100644 --- a/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs +++ b/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs @@ -671,7 +671,7 @@ genTxBodyContent era = do txMintValue <- genTxMintValue era txScriptValidity <- genTxScriptValidity era txGovernanceActions <- genTxGovernanceActions era - txVotes <- genMaybeFeaturedInEra genVotingProcedures era + txVotingProcedures <- genMaybeFeaturedInEra genVotingProcedures era pure $ TxBodyContent { Api.txIns , Api.txInsCollateral @@ -691,7 +691,7 @@ genTxBodyContent era = do , Api.txMintValue , Api.txScriptValidity , Api.txGovernanceActions - , Api.txVotes + , Api.txVotingProcedures } genTxInsCollateral :: CardanoEra era -> Gen (TxInsCollateral era) diff --git a/cardano-api/internal/Cardano/Api/TxBody.hs b/cardano-api/internal/Cardano/Api/TxBody.hs index cb3eb4f6ff..1e3f080be1 100644 --- a/cardano-api/internal/Cardano/Api/TxBody.hs +++ b/cardano-api/internal/Cardano/Api/TxBody.hs @@ -1759,7 +1759,7 @@ data TxBodyContent build era = txMintValue :: TxMintValue build era, txScriptValidity :: TxScriptValidity era, txGovernanceActions :: TxGovernanceActions era, - txVotes :: Maybe (Featured ConwayEraOnwards era (VotingProcedures era)) + txVotingProcedures :: Maybe (Featured ConwayEraOnwards era (VotingProcedures era)) } deriving (Eq, Show) @@ -1783,7 +1783,7 @@ defaultTxBodyContent = TxBodyContent , txMintValue = TxMintNone , txScriptValidity = TxScriptValidityNone , txGovernanceActions = TxGovernanceActionsNone - , txVotes = Nothing + , txVotingProcedures = Nothing } setTxIns :: TxIns build era -> TxBodyContent build era -> TxBodyContent build era @@ -2720,7 +2720,7 @@ fromLedgerTxBody sbe scriptValidity body scriptdata mAux = , txAuxScripts , txScriptValidity = scriptValidity , txGovernanceActions = fromLedgerProposalProcedure sbe body - , txVotes = fromLedgerVotingProcedures sbe body + , txVotingProcedures = fromLedgerVotingProcedures sbe body } where (txMetadata, txAuxScripts) = fromLedgerTxAuxiliaryData sbe mAux @@ -3427,7 +3427,7 @@ getByronTxBodyContent (Annotated Byron.UnsafeTx{txInputs, txOutputs} _) = , txMintValue = TxMintNone , txScriptValidity = TxScriptValidityNone , txGovernanceActions = TxGovernanceActionsNone - , txVotes = Nothing + , txVotingProcedures = Nothing } convTxIns :: TxIns BuildTx era -> Set (L.TxIn StandardCrypto) @@ -3955,7 +3955,7 @@ makeShelleyTransactionBody sbe@ShelleyBasedEraConway txCertificates, txMintValue, txScriptValidity, - txVotes, + txVotingProcedures, txGovernanceActions } = do @@ -3976,7 +3976,7 @@ makeShelleyTransactionBody sbe@ShelleyBasedEraConway & L.reqSignerHashesTxBodyL .~ convExtraKeyWitnesses txExtraKeyWits & L.mintTxBodyL .~ convMintValue txMintValue & L.scriptIntegrityHashTxBodyL .~ scriptIntegrityHash - & L.votingProceduresTxBodyL .~ unVotingProcedures @era (maybe mempty unFeatured txVotes) + & L.votingProceduresTxBodyL .~ unVotingProcedures @era (maybe emptyVotingProcedures unFeatured txVotingProcedures) & L.proposalProceduresTxBodyL .~ convGovActions txGovernanceActions -- TODO Conway: support optional network id in TxBodyContent -- & L.networkIdTxBodyL .~ SNothing