From 18706ab846f65b171a6304fa5d080ebc14b12f45 Mon Sep 17 00:00:00 2001 From: Mateusz Galazyn Date: Tue, 6 Aug 2024 16:24:24 +0200 Subject: [PATCH 1/3] Fix missing script proposals in transaction building --- cardano-api/cardano-api.cabal | 1 + cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs | 92 +++++--- cardano-api/internal/Cardano/Api/Feature.hs | 12 ++ cardano-api/internal/Cardano/Api/Fees.hs | 63 +++--- .../Governance/Actions/ProposalProcedure.hs | 3 + .../Api/Governance/Actions/VotingProcedure.hs | 2 + cardano-api/internal/Cardano/Api/Orphans.hs | 6 + cardano-api/internal/Cardano/Api/Tx/Body.hs | 203 ++++++++++++++---- cardano-api/src/Cardano/Api.hs | 8 +- .../Test/Cardano/Api/Typed/TxBody.hs | 54 +++-- 10 files changed, 325 insertions(+), 119 deletions(-) diff --git a/cardano-api/cardano-api.cabal b/cardano-api/cardano-api.cabal index 3e46a927fc..4721fe7db2 100644 --- a/cardano-api/cardano-api.cabal +++ b/cardano-api/cardano-api.cabal @@ -196,6 +196,7 @@ library internal mtl, network, optparse-applicative-fork, + ordered-containers, ouroboros-consensus ^>=0.20, ouroboros-consensus-cardano ^>=0.18, ouroboros-consensus-diffusion ^>=0.17, diff --git a/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs b/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs index 839748f4d2..2370757dba 100644 --- a/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs +++ b/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs @@ -149,17 +149,17 @@ import qualified Cardano.Ledger.Core as Ledger import Cardano.Ledger.SafeHash (unsafeMakeSafeHash) import Control.Applicative (Alternative (..), optional) +import Control.Monad import Data.ByteString (ByteString) import qualified Data.ByteString as BS import qualified Data.ByteString.Short as SBS import Data.Coerce import Data.Int (Int64) import Data.Maybe -import Data.OSet.Strict (OSet) -import qualified Data.OSet.Strict as OSet import Data.Ratio (Ratio, (%)) import Data.String import Data.Word (Word16, Word32, Word64) +import GHC.Exts (IsList(..)) import Numeric.Natural (Natural) import Test.Gen.Cardano.Api.Era @@ -318,8 +318,7 @@ genScriptInEra era = Gen.choice [ ScriptInEra langInEra <$> genScript lang | AnyScriptLanguage lang <- [minBound .. maxBound] - , -- TODO: scriptLanguageSupportedInEra should be parameterized on ShelleyBasedEra - Just langInEra <- [scriptLanguageSupportedInEra era lang] + , Just langInEra <- [scriptLanguageSupportedInEra era lang] ] genScriptHash :: Gen ScriptHash @@ -588,7 +587,7 @@ genTxAuxScripts era = (genScriptInEra (allegraEraOnwardsToShelleyBasedEra w)) ) -genTxWithdrawals :: CardanoEra era -> Gen (TxWithdrawals BuildTx era) +genTxWithdrawals :: CardanoEra era -> Gen (TxWithdrawals build era) genTxWithdrawals = inEonForEra (pure TxWithdrawalsNone) @@ -648,12 +647,12 @@ genTxMintValue :: CardanoEra era -> Gen (TxMintValue BuildTx era) genTxMintValue = inEonForEra (pure TxMintNone) - ( \supported -> - Gen.choice - [ pure TxMintNone - , TxMintValue supported <$> genValueForMinting supported <*> return (BuildTxWith mempty) - ] - ) + $ \supported -> + Gen.choice + [ pure TxMintNone + -- TODO write a generator for the last parameter of 'TxMintValue' constructor + , TxMintValue supported <$> genValueForMinting supported <*> return (pure mempty) + ] genTxBodyContent :: ShelleyBasedEra era -> Gen (TxBodyContent BuildTx era) genTxBodyContent sbe = do @@ -680,7 +679,7 @@ genTxBodyContent sbe = do txScriptValidity <- genTxScriptValidity era txProposalProcedures <- genMaybeFeaturedInEra genProposals era txVotingProcedures <- genMaybeFeaturedInEra genVotingProcedures era - txCurrentTreasuryValue <- genMaybeFeaturedInEra genCurrentTreasuryValue era + txCurrentTreasuryValue <- genMaybeFeaturedInEra (Gen.maybe . genCurrentTreasuryValue) era txTreasuryDonation <- genMaybeFeaturedInEra genTreasuryDonation era pure $ TxBodyContent @@ -719,7 +718,7 @@ genTxInsCollateral = ] ) -genTxInsReference :: CardanoEra era -> Gen (TxInsReference BuildTx era) +genTxInsReference :: CardanoEra era -> Gen (TxInsReference era) genTxInsReference = caseByronToAlonzoOrBabbageEraOnwards (const (pure TxInsReferenceNone)) @@ -1123,34 +1122,61 @@ genGovernancePollAnswer = genGovernancePollHash = GovernancePollHash . mkDummyHash <$> Gen.int (Range.linear 0 10) --- TODO: Left off here. Fix this then get back to incorporating proposal procedure --- script witnesses in the api and then propagate to the cli -genProposals :: ConwayEraOnwards era -> Gen (TxProposalProcedures BuildTx era) -genProposals w = - conwayEraOnwardsConstraints w $ - TxProposalProcedures - <$> genTxProposalsOSet w - <*> return (BuildTxWith mempty) - -genTxProposalsOSet - :: ConwayEraOnwards era - -> Gen (OSet (L.ProposalProcedure (ShelleyLedgerEra era))) -genTxProposalsOSet w = - conwayEraOnwardsConstraints w $ - OSet.fromFoldable <$> Gen.list (Range.constant 1 10) (genProposal w) +genProposals :: Applicative (BuildTxWith build) + => ConwayEraOnwards era + -> Gen (TxProposalProcedures build era) +genProposals w = conwayEraOnwardsConstraints w $ do + proposals <- fmap Proposal <$> Gen.list (Range.constant 0 10) (genProposal w) + let sbe = conwayEraOnwardsToShelleyBasedEra w + proposalsWithWitnesses <- fmap fromList . forM proposals $ \proposal -> + (proposal,) <$> Gen.maybe (genScriptWitnessForStake sbe) + pure $ mkTxProposalProcedures proposalsWithWitnesses genProposal :: ConwayEraOnwards era -> Gen (L.ProposalProcedure (ShelleyLedgerEra era)) genProposal w = conwayEraOnwardsTestConstraints w Q.arbitrary --- TODO: Generate map of script witnesses -genVotingProcedures :: ConwayEraOnwards era -> Gen (Api.TxVotingProcedures BuildTx era) -genVotingProcedures w = - conwayEraOnwardsConstraints w $ - Api.TxVotingProcedures <$> Q.arbitrary <*> return (BuildTxWith mempty) +genVotingProcedures :: Applicative (BuildTxWith build) + => ConwayEraOnwards era + -> Gen (Api.TxVotingProcedures build era) +genVotingProcedures w = conwayEraOnwardsConstraints w $ do + voters <- Gen.list (Range.constant 0 10) Q.arbitrary + let sbe = conwayEraOnwardsToShelleyBasedEra w + votersWithWitnesses <- fmap fromList . forM voters $ \voter -> + (voter,) <$> genScriptWitnessForStake sbe + Api.TxVotingProcedures <$> Q.arbitrary <*> pure (pure votersWithWitnesses) genCurrentTreasuryValue :: ConwayEraOnwards era -> Gen L.Coin genCurrentTreasuryValue _era = Q.arbitrary genTreasuryDonation :: ConwayEraOnwards era -> Gen L.Coin genTreasuryDonation _era = Q.arbitrary + +-- | This generator does not generate a valid witness - just a random one. +genScriptWitnessForStake :: ShelleyBasedEra era -> Gen (Api.ScriptWitness WitCtxStake era) +genScriptWitnessForStake sbe = do + ScriptInEra scriptLangInEra script' <- genScriptInEra sbe + case script' of + SimpleScript simpleScript -> do + simpleScriptOrReferenceInput <- Gen.choice + [ pure $ SScript simpleScript + , SReferenceScript <$> genTxIn <*> Gen.maybe genScriptHash + ] + pure $ Api.SimpleScriptWitness scriptLangInEra simpleScriptOrReferenceInput + PlutusScript plutusScriptVersion' plutusScript -> do + plutusScriptOrReferenceInput <- Gen.choice + [ pure $ PScript plutusScript + , PReferenceScript <$> genTxIn <*> Gen.maybe genScriptHash + ] + scriptRedeemer <- genHashableScriptData + PlutusScriptWitness + scriptLangInEra + plutusScriptVersion' + plutusScriptOrReferenceInput + NoScriptDatumForStake + scriptRedeemer + <$> genExecutionUnits + + + + diff --git a/cardano-api/internal/Cardano/Api/Feature.hs b/cardano-api/internal/Cardano/Api/Feature.hs index c40265a92e..f2cf39aca3 100644 --- a/cardano-api/internal/Cardano/Api/Feature.hs +++ b/cardano-api/internal/Cardano/Api/Feature.hs @@ -6,6 +6,7 @@ module Cardano.Api.Feature ( Featured (..) + , mkFeatured , unFeatured , asFeaturedInEra , asFeaturedInShelleyBasedEra @@ -31,6 +32,17 @@ deriving instance (Show a, Show (eon era)) => Show (Featured eon era a) instance Functor (Featured eon era) where fmap f (Featured eon a) = Featured eon (f a) +-- | Create a Featured with automatic witness conjuring +mkFeatured + :: forall eon era a + . IsCardanoEra era + => Eon eon + => a + -- ^ a value featured in eon + -> Maybe (Featured eon era a) + -- ^ 'Just' if era is in eon +mkFeatured a = asFeaturedInEra a cardanoEra + unFeatured :: Featured eon era a -> a unFeatured (Featured _ a) = a diff --git a/cardano-api/internal/Cardano/Api/Fees.hs b/cardano-api/internal/Cardano/Api/Fees.hs index 032cabb100..e1870a07a3 100644 --- a/cardano-api/internal/Cardano/Api/Fees.hs +++ b/cardano-api/internal/Cardano/Api/Fees.hs @@ -56,6 +56,7 @@ import Cardano.Api.Eras.Case import Cardano.Api.Eras.Core import Cardano.Api.Error import Cardano.Api.Feature +import Cardano.Api.Governance.Actions.ProposalProcedure import qualified Cardano.Api.Ledger.Lens as A import Cardano.Api.Pretty import Cardano.Api.ProtocolParameters @@ -79,14 +80,15 @@ import qualified Cardano.Ledger.Plutus.Language as Plutus import qualified Ouroboros.Consensus.HardFork.History as Consensus import qualified PlutusLedgerApi.V1 as Plutus -import Control.Monad (forM_) +import Control.Monad import Data.Bifunctor (bimap, first, second) import Data.ByteString.Short (ShortByteString) import Data.Function ((&)) import qualified Data.List as List +import qualified Data.Map.Ordered as OMap import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map -import Data.Maybe (catMaybes, fromMaybe, maybeToList) +import Data.Maybe import qualified Data.OSet.Strict as OSet import Data.Ratio import Data.Set (Set) @@ -96,8 +98,6 @@ import qualified Data.Text as Text import GHC.Exts (IsList (..)) import Lens.Micro ((.~), (^.)) -{- HLINT ignore "Redundant return" -} - -- | Type synonym for logs returned by the ledger's @evalTxExUnitsWithLogs@ function. -- for scripts in transactions. type EvalTxExecutionUnitsLog = [Text] @@ -233,8 +233,9 @@ estimateBalancedTxBody let sbe = maryEraOnwardsToShelleyBasedEra w txbodycontent1 <- - first TxFeeEstimationScriptExecutionError $ - substituteExecutionUnits exUnitsMap txbodycontent + maryEraOnwardsConstraints w $ + first TxFeeEstimationScriptExecutionError $ + substituteExecutionUnits exUnitsMap txbodycontent -- Step 2. We need to calculate the current balance of the tx. The user -- must at least provide the total value of the UTxOs they intend to spend @@ -249,10 +250,10 @@ estimateBalancedTxBody proposalProcedures :: OSet.OSet (L.ProposalProcedure (ShelleyLedgerEra era)) proposalProcedures = - case unFeatured <$> txProposalProcedures txbodycontent1 of - Nothing -> OSet.empty - Just TxProposalProceduresNone -> OSet.empty - Just (TxProposalProcedures procedures _) -> procedures + maryEraOnwardsConstraints w $ + fromList $ + maybe [] (map (unProposal . fst) . toList) $ + (getProposalProcedures . unFeatured) =<< txProposalProcedures txbodycontent1 totalDeposits :: L.Coin totalDeposits = @@ -1392,7 +1393,8 @@ maybeDummyTotalCollAndCollReturnOutput sbe TxBodyContent{txInsCollateral, txRetu substituteExecutionUnits :: forall era - . Map ScriptWitnessIndex ExecutionUnits + . IsShelleyBasedEra era + => Map ScriptWitnessIndex ExecutionUnits -> TxBodyContent BuildTx era -> Either (TxBodyErrorAutoBalance era) (TxBodyContent BuildTx era) substituteExecutionUnits @@ -1570,30 +1572,29 @@ substituteExecutionUnits (Featured era (TxVotingProcedures vProcedures (BuildTxWith $ fromList substitutedExecutionUnits))) mapScriptWitnessesProposals - :: Maybe (Featured ConwayEraOnwards era (TxProposalProcedures build era)) + :: forall build + . Applicative (BuildTxWith build) + => Maybe (Featured ConwayEraOnwards era (TxProposalProcedures build era)) -> Either (TxBodyErrorAutoBalance era) (Maybe (Featured ConwayEraOnwards era (TxProposalProcedures build era))) mapScriptWitnessesProposals Nothing = return Nothing - mapScriptWitnessesProposals (Just (Featured _ TxProposalProceduresNone)) = return Nothing - mapScriptWitnessesProposals (Just (Featured _ (TxProposalProcedures _ ViewTx))) = return Nothing - mapScriptWitnessesProposals (Just (Featured era (TxProposalProcedures osetProposalProcedures (BuildTxWith sWitMap)))) = do - let eSubstitutedExecutionUnits = - [ (proposal, updatedWitness) - | let allProposalsList = toList osetProposalProcedures - , (proposal, scriptWitness) <- toList sWitMap - , index <- maybeToList $ List.elemIndex proposal allProposalsList - , let updatedWitness = substituteExecUnits (ScriptWitnessIndexProposing $ fromIntegral index) scriptWitness + mapScriptWitnessesProposals (Just (Featured era proposalProcedures)) = forM (getProposalProcedures proposalProcedures) $ \pp -> do + let substitutedExecutionUnits = + [ (proposal, mUpdatedWitness) + | (proposal, mScriptWitness) <- toList $ fmap (join . buildTxWithToMaybe) pp + , index <- maybeToList $ OMap.findIndex proposal pp + , let mUpdatedWitness = substituteExecUnits (ScriptWitnessIndexProposing $ fromIntegral index) <$> mScriptWitness ] + final <- fmap fromList . forM substitutedExecutionUnits $ \(p, meExecUnits) -> + case meExecUnits of + Nothing -> pure (p, Nothing) + Just eExecUnits -> do + -- TODO aggregate errors instead of shortcircuiting here + execUnits <- eExecUnits + pure (p, pure execUnits) - substitutedExecutionUnits <- traverseScriptWitnesses eSubstitutedExecutionUnits - - return $ - Just - ( Featured - era - (TxProposalProcedures osetProposalProcedures (BuildTxWith $ fromList substitutedExecutionUnits)) - ) + pure . Featured era $ mkTxProposalProcedures final mapScriptWitnessesMinting :: TxMintValue BuildTx era @@ -1622,8 +1623,8 @@ substituteExecutionUnits fromList final traverseScriptWitnesses - :: [(a, Either (TxBodyErrorAutoBalance era) (ScriptWitness ctx era))] - -> Either (TxBodyErrorAutoBalance era) [(a, ScriptWitness ctx era)] + :: [(a, Either l r)] + -> Either l [(a, r)] traverseScriptWitnesses = traverse (\(item, eScriptWitness) -> eScriptWitness >>= (\sWit -> Right (item, sWit))) diff --git a/cardano-api/internal/Cardano/Api/Governance/Actions/ProposalProcedure.hs b/cardano-api/internal/Cardano/Api/Governance/Actions/ProposalProcedure.hs index 6f4b202ae0..7a1f35bfea 100644 --- a/cardano-api/internal/Cardano/Api/Governance/Actions/ProposalProcedure.hs +++ b/cardano-api/internal/Cardano/Api/Governance/Actions/ProposalProcedure.hs @@ -155,6 +155,9 @@ instance IsShelleyBasedEra era => Show (Proposal era) where instance IsShelleyBasedEra era => Eq (Proposal era) where (Proposal pp1) == (Proposal pp2) = shelleyBasedEraConstraints (shelleyBasedEra @era) $ pp1 == pp2 +instance IsShelleyBasedEra era => Ord (Proposal era) where + compare (Proposal pp1) (Proposal pp2) = shelleyBasedEraConstraints (shelleyBasedEra @era) $ compare pp1 pp2 + instance IsShelleyBasedEra era => ToCBOR (Proposal era) where toCBOR (Proposal vp) = shelleyBasedEraConstraints (shelleyBasedEra @era) $ Shelley.toEraCBOR @Conway.Conway vp diff --git a/cardano-api/internal/Cardano/Api/Governance/Actions/VotingProcedure.hs b/cardano-api/internal/Cardano/Api/Governance/Actions/VotingProcedure.hs index dba360230a..62bde7f0e9 100644 --- a/cardano-api/internal/Cardano/Api/Governance/Actions/VotingProcedure.hs +++ b/cardano-api/internal/Cardano/Api/Governance/Actions/VotingProcedure.hs @@ -123,6 +123,8 @@ newtype VotingProcedures era = VotingProcedures deriving instance Eq (VotingProcedures era) +deriving instance Ord (VotingProcedures era) + deriving instance Generic (VotingProcedures era) deriving instance Show (VotingProcedures era) diff --git a/cardano-api/internal/Cardano/Api/Orphans.hs b/cardano-api/internal/Cardano/Api/Orphans.hs index a52f6840d0..905debfce7 100644 --- a/cardano-api/internal/Cardano/Api/Orphans.hs +++ b/cardano-api/internal/Cardano/Api/Orphans.hs @@ -575,6 +575,12 @@ parsePlutusParamName t = deriving instance Show V2.ParamName +-- Required instance, to be able to use the type as the map key +-- TODO upstream to cardano-ledger +deriving instance Ord (L.VotingProcedures ledgerera) + +deriving instance Ord (L.VotingProcedure ledgerera) + -- TODO upstream to cardano-ledger instance IsList (ListMap k a) where type Item (ListMap k a) = (k, a) diff --git a/cardano-api/internal/Cardano/Api/Tx/Body.hs b/cardano-api/internal/Cardano/Api/Tx/Body.hs index 3ef72fe1b8..2188f14751 100644 --- a/cardano-api/internal/Cardano/Api/Tx/Body.hs +++ b/cardano-api/internal/Cardano/Api/Tx/Body.hs @@ -11,13 +11,12 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE ViewPatterns #-} -{- HLINT ignore "Redundant bracket" -} - -- | Transaction bodies module Cardano.Api.Tx.Body ( parseTxId @@ -114,12 +113,16 @@ module Cardano.Api.Tx.Body , TxUpdateProposal (..) , TxMintValue (..) , TxVotingProcedures (..) - , TxProposalProcedures (..) + , mkTxVotingProcedures + , TxProposalProcedures (TxProposalProceduresNone) + , mkTxProposalProcedures + , getProposalProcedures -- ** Building vs viewing transactions , BuildTxWith (..) , BuildTx , ViewTx + , buildTxWithToMaybe -- * Inspecting 'ScriptWitness'es , AnyScriptWitness (..) @@ -177,6 +180,8 @@ import Cardano.Api.Eras.Case import Cardano.Api.Eras.Core import Cardano.Api.Error (Error (..), displayError) import Cardano.Api.Feature +import Cardano.Api.Governance.Actions.ProposalProcedure +import Cardano.Api.Governance.Actions.VotingProcedure import Cardano.Api.Hash import Cardano.Api.Keys.Byron import Cardano.Api.Keys.Shelley @@ -246,6 +251,8 @@ import Data.Functor (($>)) import Data.List (sortBy) import qualified Data.List as List import qualified Data.List.NonEmpty as NonEmpty +import Data.Map.Ordered.Strict (OMap) +import qualified Data.Map.Ordered.Strict as OMap import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Maybe @@ -823,6 +830,24 @@ instance Functor (BuildTxWith build) where fmap _ ViewTx = ViewTx fmap f (BuildTxWith x) = BuildTxWith (f x) +instance Applicative (BuildTxWith ViewTx) where + pure _ = ViewTx + _ <*> _ = ViewTx + +instance Applicative (BuildTxWith BuildTx) where + pure = BuildTxWith + (BuildTxWith f) <*> (BuildTxWith a) = BuildTxWith (f a) + +instance Monad (BuildTxWith ViewTx) where + ViewTx >>= _ = ViewTx + +instance Monad (BuildTxWith BuildTx) where + (BuildTxWith a) >>= f = f a + +buildTxWithToMaybe :: BuildTxWith build a -> Maybe a +buildTxWithToMaybe ViewTx = Nothing +buildTxWithToMaybe (BuildTxWith a) = Just a + deriving instance Eq a => Eq (BuildTxWith build a) deriving instance Show a => Show (BuildTxWith build a) @@ -845,16 +870,16 @@ deriving instance Eq (TxInsCollateral era) deriving instance Show (TxInsCollateral era) -data TxInsReference build era where - TxInsReferenceNone :: TxInsReference build era +data TxInsReference era where + TxInsReferenceNone :: TxInsReference era TxInsReference :: BabbageEraOnwards era -> [TxIn] - -> TxInsReference build era + -> TxInsReference era -deriving instance Eq (TxInsReference build era) +deriving instance Eq (TxInsReference era) -deriving instance Show (TxInsReference build era) +deriving instance Show (TxInsReference era) -- ---------------------------------------------------------------------------- -- Transaction output values (era-dependent) @@ -1211,6 +1236,40 @@ deriving instance Eq (TxVotingProcedures build era) deriving instance Show (TxVotingProcedures build era) +-- | Create voting procedures from map of voting procedures and optional witnesses. +-- Validates the function argument, to make sure the list of votes is legal. +-- See 'mergeVotingProcedures' for validation rules. +mkTxVotingProcedures + :: Applicative (BuildTxWith build) + => [(VotingProcedures era, Maybe (ScriptWitness WitCtxStake era))] + -> Either (VotesMergingConflict era) (TxVotingProcedures build era) +mkTxVotingProcedures votingProcedures = do + VotingProcedures procedure <- + foldM f emptyVotingProcedures votingProcedures + pure $ TxVotingProcedures procedure (pure votingScriptWitnessMap) + where + votingScriptWitnessMap = + foldl + (\acc next -> acc `Map.union` uncurry votingScriptWitnessSingleton next) + Map.empty + votingProcedures + f acc (procedure, _witness) = mergeVotingProcedures acc procedure + + votingScriptWitnessSingleton + :: VotingProcedures era + -> Maybe (ScriptWitness WitCtxStake era) + -> Map (L.Voter (L.EraCrypto (ShelleyLedgerEra era))) (ScriptWitness WitCtxStake era) + votingScriptWitnessSingleton _ Nothing = Map.empty + votingScriptWitnessSingleton votingProcedures' (Just scriptWitness) = do + let voter = fromJust $ getVotingScriptCredentials votingProcedures' + Map.singleton voter scriptWitness + + getVotingScriptCredentials + :: VotingProcedures era + -> Maybe (L.Voter (L.EraCrypto (ShelleyLedgerEra era))) + getVotingScriptCredentials (VotingProcedures (L.VotingProcedures m)) = + listToMaybe $ Map.keys m + -- ---------------------------------------------------------------------------- -- Proposals within transactions (era-dependent) -- @@ -1220,13 +1279,54 @@ data TxProposalProcedures build era where TxProposalProcedures :: Ledger.EraPParams (ShelleyLedgerEra era) => OSet (L.ProposalProcedure (ShelleyLedgerEra era)) - -> BuildTxWith build (Map (L.ProposalProcedure (ShelleyLedgerEra era)) (ScriptWitness WitCtxStake era)) + -> BuildTxWith + build + (OMap (L.ProposalProcedure (ShelleyLedgerEra era)) (ScriptWitness WitCtxStake era)) -> TxProposalProcedures build era deriving instance Eq (TxProposalProcedures build era) deriving instance Show (TxProposalProcedures build era) +-- | Create a 'TxProposalProcedures' value +mkTxProposalProcedures + :: forall era build + . IsShelleyBasedEra era + => Applicative (BuildTxWith build) + => OMap (Proposal era) (Maybe (ScriptWitness WitCtxStake era)) + -- ^ a map with proposals, with optional witnesses + -> TxProposalProcedures build era +mkTxProposalProcedures proposalProcedures = shelleyBasedEraConstraints (shelleyBasedEra @era) $ do + let proposalsList = toList proposalProcedures + proposals = fromList $ map (unProposal . fst) proposalsList + sWitMap = fromList $ mapMaybe (\(p, mw) -> (unProposal p,) <$> mw) proposalsList + TxProposalProcedures proposals (pure sWitMap) + +-- | Get map of the proposals with optional witnesses. +-- +-- You can understand the return type as: +-- @ +-- Maybe (OMap (Proposal era) (BuildTxWith build (Maybe (ScriptWitness WitCtxStake era)))) +-- ▲ ▲ ▲ ▲ +-- │ │ │ └─ Witness if it was provided +-- │ │ └─ Witnesses are only present for 'BuildTx' +-- │ └─ A proposal which might have a witness +-- └─ 'Just' if there were provided any proposals +-- @ +getProposalProcedures + :: IsShelleyBasedEra era + => TxProposalProcedures build era + -> Maybe (OMap (Proposal era) (BuildTxWith build (Maybe (ScriptWitness WitCtxStake era)))) +getProposalProcedures TxProposalProceduresNone = Nothing +getProposalProcedures (TxProposalProcedures procedures ViewTx) = + Just . fromList $ map (,pure Nothing) (Proposal <$> toList procedures) +getProposalProcedures (TxProposalProcedures procedures (BuildTxWith proposalProceduresWithWitnesses)) = do + Just $ + OMap.unionWithL + (const (liftA2 (<|>))) + (fromList $ map (,pure Nothing) (Proposal <$> toList procedures)) + (fromList $ map (bimap Proposal (pure . Just)) (toList proposalProceduresWithWitnesses)) + -- ---------------------------------------------------------------------------- -- Transaction body content -- @@ -1238,7 +1338,7 @@ data TxBodyContent build era = TxBodyContent { txIns :: TxIns build era , txInsCollateral :: TxInsCollateral era - , txInsReference :: TxInsReference build era + , txInsReference :: TxInsReference era , txOuts :: [TxOut CtxTx era] , txTotalCollateral :: TxTotalCollateral era , txReturnCollateral :: TxReturnCollateral CtxTx era @@ -1256,7 +1356,7 @@ data TxBodyContent build era , txScriptValidity :: TxScriptValidity era , txProposalProcedures :: Maybe (Featured ConwayEraOnwards era (TxProposalProcedures build era)) , txVotingProcedures :: Maybe (Featured ConwayEraOnwards era (TxVotingProcedures build era)) - , txCurrentTreasuryValue :: Maybe (Featured ConwayEraOnwards era L.Coin) + , txCurrentTreasuryValue :: Maybe (Featured ConwayEraOnwards era (Maybe L.Coin)) -- ^ Current treasury value , txTreasuryDonation :: Maybe (Featured ConwayEraOnwards era L.Coin) -- ^ Treasury donation to perform @@ -1309,7 +1409,7 @@ addTxIn txIn = modTxIns (txIn :) setTxInsCollateral :: TxInsCollateral era -> TxBodyContent build era -> TxBodyContent build era setTxInsCollateral v txBodyContent = txBodyContent{txInsCollateral = v} -setTxInsReference :: TxInsReference build era -> TxBodyContent build era -> TxBodyContent build era +setTxInsReference :: TxInsReference era -> TxBodyContent build era -> TxBodyContent build era setTxInsReference v txBodyContent = txBodyContent{txInsReference = v} setTxOuts :: [TxOut CtxTx era] -> TxBodyContent build era -> TxBodyContent build era @@ -1361,6 +1461,15 @@ setTxWithdrawals v txBodyContent = txBodyContent{txWithdrawals = v} setTxCertificates :: TxCertificates build era -> TxBodyContent build era -> TxBodyContent build era setTxCertificates v txBodyContent = txBodyContent{txCertificates = v} +setTxUpdateProposal :: TxUpdateProposal era -> TxBodyContent build era -> TxBodyContent build era +setTxUpdateProposal v txBodyContent = txBodyContent{txUpdateProposal = v} + +setTxMintValue :: TxMintValue build era -> TxBodyContent build era -> TxBodyContent build era +setTxMintValue v txBodyContent = txBodyContent{txMintValue = v} + +setTxScriptValidity :: TxScriptValidity era -> TxBodyContent build era -> TxBodyContent build era +setTxScriptValidity v txBodyContent = txBodyContent{txScriptValidity = v} + setTxProposalProcedures :: Maybe (Featured ConwayEraOnwards era (TxProposalProcedures build era)) -> TxBodyContent build era @@ -1373,17 +1482,10 @@ setTxVotingProcedures -> TxBodyContent build era setTxVotingProcedures v txBodyContent = txBodyContent{txVotingProcedures = v} -setTxUpdateProposal :: TxUpdateProposal era -> TxBodyContent build era -> TxBodyContent build era -setTxUpdateProposal v txBodyContent = txBodyContent{txUpdateProposal = v} - -setTxMintValue :: TxMintValue build era -> TxBodyContent build era -> TxBodyContent build era -setTxMintValue v txBodyContent = txBodyContent{txMintValue = v} - -setTxScriptValidity :: TxScriptValidity era -> TxBodyContent build era -> TxBodyContent build era -setTxScriptValidity v txBodyContent = txBodyContent{txScriptValidity = v} - setTxCurrentTreasuryValue - :: Maybe (Featured ConwayEraOnwards era L.Coin) -> TxBodyContent build era -> TxBodyContent build era + :: Maybe (Featured ConwayEraOnwards era (Maybe L.Coin)) + -> TxBodyContent build era + -> TxBodyContent build era setTxCurrentTreasuryValue v txBodyContent = txBodyContent{txCurrentTreasuryValue = v} setTxTreasuryDonation @@ -1508,6 +1610,10 @@ createTransactionBody sbe bc = scripts = convScripts apiScriptWitnesses languages = convLanguages apiScriptWitnesses sData = convScriptData sbe apiTxOuts apiScriptWitnesses + proposalProcedures = convProposalProcedures $ maybe TxProposalProceduresNone unFeatured (txProposalProcedures bc) + votingProcedures = convVotingProcedures $ maybe TxVotingProceduresNone unFeatured (txVotingProcedures bc) + currentTreasuryValue = Ledger.maybeToStrictMaybe $ unFeatured =<< txCurrentTreasuryValue bc + treasuryDonation = maybe 0 unFeatured $ txTreasuryDonation bc setUpdateProposal <- monoidForEraInEonA era $ \w -> Endo . (A.updateTxBodyL w .~) <$> convTxUpdateProposal sbe (txUpdateProposal bc) @@ -1538,6 +1644,18 @@ createTransactionBody sbe bc = setTotalCollateral <- monoidForEraInEonA era $ \w -> pure $ Endo $ A.totalCollateralTxBodyL w .~ totalCollateral + setProposalProcedures <- monoidForEraInEonA era $ \w -> + pure $ Endo $ A.proposalProceduresTxBodyL w .~ proposalProcedures + + setVotingProcedures <- monoidForEraInEonA era $ \w -> + pure $ Endo $ A.votingProceduresTxBodyL w .~ votingProcedures + + setCurrentTreasuryValue <- monoidForEraInEonA era $ \w -> + pure $ Endo $ A.currentTreasuryValueTxBodyL w .~ currentTreasuryValue + + setTreasuryDonation <- monoidForEraInEonA era $ \w -> + pure $ Endo $ A.treasuryDonationTxBodyL w .~ treasuryDonation + let ledgerTxBody = mkCommonTxBody sbe (txIns bc) (txOuts bc) (txFee bc) (txWithdrawals bc) txAuxData & A.certsTxBodyL sbe .~ certs @@ -1553,6 +1671,10 @@ createTransactionBody sbe bc = , setReferenceInputs , setCollateralReturn , setTotalCollateral + , setProposalProcedures + , setVotingProcedures + , setCurrentTreasuryValue + , setTreasuryDonation ] ) @@ -1802,16 +1924,11 @@ fromLedgerCurrentTreasuryValue :: () => ShelleyBasedEra era -> Ledger.TxBody (ShelleyLedgerEra era) - -> Maybe (Featured ConwayEraOnwards era Coin) -fromLedgerCurrentTreasuryValue sbe body = - caseShelleyToBabbageOrConwayEraOnwards - (const Nothing) - ( \cOnwards -> conwayEraOnwardsConstraints cOnwards $ - case body ^. L.currentTreasuryValueTxBodyL of - SNothing -> Nothing - SJust currentTreasuryValue -> Just $ Featured cOnwards currentTreasuryValue - ) - sbe + -> Maybe (Featured ConwayEraOnwards era (Maybe Coin)) +fromLedgerCurrentTreasuryValue sbe body = forEraInEonMaybe (toCardanoEra sbe) $ \ceo -> + conwayEraOnwardsConstraints ceo $ + Featured ceo . Ledger.strictMaybeToMaybe $ + body ^. L.currentTreasuryValueTxBodyL fromLedgerTreasuryDonation :: () @@ -1856,7 +1973,7 @@ fromLedgerTxInsCollateral sbe body = sbe fromLedgerTxInsReference - :: ShelleyBasedEra era -> Ledger.TxBody (ShelleyLedgerEra era) -> TxInsReference ViewTx era + :: ShelleyBasedEra era -> Ledger.TxBody (ShelleyLedgerEra era) -> TxInsReference era fromLedgerTxInsReference sbe txBody = caseShelleyToAlonzoOrBabbageEraOnwards (const TxInsReferenceNone) @@ -2356,16 +2473,20 @@ convLanguages witnesses = | (_, AnyScriptWitness (PlutusScriptWitness _ v _ _ _ _)) <- witnesses ] -convReferenceInputs :: TxInsReference build era -> Set (Ledger.TxIn StandardCrypto) +convReferenceInputs :: TxInsReference era -> Set (Ledger.TxIn StandardCrypto) convReferenceInputs txInsReference = case txInsReference of TxInsReferenceNone -> mempty TxInsReference _ refTxins -> fromList $ map toShelleyTxIn refTxins convProposalProcedures - :: TxProposalProcedures build era -> OSet (L.ProposalProcedure (ShelleyLedgerEra era)) -convProposalProcedures TxProposalProceduresNone = OSet.empty -convProposalProcedures (TxProposalProcedures procedures _) = procedures + :: forall era build + . IsShelleyBasedEra era + => TxProposalProcedures build era -> OSet (L.ProposalProcedure (ShelleyLedgerEra era)) +convProposalProcedures pp = + shelleyBasedEraConstraints (shelleyBasedEra @era) $ + fromList . maybe [] (map (unProposal . fst) . toList) $ + getProposalProcedures pp convVotingProcedures :: TxVotingProcedures build era -> L.VotingProcedures (ShelleyLedgerEra era) convVotingProcedures txVotingProcedures = @@ -2834,8 +2955,8 @@ makeShelleyTransactionBody & A.proposalProceduresTxBodyL cOn .~ convProposalProcedures (maybe TxProposalProceduresNone unFeatured txProposalProcedures) & A.currentTreasuryValueTxBodyL cOn - .~ (Ledger.maybeToStrictMaybe (unFeatured <$> txCurrentTreasuryValue)) - & A.treasuryDonationTxBodyL cOn .~ (maybe (L.Coin 0) unFeatured txTreasuryDonation) + .~ Ledger.maybeToStrictMaybe (unFeatured =<< txCurrentTreasuryValue) + & A.treasuryDonationTxBodyL cOn .~ maybe (L.Coin 0) unFeatured txTreasuryDonation -- TODO Conway: support optional network id in TxBodyContent -- & L.networkIdTxBodyL .~ SNothing ) @@ -3190,12 +3311,12 @@ collectTxBodyScriptWitnesses -> [(ScriptWitnessIndex, AnyScriptWitness era)] scriptWitnessesProposing TxProposalProceduresNone = [] scriptWitnessesProposing (TxProposalProcedures proposalProcedures (BuildTxWith mScriptWitnesses)) - | Map.null mScriptWitnesses = [] + | OMap.null mScriptWitnesses = [] | otherwise = [ (ScriptWitnessIndexProposing ix, AnyScriptWitness witness) | let proposalsList = toList $ OSet.toSet proposalProcedures , (ix, proposal) <- zip [0 ..] proposalsList - , witness <- maybeToList (Map.lookup proposal mScriptWitnesses) + , witness <- maybeToList (OMap.lookup proposal mScriptWitnesses) ] -- This relies on the TxId Ord instance being consistent with the diff --git a/cardano-api/src/Cardano/Api.hs b/cardano-api/src/Cardano/Api.hs index 406af60a49..5c37495fc4 100644 --- a/cardano-api/src/Cardano/Api.hs +++ b/cardano-api/src/Cardano/Api.hs @@ -44,6 +44,7 @@ module Cardano.Api , forShelleyBasedEraInEonMaybe , forShelleyBasedEraMaybeEon , Featured (..) + , mkFeatured , unFeatured , asFeaturedInEra , asFeaturedInShelleyBasedEra @@ -314,6 +315,8 @@ module Cardano.Api , setTxUpdateProposal , setTxMintValue , setTxScriptValidity + , setTxProposalProcedures + , setTxVotingProcedures , setTxCurrentTreasuryValue , setTxTreasuryDonation , TxBodyError (..) @@ -362,7 +365,10 @@ module Cardano.Api , TxUpdateProposal (..) , TxMintValue (..) , TxVotingProcedures (..) - , TxProposalProcedures (..) + , mkTxVotingProcedures + , TxProposalProcedures (TxProposalProceduresNone) + , mkTxProposalProcedures + , getProposalProcedures -- ** Building vs viewing transactions , BuildTxWith (..) diff --git a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Typed/TxBody.hs b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Typed/TxBody.hs index df5d28a139..071b021bef 100644 --- a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Typed/TxBody.hs +++ b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Typed/TxBody.hs @@ -10,32 +10,33 @@ import Cardano.Api.Shelley (ReferenceScript (..), refScriptToShelleySc import Data.Maybe (isJust) import Data.Type.Equality (TestEquality (testEquality)) +import GHC.Exts (IsList (..)) import Test.Gen.Cardano.Api.Typed (genTxBodyContent) import Test.Cardano.Api.Typed.Orphans () -import Hedgehog (MonadTest, Property, annotateShow, failure, (===)) +import Hedgehog (MonadTest, Property, annotateShow, (===)) import qualified Hedgehog as H +import qualified Hedgehog.Extras as H import Test.Tasty (TestTree, testGroup) import Test.Tasty.Hedgehog (testProperty) {- HLINT ignore "Use camelCase" -} +era :: ShelleyBasedEra BabbageEra +era = ShelleyBasedEraBabbage + -- | Check the txOuts in a TxBodyContent after a ledger roundtrip. prop_roundtrip_txbodycontent_txouts :: Property -prop_roundtrip_txbodycontent_txouts = - H.property $ do - let era = ShelleyBasedEraBabbage - content <- H.forAll $ genTxBodyContent era - -- Create the ledger body & auxiliaries - body <- case createAndValidateTransactionBody era content of - Left err -> annotateShow err >> failure - Right body -> pure body - annotateShow body - -- Convert ledger body back via 'getTxBodyContent' and 'fromLedgerTxBody' - let (TxBody content') = body - matchTxOuts (txOuts content) (txOuts content') +prop_roundtrip_txbodycontent_txouts = H.property $ do + content <- H.forAll $ genTxBodyContent era + -- Create the ledger body & auxiliaries + body <- H.leftFail $ createAndValidateTransactionBody era content + annotateShow body + -- Convert ledger body back via 'getTxBodyContent' and 'fromLedgerTxBody' + let (TxBody content') = body + matchTxOuts (txOuts content) (txOuts content') where matchTxOuts :: MonadTest m => [TxOut CtxTx BabbageEra] -> [TxOut CtxTx BabbageEra] -> m () matchTxOuts as bs = @@ -77,9 +78,36 @@ prop_roundtrip_txbodycontent_txouts = (ReferenceScript _ (ScriptInAnyLang actual _)) -> isJust $ testEquality expected actual _ -> False +prop_roundtrip_txbodycontent_conway_fields :: Property +prop_roundtrip_txbodycontent_conway_fields = H.property $ do + content <- H.forAll $ genTxBodyContent era + -- Create the ledger body & auxiliaries + body <- H.leftFail $ createAndValidateTransactionBody era content + annotateShow body + -- Convert ledger body back via 'getTxBodyContent' and 'fromLedgerTxBody' + let (TxBody content') = body + + let proposals = fmap (fmap fst . toList) . getProposalProcedures . unFeatured <$> txProposalProcedures content + proposals' = fmap (fmap fst . toList) . getProposalProcedures . unFeatured <$> txProposalProcedures content' + votes = getVotingProcedures . unFeatured <$> txVotingProcedures content + votes' = getVotingProcedures . unFeatured <$> txVotingProcedures content' + currTreasury = unFeatured <$> txCurrentTreasuryValue content + currTreasury' = unFeatured <$> txCurrentTreasuryValue content' + treasuryDonation = unFeatured <$> txTreasuryDonation content + treasuryDonation' = unFeatured <$> txTreasuryDonation content' + + proposals === proposals' + votes === votes' + currTreasury === currTreasury' + treasuryDonation === treasuryDonation' + where + getVotingProcedures TxVotingProceduresNone = Nothing + getVotingProcedures (TxVotingProcedures vps _) = Just vps + tests :: TestTree tests = testGroup "Test.Cardano.Api.Typed.TxBody" [ testProperty "roundtrip txbodycontent txouts" prop_roundtrip_txbodycontent_txouts + , testProperty "roundtrip txbodycontent new conway fields" prop_roundtrip_txbodycontent_conway_fields ] From dc612a032e7a5b43f4ec080b9247f5b855565f47 Mon Sep 17 00:00:00 2001 From: Mateusz Galazyn Date: Thu, 8 Aug 2024 09:12:14 +0200 Subject: [PATCH 2/3] Fix argument type in TxProposalProcedures constructor --- cardano-api/cardano-api.cabal | 2 +- cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs | 9 +- cardano-api/internal/Cardano/Api/Fees.hs | 25 ++--- cardano-api/internal/Cardano/Api/Tx/Body.hs | 97 ++++++------------- cardano-api/src/Cardano/Api.hs | 4 +- .../Test/Cardano/Api/Typed/TxBody.hs | 14 ++- 6 files changed, 64 insertions(+), 87 deletions(-) diff --git a/cardano-api/cardano-api.cabal b/cardano-api/cardano-api.cabal index 4721fe7db2..d2fb288264 100644 --- a/cardano-api/cardano-api.cabal +++ b/cardano-api/cardano-api.cabal @@ -282,7 +282,6 @@ library gen cardano-binary >=1.6 && <1.8, cardano-crypto-class ^>=2.1.2, cardano-crypto-test ^>=1.5, - cardano-data, cardano-ledger-alonzo:{cardano-ledger-alonzo, testlib} >=1.8.1, cardano-ledger-byron-test >=1.5, cardano-ledger-conway:testlib >=1.10.0, @@ -328,6 +327,7 @@ test-suite cardano-api-test hedgehog-quickcheck, interpolatedstring-perl6, mtl, + ordered-containers, ouroboros-consensus, ouroboros-consensus-cardano, ouroboros-consensus-protocol, diff --git a/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs b/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs index 2370757dba..d70b653e4e 100644 --- a/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs +++ b/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs @@ -1126,11 +1126,12 @@ genProposals :: Applicative (BuildTxWith build) => ConwayEraOnwards era -> Gen (TxProposalProcedures build era) genProposals w = conwayEraOnwardsConstraints w $ do - proposals <- fmap Proposal <$> Gen.list (Range.constant 0 10) (genProposal w) + proposals <- Gen.list (Range.constant 0 10) (genProposal w) let sbe = conwayEraOnwardsToShelleyBasedEra w - proposalsWithWitnesses <- fmap fromList . forM proposals $ \proposal -> - (proposal,) <$> Gen.maybe (genScriptWitnessForStake sbe) - pure $ mkTxProposalProcedures proposalsWithWitnesses + proposalsWithWitnesses <- fmap fromList . forM proposals $ \proposal -> do + mWitness <- Gen.maybe (genScriptWitnessForStake sbe) + pure (proposal, pure mWitness) + pure $ TxProposalProcedures proposalsWithWitnesses genProposal :: ConwayEraOnwards era -> Gen (L.ProposalProcedure (ShelleyLedgerEra era)) genProposal w = diff --git a/cardano-api/internal/Cardano/Api/Fees.hs b/cardano-api/internal/Cardano/Api/Fees.hs index e1870a07a3..b3730cfcff 100644 --- a/cardano-api/internal/Cardano/Api/Fees.hs +++ b/cardano-api/internal/Cardano/Api/Fees.hs @@ -56,7 +56,6 @@ import Cardano.Api.Eras.Case import Cardano.Api.Eras.Core import Cardano.Api.Error import Cardano.Api.Feature -import Cardano.Api.Governance.Actions.ProposalProcedure import qualified Cardano.Api.Ledger.Lens as A import Cardano.Api.Pretty import Cardano.Api.ProtocolParameters @@ -251,9 +250,11 @@ estimateBalancedTxBody proposalProcedures :: OSet.OSet (L.ProposalProcedure (ShelleyLedgerEra era)) proposalProcedures = maryEraOnwardsConstraints w $ - fromList $ - maybe [] (map (unProposal . fst) . toList) $ - (getProposalProcedures . unFeatured) =<< txProposalProcedures txbodycontent1 + case unFeatured <$> txProposalProcedures txbodycontent1 of + Nothing -> mempty + Just TxProposalProceduresNone -> mempty + Just (TxProposalProcedures pp) -> + fromList $ (map fst . toList) pp totalDeposits :: L.Coin totalDeposits = @@ -1578,23 +1579,23 @@ substituteExecutionUnits -> Either (TxBodyErrorAutoBalance era) (Maybe (Featured ConwayEraOnwards era (TxProposalProcedures build era))) - mapScriptWitnessesProposals Nothing = return Nothing - mapScriptWitnessesProposals (Just (Featured era proposalProcedures)) = forM (getProposalProcedures proposalProcedures) $ \pp -> do + mapScriptWitnessesProposals Nothing = pure Nothing + mapScriptWitnessesProposals (Just (Featured _ TxProposalProceduresNone)) = pure Nothing + mapScriptWitnessesProposals (Just (Featured _ (TxProposalProcedures proposalProcedures))) = do let substitutedExecutionUnits = [ (proposal, mUpdatedWitness) - | (proposal, mScriptWitness) <- toList $ fmap (join . buildTxWithToMaybe) pp - , index <- maybeToList $ OMap.findIndex proposal pp + | (proposal, BuildTxWith mScriptWitness) <- toList proposalProcedures + , index <- maybeToList $ OMap.findIndex proposal proposalProcedures , let mUpdatedWitness = substituteExecUnits (ScriptWitnessIndexProposing $ fromIntegral index) <$> mScriptWitness ] final <- fmap fromList . forM substitutedExecutionUnits $ \(p, meExecUnits) -> case meExecUnits of - Nothing -> pure (p, Nothing) + Nothing -> pure (p, pure Nothing) Just eExecUnits -> do -- TODO aggregate errors instead of shortcircuiting here execUnits <- eExecUnits - pure (p, pure execUnits) - - pure . Featured era $ mkTxProposalProcedures final + pure (p, pure $ pure execUnits) + pure . mkFeatured $ TxProposalProcedures final mapScriptWitnessesMinting :: TxMintValue BuildTx era diff --git a/cardano-api/internal/Cardano/Api/Tx/Body.hs b/cardano-api/internal/Cardano/Api/Tx/Body.hs index 2188f14751..e349304784 100644 --- a/cardano-api/internal/Cardano/Api/Tx/Body.hs +++ b/cardano-api/internal/Cardano/Api/Tx/Body.hs @@ -114,9 +114,7 @@ module Cardano.Api.Tx.Body , TxMintValue (..) , TxVotingProcedures (..) , mkTxVotingProcedures - , TxProposalProcedures (TxProposalProceduresNone) - , mkTxProposalProcedures - , getProposalProcedures + , TxProposalProcedures (..) -- ** Building vs viewing transactions , BuildTxWith (..) @@ -180,7 +178,6 @@ import Cardano.Api.Eras.Case import Cardano.Api.Eras.Core import Cardano.Api.Error (Error (..), displayError) import Cardano.Api.Feature -import Cardano.Api.Governance.Actions.ProposalProcedure import Cardano.Api.Governance.Actions.VotingProcedure import Cardano.Api.Hash import Cardano.Api.Keys.Byron @@ -258,7 +255,6 @@ import qualified Data.Map.Strict as Map import Data.Maybe import Data.Monoid import Data.OSet.Strict (OSet) -import qualified Data.OSet.Strict as OSet import Data.Scientific (toBoundedInteger) import qualified Data.Sequence.Strict as Seq import Data.Set (Set) @@ -1278,55 +1274,15 @@ data TxProposalProcedures build era where TxProposalProceduresNone :: TxProposalProcedures build era TxProposalProcedures :: Ledger.EraPParams (ShelleyLedgerEra era) - => OSet (L.ProposalProcedure (ShelleyLedgerEra era)) - -> BuildTxWith - build - (OMap (L.ProposalProcedure (ShelleyLedgerEra era)) (ScriptWitness WitCtxStake era)) + => OMap + (L.ProposalProcedure (ShelleyLedgerEra era)) + (BuildTxWith build (Maybe (ScriptWitness WitCtxStake era))) -> TxProposalProcedures build era deriving instance Eq (TxProposalProcedures build era) deriving instance Show (TxProposalProcedures build era) --- | Create a 'TxProposalProcedures' value -mkTxProposalProcedures - :: forall era build - . IsShelleyBasedEra era - => Applicative (BuildTxWith build) - => OMap (Proposal era) (Maybe (ScriptWitness WitCtxStake era)) - -- ^ a map with proposals, with optional witnesses - -> TxProposalProcedures build era -mkTxProposalProcedures proposalProcedures = shelleyBasedEraConstraints (shelleyBasedEra @era) $ do - let proposalsList = toList proposalProcedures - proposals = fromList $ map (unProposal . fst) proposalsList - sWitMap = fromList $ mapMaybe (\(p, mw) -> (unProposal p,) <$> mw) proposalsList - TxProposalProcedures proposals (pure sWitMap) - --- | Get map of the proposals with optional witnesses. --- --- You can understand the return type as: --- @ --- Maybe (OMap (Proposal era) (BuildTxWith build (Maybe (ScriptWitness WitCtxStake era)))) --- ▲ ▲ ▲ ▲ --- │ │ │ └─ Witness if it was provided --- │ │ └─ Witnesses are only present for 'BuildTx' --- │ └─ A proposal which might have a witness --- └─ 'Just' if there were provided any proposals --- @ -getProposalProcedures - :: IsShelleyBasedEra era - => TxProposalProcedures build era - -> Maybe (OMap (Proposal era) (BuildTxWith build (Maybe (ScriptWitness WitCtxStake era)))) -getProposalProcedures TxProposalProceduresNone = Nothing -getProposalProcedures (TxProposalProcedures procedures ViewTx) = - Just . fromList $ map (,pure Nothing) (Proposal <$> toList procedures) -getProposalProcedures (TxProposalProcedures procedures (BuildTxWith proposalProceduresWithWitnesses)) = do - Just $ - OMap.unionWithL - (const (liftA2 (<|>))) - (fromList $ map (,pure Nothing) (Proposal <$> toList procedures)) - (fromList $ map (bimap Proposal (pure . Just)) (toList proposalProceduresWithWitnesses)) - -- ---------------------------------------------------------------------------- -- Transaction body content -- @@ -1896,16 +1852,26 @@ fromLedgerTxBody sbe scriptValidity body scriptdata mAux = (txMetadata, txAuxScripts) = fromLedgerTxAuxiliaryData sbe mAux fromLedgerProposalProcedures - :: ShelleyBasedEra era + :: forall era + . ShelleyBasedEra era -> Ledger.TxBody (ShelleyLedgerEra era) -> Maybe (Featured ConwayEraOnwards era (TxProposalProcedures ViewTx era)) fromLedgerProposalProcedures sbe body = - forShelleyBasedEraInEonMaybe sbe $ \w -> - conwayEraOnwardsConstraints w $ - Featured w $ - TxProposalProcedures - (body ^. L.proposalProceduresTxBodyL) - ViewTx + forShelleyBasedEraInEonMaybe sbe $ \w -> do + let lpp + :: [ ( L.ProposalProcedure (ShelleyLedgerEra era) + , BuildTxWith ViewTx (Maybe (ScriptWitness WitCtxStake era)) + ) + ] + lpp = + conwayEraOnwardsConstraints w $ + map (,ViewTx) $ + toList $ + body ^. L.proposalProceduresTxBodyL + Featured w $ + conwayEraOnwardsConstraints w $ + TxProposalProcedures $ + fromList lpp fromLedgerVotingProcedures :: () @@ -2483,10 +2449,12 @@ convProposalProcedures :: forall era build . IsShelleyBasedEra era => TxProposalProcedures build era -> OSet (L.ProposalProcedure (ShelleyLedgerEra era)) -convProposalProcedures pp = +convProposalProcedures TxProposalProceduresNone = + shelleyBasedEraConstraints (shelleyBasedEra @era) mempty +convProposalProcedures (TxProposalProcedures pp) = shelleyBasedEraConstraints (shelleyBasedEra @era) $ - fromList . maybe [] (map (unProposal . fst) . toList) $ - getProposalProcedures pp + fromList $ + fst <$> toList pp convVotingProcedures :: TxVotingProcedures build era -> L.VotingProcedures (ShelleyLedgerEra era) convVotingProcedures txVotingProcedures = @@ -3310,14 +3278,11 @@ collectTxBodyScriptWitnesses :: TxProposalProcedures BuildTx era -> [(ScriptWitnessIndex, AnyScriptWitness era)] scriptWitnessesProposing TxProposalProceduresNone = [] - scriptWitnessesProposing (TxProposalProcedures proposalProcedures (BuildTxWith mScriptWitnesses)) - | OMap.null mScriptWitnesses = [] - | otherwise = - [ (ScriptWitnessIndexProposing ix, AnyScriptWitness witness) - | let proposalsList = toList $ OSet.toSet proposalProcedures - , (ix, proposal) <- zip [0 ..] proposalsList - , witness <- maybeToList (OMap.lookup proposal mScriptWitnesses) - ] + scriptWitnessesProposing (TxProposalProcedures proposalProcedures) = + [ (ScriptWitnessIndexProposing (fromIntegral ix), AnyScriptWitness witness) + | (p, BuildTxWith (Just witness)) <- toList proposalProcedures + , ix <- maybeToList $ OMap.findIndex p proposalProcedures + ] -- This relies on the TxId Ord instance being consistent with the -- Ledger.TxId Ord instance via the toShelleyTxId conversion diff --git a/cardano-api/src/Cardano/Api.hs b/cardano-api/src/Cardano/Api.hs index 5c37495fc4..dc9161001b 100644 --- a/cardano-api/src/Cardano/Api.hs +++ b/cardano-api/src/Cardano/Api.hs @@ -366,9 +366,7 @@ module Cardano.Api , TxMintValue (..) , TxVotingProcedures (..) , mkTxVotingProcedures - , TxProposalProcedures (TxProposalProceduresNone) - , mkTxProposalProcedures - , getProposalProcedures + , TxProposalProcedures (..) -- ** Building vs viewing transactions , BuildTxWith (..) diff --git a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Typed/TxBody.hs b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Typed/TxBody.hs index 071b021bef..ebb1746297 100644 --- a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Typed/TxBody.hs +++ b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Typed/TxBody.hs @@ -6,8 +6,11 @@ module Test.Cardano.Api.Typed.TxBody where import Cardano.Api -import Cardano.Api.Shelley (ReferenceScript (..), refScriptToShelleyScript) +import qualified Cardano.Api.Ledger as L +import Cardano.Api.Shelley (ReferenceScript (..), ShelleyLedgerEra, + refScriptToShelleyScript) +import Data.Map.Ordered.Strict (OMap) import Data.Maybe (isJust) import Data.Type.Equality (TestEquality (testEquality)) import GHC.Exts (IsList (..)) @@ -103,6 +106,15 @@ prop_roundtrip_txbodycontent_conway_fields = H.property $ do where getVotingProcedures TxVotingProceduresNone = Nothing getVotingProcedures (TxVotingProcedures vps _) = Just vps + getProposalProcedures + :: TxProposalProcedures build era + -> Maybe + ( OMap + (L.ProposalProcedure (ShelleyLedgerEra era)) + (BuildTxWith build (Maybe (ScriptWitness WitCtxStake era))) + ) + getProposalProcedures TxProposalProceduresNone = Nothing + getProposalProcedures (TxProposalProcedures pps) = Just pps tests :: TestTree tests = From 55fadc945dc07a42be3a954c56e474043ee22f9f Mon Sep 17 00:00:00 2001 From: Mateusz Galazyn Date: Fri, 9 Aug 2024 18:20:18 +0200 Subject: [PATCH 3/3] Revert to using an ill-defined TxProposalProcedures constructor --- cardano-api/cardano-api.cabal | 3 +- cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs | 52 ++++++--- cardano-api/internal/Cardano/Api/Fees.hs | 53 +++++---- .../Governance/Actions/ProposalProcedure.hs | 3 - .../Api/Governance/Actions/VotingProcedure.hs | 2 - cardano-api/internal/Cardano/Api/Orphans.hs | 6 -- cardano-api/internal/Cardano/Api/Tx/Body.hs | 101 ++++++++++-------- cardano-api/src/Cardano/Api.hs | 3 + .../Test/Cardano/Api/Typed/CBOR.hs | 15 +-- .../Test/Cardano/Api/Typed/TxBody.hs | 60 +++++------ 10 files changed, 158 insertions(+), 140 deletions(-) diff --git a/cardano-api/cardano-api.cabal b/cardano-api/cardano-api.cabal index d2fb288264..c732ea4142 100644 --- a/cardano-api/cardano-api.cabal +++ b/cardano-api/cardano-api.cabal @@ -184,6 +184,7 @@ library internal data-default-class, deepseq, directory, + dlist, either, errors, filepath, @@ -196,7 +197,6 @@ library internal mtl, network, optparse-applicative-fork, - ordered-containers, ouroboros-consensus ^>=0.20, ouroboros-consensus-cardano ^>=0.18, ouroboros-consensus-diffusion ^>=0.17, @@ -327,7 +327,6 @@ test-suite cardano-api-test hedgehog-quickcheck, interpolatedstring-perl6, mtl, - ordered-containers, ouroboros-consensus, ouroboros-consensus-cardano, ouroboros-consensus-protocol, diff --git a/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs b/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs index d70b653e4e..9391a5dde1 100644 --- a/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs +++ b/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs @@ -86,6 +86,7 @@ module Test.Gen.Cardano.Api.Typed , genTxAuxScripts , genTxBody , genTxBodyContent + , genValidTxBody , genTxCertificates , genTxFee , genTxIndex @@ -160,6 +161,7 @@ import Data.Ratio (Ratio, (%)) import Data.String import Data.Word (Word16, Word32, Word64) import GHC.Exts (IsList(..)) +import GHC.Stack import Numeric.Natural (Natural) import Test.Gen.Cardano.Api.Era @@ -446,7 +448,7 @@ genOperationalCertificateIssueCounter :: Gen OperationalCertificateIssueCounter genOperationalCertificateIssueCounter = snd <$> genOperationalCertificateWithCounter genOperationalCertificateWithCounter - :: Gen (OperationalCertificate, OperationalCertificateIssueCounter) + :: HasCallStack => Gen (OperationalCertificate, OperationalCertificateIssueCounter) genOperationalCertificateWithCounter = do kesVKey <- genVerificationKey AsKesKey stkPoolOrGenDelExtSign <- @@ -459,7 +461,7 @@ genOperationalCertificateWithCounter = do case issueOperationalCertificate kesVKey stkPoolOrGenDelExtSign kesP iCounter of -- This case should be impossible as we clearly derive the verification -- key from the generated signing key. - Left err -> fail $ docToString $ prettyError err + Left err -> error $ docToString $ prettyError err Right pair -> return pair where convert @@ -760,23 +762,37 @@ genTxOutByron = <*> pure TxOutDatumNone <*> pure ReferenceScriptNone -genTxBodyByron :: Gen (L.Annotated L.Tx ByteString) +-- | Partial! It will throw if the generated transaction body is invalid. +genTxBodyByron :: HasCallStack => Gen (L.Annotated L.Tx ByteString) genTxBodyByron = do txIns <- map (,BuildTxWith (KeyWitness KeyWitnessForSpending)) <$> Gen.list (Range.constant 1 10) genTxIn txOuts <- Gen.list (Range.constant 1 10) genTxOutByron case Api.makeByronTransactionBody txIns txOuts of - Left err -> fail (displayError err) + Left err -> error (displayError err) Right txBody -> pure txBody genWitnessesByron :: Gen [KeyWitness ByronEra] genWitnessesByron = Gen.list (Range.constant 1 10) genByronKeyWitness -genTxBody :: ShelleyBasedEra era -> Gen (TxBody era) +-- | This generator validates generated 'TxBodyContent' and backtracks when the generated body +-- fails the validation. That also means that it is quite slow. +genValidTxBody :: ShelleyBasedEra era + -> Gen (TxBody era, TxBodyContent BuildTx era) -- ^ validated 'TxBody' and 'TxBodyContent' +genValidTxBody sbe = + Gen.mapMaybe + (\content -> + either (const Nothing) (Just . (, content)) $ + createAndValidateTransactionBody sbe content + ) + (genTxBodyContent sbe) + +-- | Partial! This function will throw an error when the generated transaction is invalid. +genTxBody :: HasCallStack => ShelleyBasedEra era -> Gen (TxBody era) genTxBody era = do res <- Api.createAndValidateTransactionBody era <$> genTxBodyContent era case res of - Left err -> fail (docToString (prettyError err)) + Left err -> error (docToString (prettyError err)) Right txBody -> pure txBody -- | Generate a 'Featured' for the given 'CardanoEra' with the provided generator. @@ -799,7 +815,7 @@ genMaybeFeaturedInEra -> f (Maybe (Featured eon era a)) genMaybeFeaturedInEra f = inEonForEra (pure Nothing) $ \w -> - pure Nothing <|> fmap Just (genFeaturedInEra w (f w)) + Just <$> genFeaturedInEra w (f w) genTxScriptValidity :: CardanoEra era -> Gen (TxScriptValidity era) genTxScriptValidity = @@ -817,7 +833,7 @@ genTx genTx era = makeSignedTransaction <$> genWitnesses era - <*> genTxBody era + <*> (fst <$> genValidTxBody era) genWitnesses :: ShelleyBasedEra era -> Gen [KeyWitness era] genWitnesses sbe = do @@ -870,7 +886,7 @@ genShelleyBootstrapWitness genShelleyBootstrapWitness sbe = makeShelleyBootstrapWitness sbe <$> genWitnessNetworkIdOrByronAddress - <*> genTxBody sbe + <*> (fst <$> genValidTxBody sbe) <*> genSigningKey AsByronKey genShelleyKeyWitness @@ -878,8 +894,8 @@ genShelleyKeyWitness => ShelleyBasedEra era -> Gen (KeyWitness era) genShelleyKeyWitness sbe = - makeShelleyKeyWitness sbe - <$> genTxBody sbe + makeShelleyKeyWitness sbe . fst + <$> genValidTxBody sbe <*> genShelleyWitnessSigningKey genShelleyWitness @@ -1127,11 +1143,17 @@ genProposals :: Applicative (BuildTxWith build) -> Gen (TxProposalProcedures build era) genProposals w = conwayEraOnwardsConstraints w $ do proposals <- Gen.list (Range.constant 0 10) (genProposal w) + proposalsToBeWitnessed <- Gen.subsequence proposals + -- We're generating also some extra proposals, purposely not included in the proposals list, which results + -- in an invalid state of 'TxProposalProcedures'. + -- We're doing it for the complete representation of possible values space of TxProposalProcedures. + -- Proposal procedures code in cardano-api should handle such invalid values just fine. + extraProposals <- Gen.list (Range.constant 0 10) (genProposal w) let sbe = conwayEraOnwardsToShelleyBasedEra w - proposalsWithWitnesses <- fmap fromList . forM proposals $ \proposal -> do - mWitness <- Gen.maybe (genScriptWitnessForStake sbe) - pure (proposal, pure mWitness) - pure $ TxProposalProcedures proposalsWithWitnesses + proposalsWithWitnesses <- + forM (extraProposals <> proposalsToBeWitnessed) $ \proposal -> + (proposal,) <$> genScriptWitnessForStake sbe + pure $ TxProposalProcedures (fromList proposals) (pure $ fromList proposalsWithWitnesses) genProposal :: ConwayEraOnwards era -> Gen (L.ProposalProcedure (ShelleyLedgerEra era)) genProposal w = diff --git a/cardano-api/internal/Cardano/Api/Fees.hs b/cardano-api/internal/Cardano/Api/Fees.hs index b3730cfcff..fe4e226647 100644 --- a/cardano-api/internal/Cardano/Api/Fees.hs +++ b/cardano-api/internal/Cardano/Api/Fees.hs @@ -84,7 +84,6 @@ import Data.Bifunctor (bimap, first, second) import Data.ByteString.Short (ShortByteString) import Data.Function ((&)) import qualified Data.List as List -import qualified Data.Map.Ordered as OMap import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Maybe @@ -250,11 +249,7 @@ estimateBalancedTxBody proposalProcedures :: OSet.OSet (L.ProposalProcedure (ShelleyLedgerEra era)) proposalProcedures = maryEraOnwardsConstraints w $ - case unFeatured <$> txProposalProcedures txbodycontent1 of - Nothing -> mempty - Just TxProposalProceduresNone -> mempty - Just (TxProposalProcedures pp) -> - fromList $ (map fst . toList) pp + maybe mempty (convProposalProcedures . unFeatured) (txProposalProcedures txbodycontent1) totalDeposits :: L.Coin totalDeposits = @@ -1394,8 +1389,7 @@ maybeDummyTotalCollAndCollReturnOutput sbe TxBodyContent{txInsCollateral, txRetu substituteExecutionUnits :: forall era - . IsShelleyBasedEra era - => Map ScriptWitnessIndex ExecutionUnits + . Map ScriptWitnessIndex ExecutionUnits -> TxBodyContent BuildTx era -> Either (TxBodyErrorAutoBalance era) (TxBodyContent BuildTx era) substituteExecutionUnits @@ -1573,29 +1567,30 @@ substituteExecutionUnits (Featured era (TxVotingProcedures vProcedures (BuildTxWith $ fromList substitutedExecutionUnits))) mapScriptWitnessesProposals - :: forall build - . Applicative (BuildTxWith build) - => Maybe (Featured ConwayEraOnwards era (TxProposalProcedures build era)) + :: Maybe (Featured ConwayEraOnwards era (TxProposalProcedures build era)) -> Either (TxBodyErrorAutoBalance era) (Maybe (Featured ConwayEraOnwards era (TxProposalProcedures build era))) - mapScriptWitnessesProposals Nothing = pure Nothing - mapScriptWitnessesProposals (Just (Featured _ TxProposalProceduresNone)) = pure Nothing - mapScriptWitnessesProposals (Just (Featured _ (TxProposalProcedures proposalProcedures))) = do - let substitutedExecutionUnits = - [ (proposal, mUpdatedWitness) - | (proposal, BuildTxWith mScriptWitness) <- toList proposalProcedures - , index <- maybeToList $ OMap.findIndex proposal proposalProcedures - , let mUpdatedWitness = substituteExecUnits (ScriptWitnessIndexProposing $ fromIntegral index) <$> mScriptWitness + mapScriptWitnessesProposals Nothing = return Nothing + mapScriptWitnessesProposals (Just (Featured _ TxProposalProceduresNone)) = return Nothing + mapScriptWitnessesProposals (Just (Featured _ (TxProposalProcedures _ ViewTx))) = return Nothing + mapScriptWitnessesProposals (Just (Featured era txpp@(TxProposalProcedures osetProposalProcedures (BuildTxWith sWitMap)))) = do + let allProposalsList = toList $ convProposalProcedures txpp + eSubstitutedExecutionUnits = + [ (proposal, updatedWitness) + | (proposal, scriptWitness) <- toList sWitMap + , index <- maybeToList $ List.elemIndex proposal allProposalsList + , let updatedWitness = substituteExecUnits (ScriptWitnessIndexProposing $ fromIntegral index) scriptWitness ] - final <- fmap fromList . forM substitutedExecutionUnits $ \(p, meExecUnits) -> - case meExecUnits of - Nothing -> pure (p, pure Nothing) - Just eExecUnits -> do - -- TODO aggregate errors instead of shortcircuiting here - execUnits <- eExecUnits - pure (p, pure $ pure execUnits) - pure . mkFeatured $ TxProposalProcedures final + + substitutedExecutionUnits <- traverseScriptWitnesses eSubstitutedExecutionUnits + + return $ + Just + ( Featured + era + (TxProposalProcedures osetProposalProcedures (BuildTxWith $ fromList substitutedExecutionUnits)) + ) mapScriptWitnessesMinting :: TxMintValue BuildTx era @@ -1624,8 +1619,8 @@ substituteExecutionUnits fromList final traverseScriptWitnesses - :: [(a, Either l r)] - -> Either l [(a, r)] + :: [(a, Either (TxBodyErrorAutoBalance era) (ScriptWitness ctx era))] + -> Either (TxBodyErrorAutoBalance era) [(a, ScriptWitness ctx era)] traverseScriptWitnesses = traverse (\(item, eScriptWitness) -> eScriptWitness >>= (\sWit -> Right (item, sWit))) diff --git a/cardano-api/internal/Cardano/Api/Governance/Actions/ProposalProcedure.hs b/cardano-api/internal/Cardano/Api/Governance/Actions/ProposalProcedure.hs index 7a1f35bfea..6f4b202ae0 100644 --- a/cardano-api/internal/Cardano/Api/Governance/Actions/ProposalProcedure.hs +++ b/cardano-api/internal/Cardano/Api/Governance/Actions/ProposalProcedure.hs @@ -155,9 +155,6 @@ instance IsShelleyBasedEra era => Show (Proposal era) where instance IsShelleyBasedEra era => Eq (Proposal era) where (Proposal pp1) == (Proposal pp2) = shelleyBasedEraConstraints (shelleyBasedEra @era) $ pp1 == pp2 -instance IsShelleyBasedEra era => Ord (Proposal era) where - compare (Proposal pp1) (Proposal pp2) = shelleyBasedEraConstraints (shelleyBasedEra @era) $ compare pp1 pp2 - instance IsShelleyBasedEra era => ToCBOR (Proposal era) where toCBOR (Proposal vp) = shelleyBasedEraConstraints (shelleyBasedEra @era) $ Shelley.toEraCBOR @Conway.Conway vp diff --git a/cardano-api/internal/Cardano/Api/Governance/Actions/VotingProcedure.hs b/cardano-api/internal/Cardano/Api/Governance/Actions/VotingProcedure.hs index 62bde7f0e9..dba360230a 100644 --- a/cardano-api/internal/Cardano/Api/Governance/Actions/VotingProcedure.hs +++ b/cardano-api/internal/Cardano/Api/Governance/Actions/VotingProcedure.hs @@ -123,8 +123,6 @@ newtype VotingProcedures era = VotingProcedures deriving instance Eq (VotingProcedures era) -deriving instance Ord (VotingProcedures era) - deriving instance Generic (VotingProcedures era) deriving instance Show (VotingProcedures era) diff --git a/cardano-api/internal/Cardano/Api/Orphans.hs b/cardano-api/internal/Cardano/Api/Orphans.hs index 905debfce7..a52f6840d0 100644 --- a/cardano-api/internal/Cardano/Api/Orphans.hs +++ b/cardano-api/internal/Cardano/Api/Orphans.hs @@ -575,12 +575,6 @@ parsePlutusParamName t = deriving instance Show V2.ParamName --- Required instance, to be able to use the type as the map key --- TODO upstream to cardano-ledger -deriving instance Ord (L.VotingProcedures ledgerera) - -deriving instance Ord (L.VotingProcedure ledgerera) - -- TODO upstream to cardano-ledger instance IsList (ListMap k a) where type Item (ListMap k a) = (k, a) diff --git a/cardano-api/internal/Cardano/Api/Tx/Body.hs b/cardano-api/internal/Cardano/Api/Tx/Body.hs index e349304784..a8131701e9 100644 --- a/cardano-api/internal/Cardano/Api/Tx/Body.hs +++ b/cardano-api/internal/Cardano/Api/Tx/Body.hs @@ -11,7 +11,6 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} @@ -115,6 +114,8 @@ module Cardano.Api.Tx.Body , TxVotingProcedures (..) , mkTxVotingProcedures , TxProposalProcedures (..) + , mkTxProposalProcedures + , convProposalProcedures -- ** Building vs viewing transactions , BuildTxWith (..) @@ -242,19 +243,20 @@ import qualified Data.Aeson.Types as Aeson import Data.Bifunctor (Bifunctor (..)) import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as BSC +import qualified Data.DList as DList import Data.Foldable (for_) +import qualified Data.Foldable as Foldable import Data.Function (on) import Data.Functor (($>)) import Data.List (sortBy) import qualified Data.List as List import qualified Data.List.NonEmpty as NonEmpty -import Data.Map.Ordered.Strict (OMap) -import qualified Data.Map.Ordered.Strict as OMap import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Maybe import Data.Monoid -import Data.OSet.Strict (OSet) +import Data.OSet.Strict (OSet, (|><)) +import qualified Data.OSet.Strict as OSet import Data.Scientific (toBoundedInteger) import qualified Data.Sequence.Strict as Seq import Data.Set (Set) @@ -834,12 +836,6 @@ instance Applicative (BuildTxWith BuildTx) where pure = BuildTxWith (BuildTxWith f) <*> (BuildTxWith a) = BuildTxWith (f a) -instance Monad (BuildTxWith ViewTx) where - ViewTx >>= _ = ViewTx - -instance Monad (BuildTxWith BuildTx) where - (BuildTxWith a) >>= f = f a - buildTxWithToMaybe :: BuildTxWith build a -> Maybe a buildTxWithToMaybe ViewTx = Nothing buildTxWithToMaybe (BuildTxWith a) = Just a @@ -1272,17 +1268,41 @@ mkTxVotingProcedures votingProcedures = do data TxProposalProcedures build era where TxProposalProceduresNone :: TxProposalProcedures build era + -- | Create Tx proposal procedures. Prefer 'mkTxProposalProcedures' smart constructor to using this constructor + -- directly. TxProposalProcedures :: Ledger.EraPParams (ShelleyLedgerEra era) - => OMap - (L.ProposalProcedure (ShelleyLedgerEra era)) - (BuildTxWith build (Maybe (ScriptWitness WitCtxStake era))) + => OSet (L.ProposalProcedure (ShelleyLedgerEra era)) + -- ^ a set of proposals + -> BuildTxWith build (Map (L.ProposalProcedure (ShelleyLedgerEra era)) (ScriptWitness WitCtxStake era)) + -- ^ a map of witnesses for the proposals. If the proposals are not added to the first constructor + -- parameter too, the sky will fall on your head. -> TxProposalProcedures build era deriving instance Eq (TxProposalProcedures build era) deriving instance Show (TxProposalProcedures build era) +-- | A smart constructor for 'TxProposalProcedures'. It makes sure that the value produced is consistent - the +-- witnessed proposals are also present in the first constructor parameter. +mkTxProposalProcedures + :: forall era build + . Applicative (BuildTxWith build) + => IsShelleyBasedEra era + => [(L.ProposalProcedure (ShelleyLedgerEra era), Maybe (ScriptWitness WitCtxStake era))] + -> TxProposalProcedures build era +mkTxProposalProcedures proposalsWithWitnessesList = do + let (proposals, proposalsWithWitnesses) = + bimap toList toList $ + Foldable.foldl' partitionProposals mempty proposalsWithWitnessesList + shelleyBasedEraConstraints (shelleyBasedEra @era) $ + TxProposalProcedures (fromList proposals) (pure $ fromList proposalsWithWitnesses) + where + partitionProposals (ps, pws) (p, Nothing) = + (DList.snoc ps p, pws) -- add a proposal to the list + partitionProposals (ps, pws) (p, Just w) = + (DList.snoc ps p, DList.snoc pws (p, w)) -- add a proposal both to the list and to the witnessed list + -- ---------------------------------------------------------------------------- -- Transaction body content -- @@ -1852,26 +1872,16 @@ fromLedgerTxBody sbe scriptValidity body scriptdata mAux = (txMetadata, txAuxScripts) = fromLedgerTxAuxiliaryData sbe mAux fromLedgerProposalProcedures - :: forall era - . ShelleyBasedEra era + :: ShelleyBasedEra era -> Ledger.TxBody (ShelleyLedgerEra era) -> Maybe (Featured ConwayEraOnwards era (TxProposalProcedures ViewTx era)) fromLedgerProposalProcedures sbe body = - forShelleyBasedEraInEonMaybe sbe $ \w -> do - let lpp - :: [ ( L.ProposalProcedure (ShelleyLedgerEra era) - , BuildTxWith ViewTx (Maybe (ScriptWitness WitCtxStake era)) - ) - ] - lpp = - conwayEraOnwardsConstraints w $ - map (,ViewTx) $ - toList $ - body ^. L.proposalProceduresTxBodyL - Featured w $ - conwayEraOnwardsConstraints w $ - TxProposalProcedures $ - fromList lpp + forShelleyBasedEraInEonMaybe sbe $ \w -> + conwayEraOnwardsConstraints w $ + Featured w $ + TxProposalProcedures + (body ^. L.proposalProceduresTxBodyL) + ViewTx fromLedgerVotingProcedures :: () @@ -2445,16 +2455,16 @@ convReferenceInputs txInsReference = TxInsReferenceNone -> mempty TxInsReference _ refTxins -> fromList $ map toShelleyTxIn refTxins +-- | Returns an OSet of proposals from 'TxProposalProcedures'. +-- +-- If 'pws' in 'TxProposalProcedures pps (BuildTxWith pws)' contained proposals not present in 'pps', the'll +-- be sorted ascendingly and snoc-ed to 'pps' if they're not present in 'pps'. convProposalProcedures - :: forall era build - . IsShelleyBasedEra era - => TxProposalProcedures build era -> OSet (L.ProposalProcedure (ShelleyLedgerEra era)) -convProposalProcedures TxProposalProceduresNone = - shelleyBasedEraConstraints (shelleyBasedEra @era) mempty -convProposalProcedures (TxProposalProcedures pp) = - shelleyBasedEraConstraints (shelleyBasedEra @era) $ - fromList $ - fst <$> toList pp + :: TxProposalProcedures build era -> OSet (L.ProposalProcedure (ShelleyLedgerEra era)) +convProposalProcedures TxProposalProceduresNone = OSet.empty +convProposalProcedures (TxProposalProcedures pp bWits) = do + let wits = fromMaybe mempty $ buildTxWithToMaybe bWits + pp |>< fromList (Map.keys wits) convVotingProcedures :: TxVotingProcedures build era -> L.VotingProcedures (ShelleyLedgerEra era) convVotingProcedures txVotingProcedures = @@ -3278,11 +3288,14 @@ collectTxBodyScriptWitnesses :: TxProposalProcedures BuildTx era -> [(ScriptWitnessIndex, AnyScriptWitness era)] scriptWitnessesProposing TxProposalProceduresNone = [] - scriptWitnessesProposing (TxProposalProcedures proposalProcedures) = - [ (ScriptWitnessIndexProposing (fromIntegral ix), AnyScriptWitness witness) - | (p, BuildTxWith (Just witness)) <- toList proposalProcedures - , ix <- maybeToList $ OMap.findIndex p proposalProcedures - ] + scriptWitnessesProposing (TxProposalProcedures proposalProcedures (BuildTxWith mScriptWitnesses)) + | Map.null mScriptWitnesses = [] + | otherwise = + [ (ScriptWitnessIndexProposing ix, AnyScriptWitness witness) + | let proposalsList = toList proposalProcedures + , (ix, proposal) <- zip [0 ..] proposalsList + , witness <- maybeToList (Map.lookup proposal mScriptWitnesses) + ] -- This relies on the TxId Ord instance being consistent with the -- Ledger.TxId Ord instance via the toShelleyTxId conversion diff --git a/cardano-api/src/Cardano/Api.hs b/cardano-api/src/Cardano/Api.hs index dc9161001b..7b73c22c81 100644 --- a/cardano-api/src/Cardano/Api.hs +++ b/cardano-api/src/Cardano/Api.hs @@ -367,11 +367,14 @@ module Cardano.Api , TxVotingProcedures (..) , mkTxVotingProcedures , TxProposalProcedures (..) + , mkTxProposalProcedures + , convProposalProcedures -- ** Building vs viewing transactions , BuildTxWith (..) , BuildTx , ViewTx + , buildTxWithToMaybe -- ** Fee calculation , LedgerEpochInfo (..) diff --git a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Typed/CBOR.hs b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Typed/CBOR.hs index b11b54ff31..217caa9e73 100644 --- a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Typed/CBOR.hs +++ b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Typed/CBOR.hs @@ -20,6 +20,7 @@ import Test.Cardano.Api.Typed.Orphans () import Hedgehog (Property, forAll, property, tripping) import qualified Hedgehog as H +import qualified Hedgehog.Extras as H import qualified Hedgehog.Gen as Gen import qualified Test.Hedgehog.Roundtrip.CBOR as H import Test.Hedgehog.Roundtrip.CBOR @@ -33,19 +34,19 @@ import Test.Tasty.Hedgehog (testProperty) prop_roundtrip_txbody_CBOR :: Property prop_roundtrip_txbody_CBOR = H.property $ do - AnyShelleyBasedEra era <- H.forAll $ Gen.element [minBound .. maxBound] - x <- H.forAll $ makeSignedTransaction [] <$> genTxBody era + AnyShelleyBasedEra era <- H.noteShowM . H.forAll $ Gen.element [minBound .. maxBound] + x <- H.forAll $ makeSignedTransaction [] . fst <$> genValidTxBody era H.tripping x (serialiseTxLedgerCddl era) (deserialiseTxLedgerCddl era) prop_roundtrip_tx_CBOR :: Property prop_roundtrip_tx_CBOR = H.property $ do - AnyShelleyBasedEra era <- H.forAll $ Gen.element [minBound .. maxBound] + AnyShelleyBasedEra era <- H.noteShowM . H.forAll $ Gen.element [minBound .. maxBound] x <- H.forAll $ genTx era shelleyBasedEraConstraints era $ H.trippingCbor (proxyToAsType Proxy) x prop_roundtrip_witness_CBOR :: Property prop_roundtrip_witness_CBOR = H.property $ do - AnyShelleyBasedEra era <- H.forAll $ Gen.element [minBound .. maxBound] + AnyShelleyBasedEra era <- H.noteShowM . H.forAll $ Gen.element [minBound .. maxBound] x <- H.forAll $ genCardanoKeyWitness era shelleyBasedEraConstraints era $ H.trippingCbor (AsKeyWitness (proxyToAsType Proxy)) x @@ -166,19 +167,19 @@ prop_roundtrip_ScriptData_CBOR = H.property $ do prop_roundtrip_UpdateProposal_CBOR :: Property prop_roundtrip_UpdateProposal_CBOR = H.property $ do - AnyCardanoEra era <- H.forAll $ Gen.element [minBound .. maxBound] + AnyCardanoEra era <- H.noteShowM . H.forAll $ Gen.element [minBound .. maxBound] proposal <- H.forAll $ genUpdateProposal era H.trippingCbor AsUpdateProposal proposal prop_roundtrip_Tx_Cddl :: Property prop_roundtrip_Tx_Cddl = H.property $ do - AnyShelleyBasedEra era <- H.forAll $ Gen.element [minBound .. maxBound] + AnyShelleyBasedEra era <- H.noteShowM . H.forAll $ Gen.element [minBound .. maxBound] x <- forAll $ genTx era H.tripping x (serialiseTxLedgerCddl era) (deserialiseTxLedgerCddl era) prop_roundtrip_TxWitness_Cddl :: Property prop_roundtrip_TxWitness_Cddl = H.property $ do - AnyShelleyBasedEra sbe <- H.forAll $ Gen.element [minBound .. maxBound] + AnyShelleyBasedEra sbe <- H.noteShowM . H.forAll $ Gen.element [minBound .. maxBound] x <- forAll $ genShelleyKeyWitness sbe tripping x (serialiseWitnessLedgerCddl sbe) (deserialiseWitnessLedgerCddl sbe) diff --git a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Typed/TxBody.hs b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Typed/TxBody.hs index ebb1746297..cead101dbd 100644 --- a/cardano-api/test/cardano-api-test/Test/Cardano/Api/Typed/TxBody.hs +++ b/cardano-api/test/cardano-api-test/Test/Cardano/Api/Typed/TxBody.hs @@ -1,4 +1,7 @@ +{-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} module Test.Cardano.Api.Typed.TxBody ( tests @@ -10,42 +13,35 @@ import qualified Cardano.Api.Ledger as L import Cardano.Api.Shelley (ReferenceScript (..), ShelleyLedgerEra, refScriptToShelleyScript) -import Data.Map.Ordered.Strict (OMap) import Data.Maybe (isJust) import Data.Type.Equality (TestEquality (testEquality)) import GHC.Exts (IsList (..)) -import Test.Gen.Cardano.Api.Typed (genTxBodyContent) +import Test.Gen.Cardano.Api.Typed (genValidTxBody) import Test.Cardano.Api.Typed.Orphans () -import Hedgehog (MonadTest, Property, annotateShow, (===)) +import Hedgehog (MonadTest, Property, (===)) import qualified Hedgehog as H -import qualified Hedgehog.Extras as H import Test.Tasty (TestTree, testGroup) import Test.Tasty.Hedgehog (testProperty) {- HLINT ignore "Use camelCase" -} -era :: ShelleyBasedEra BabbageEra -era = ShelleyBasedEraBabbage - -- | Check the txOuts in a TxBodyContent after a ledger roundtrip. -prop_roundtrip_txbodycontent_txouts :: Property -prop_roundtrip_txbodycontent_txouts = H.property $ do - content <- H.forAll $ genTxBodyContent era - -- Create the ledger body & auxiliaries - body <- H.leftFail $ createAndValidateTransactionBody era content - annotateShow body +prop_roundtrip_txbodycontent_txouts :: forall era. ShelleyBasedEra era -> Property +prop_roundtrip_txbodycontent_txouts era = H.property $ do + (body, content :: TxBodyContent BuildTx era) <- + shelleyBasedEraConstraints era $ H.forAll $ genValidTxBody era -- Convert ledger body back via 'getTxBodyContent' and 'fromLedgerTxBody' let (TxBody content') = body matchTxOuts (txOuts content) (txOuts content') where - matchTxOuts :: MonadTest m => [TxOut CtxTx BabbageEra] -> [TxOut CtxTx BabbageEra] -> m () + matchTxOuts :: MonadTest m => [TxOut CtxTx era] -> [TxOut CtxTx era] -> m () matchTxOuts as bs = mapM_ matchTxOut $ zip as bs - matchTxOut :: MonadTest m => (TxOut CtxTx BabbageEra, TxOut CtxTx BabbageEra) -> m () + matchTxOut :: MonadTest m => (TxOut CtxTx era, TxOut CtxTx era) -> m () matchTxOut (a, b) = do let TxOut aAddress aValue aDatum aRefScript = a let TxOut bAddress bValue bDatum bRefScript = b @@ -65,11 +61,12 @@ prop_roundtrip_txbodycontent_txouts = H.property $ do -- NOTE: After Allegra, all eras interpret SimpleScriptV1 as SimpleScriptV2 -- because V2 is a superset of V1. So we accept that as a valid conversion. - matchRefScript :: MonadTest m => (ReferenceScript BabbageEra, ReferenceScript BabbageEra) -> m () + matchRefScript :: MonadTest m => (ReferenceScript era, ReferenceScript era) -> m () matchRefScript (a, b) | isSimpleScriptV2 a && isSimpleScriptV2 b = - refScriptToShelleyScript ShelleyBasedEraBabbage a - === refScriptToShelleyScript ShelleyBasedEraBabbage b + shelleyBasedEraConstraints era $ + refScriptToShelleyScript era a + === refScriptToShelleyScript era b | otherwise = a === b @@ -83,15 +80,13 @@ prop_roundtrip_txbodycontent_txouts = H.property $ do prop_roundtrip_txbodycontent_conway_fields :: Property prop_roundtrip_txbodycontent_conway_fields = H.property $ do - content <- H.forAll $ genTxBodyContent era - -- Create the ledger body & auxiliaries - body <- H.leftFail $ createAndValidateTransactionBody era content - annotateShow body + let sbe = ShelleyBasedEraConway + (body, content) <- H.forAll $ genValidTxBody sbe -- Convert ledger body back via 'getTxBodyContent' and 'fromLedgerTxBody' let (TxBody content') = body - let proposals = fmap (fmap fst . toList) . getProposalProcedures . unFeatured <$> txProposalProcedures content - proposals' = fmap (fmap fst . toList) . getProposalProcedures . unFeatured <$> txProposalProcedures content' + let proposals = getProposalProcedures . unFeatured <$> txProposalProcedures content + proposals' = getProposalProcedures . unFeatured <$> txProposalProcedures content' votes = getVotingProcedures . unFeatured <$> txVotingProcedures content votes' = getVotingProcedures . unFeatured <$> txVotingProcedures content' currTreasury = unFeatured <$> txCurrentTreasuryValue content @@ -108,18 +103,19 @@ prop_roundtrip_txbodycontent_conway_fields = H.property $ do getVotingProcedures (TxVotingProcedures vps _) = Just vps getProposalProcedures :: TxProposalProcedures build era - -> Maybe - ( OMap - (L.ProposalProcedure (ShelleyLedgerEra era)) - (BuildTxWith build (Maybe (ScriptWitness WitCtxStake era))) - ) + -> Maybe [L.ProposalProcedure (ShelleyLedgerEra era)] getProposalProcedures TxProposalProceduresNone = Nothing - getProposalProcedures (TxProposalProcedures pps) = Just pps + getProposalProcedures txpp@(TxProposalProcedures _ _) = Just . toList $ convProposalProcedures txpp tests :: TestTree tests = testGroup "Test.Cardano.Api.Typed.TxBody" - [ testProperty "roundtrip txbodycontent txouts" prop_roundtrip_txbodycontent_txouts - , testProperty "roundtrip txbodycontent new conway fields" prop_roundtrip_txbodycontent_conway_fields + [ testProperty "roundtrip txbodycontent txouts Babbage" $ + prop_roundtrip_txbodycontent_txouts ShelleyBasedEraBabbage + , testProperty "roundtrip txbodycontent txouts Conway" $ + prop_roundtrip_txbodycontent_txouts ShelleyBasedEraConway + , testProperty + "roundtrip txbodycontent new conway fields" + prop_roundtrip_txbodycontent_conway_fields ]