diff --git a/cardano-api/cardano-api.cabal b/cardano-api/cardano-api.cabal index 3e46a927f..c732ea414 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, @@ -281,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, diff --git a/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs b/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs index 839748f4d..9391a5dde 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 @@ -149,17 +150,18 @@ 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 GHC.Stack import Numeric.Natural (Natural) import Test.Gen.Cardano.Api.Era @@ -318,8 +320,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 @@ -447,7 +448,7 @@ genOperationalCertificateIssueCounter :: Gen OperationalCertificateIssueCounter genOperationalCertificateIssueCounter = snd <$> genOperationalCertificateWithCounter genOperationalCertificateWithCounter - :: Gen (OperationalCertificate, OperationalCertificateIssueCounter) + :: HasCallStack => Gen (OperationalCertificate, OperationalCertificateIssueCounter) genOperationalCertificateWithCounter = do kesVKey <- genVerificationKey AsKesKey stkPoolOrGenDelExtSign <- @@ -460,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 @@ -588,7 +589,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 +649,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 +681,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 +720,7 @@ genTxInsCollateral = ] ) -genTxInsReference :: CardanoEra era -> Gen (TxInsReference BuildTx era) +genTxInsReference :: CardanoEra era -> Gen (TxInsReference era) genTxInsReference = caseByronToAlonzoOrBabbageEraOnwards (const (pure TxInsReferenceNone)) @@ -761,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. @@ -800,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 = @@ -818,7 +833,7 @@ genTx genTx era = makeSignedTransaction <$> genWitnesses era - <*> genTxBody era + <*> (fst <$> genValidTxBody era) genWitnesses :: ShelleyBasedEra era -> Gen [KeyWitness era] genWitnesses sbe = do @@ -871,7 +886,7 @@ genShelleyBootstrapWitness genShelleyBootstrapWitness sbe = makeShelleyBootstrapWitness sbe <$> genWitnessNetworkIdOrByronAddress - <*> genTxBody sbe + <*> (fst <$> genValidTxBody sbe) <*> genSigningKey AsByronKey genShelleyKeyWitness @@ -879,8 +894,8 @@ genShelleyKeyWitness => ShelleyBasedEra era -> Gen (KeyWitness era) genShelleyKeyWitness sbe = - makeShelleyKeyWitness sbe - <$> genTxBody sbe + makeShelleyKeyWitness sbe . fst + <$> genValidTxBody sbe <*> genShelleyWitnessSigningKey genShelleyWitness @@ -1123,34 +1138,68 @@ 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 <- 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 <- + forM (extraProposals <> proposalsToBeWitnessed) $ \proposal -> + (proposal,) <$> genScriptWitnessForStake sbe + pure $ TxProposalProcedures (fromList proposals) (pure $ fromList 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 c40265a92..f2cf39aca 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 032cabb10..fe4e22664 100644 --- a/cardano-api/internal/Cardano/Api/Fees.hs +++ b/cardano-api/internal/Cardano/Api/Fees.hs @@ -79,14 +79,14 @@ 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 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 +96,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 +231,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 +248,8 @@ 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 $ + maybe mempty (convProposalProcedures . unFeatured) (txProposalProcedures txbodycontent1) totalDeposits :: L.Coin totalDeposits = @@ -1577,11 +1574,11 @@ substituteExecutionUnits 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 = + mapScriptWitnessesProposals (Just (Featured era txpp@(TxProposalProcedures osetProposalProcedures (BuildTxWith sWitMap)))) = do + let allProposalsList = toList $ convProposalProcedures txpp + eSubstitutedExecutionUnits = [ (proposal, updatedWitness) - | let allProposalsList = toList osetProposalProcedures - , (proposal, scriptWitness) <- toList sWitMap + | (proposal, scriptWitness) <- toList sWitMap , index <- maybeToList $ List.elemIndex proposal allProposalsList , let updatedWitness = substituteExecUnits (ScriptWitnessIndexProposing $ fromIntegral index) scriptWitness ] diff --git a/cardano-api/internal/Cardano/Api/Tx/Body.hs b/cardano-api/internal/Cardano/Api/Tx/Body.hs index 3ef72fe1b..a8131701e 100644 --- a/cardano-api/internal/Cardano/Api/Tx/Body.hs +++ b/cardano-api/internal/Cardano/Api/Tx/Body.hs @@ -16,8 +16,6 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE ViewPatterns #-} -{- HLINT ignore "Redundant bracket" -} - -- | Transaction bodies module Cardano.Api.Tx.Body ( parseTxId @@ -114,12 +112,16 @@ module Cardano.Api.Tx.Body , TxUpdateProposal (..) , TxMintValue (..) , TxVotingProcedures (..) + , mkTxVotingProcedures , TxProposalProcedures (..) + , mkTxProposalProcedures + , convProposalProcedures -- ** Building vs viewing transactions , BuildTxWith (..) , BuildTx , ViewTx + , buildTxWithToMaybe -- * Inspecting 'ScriptWitness'es , AnyScriptWitness (..) @@ -177,6 +179,7 @@ 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.VotingProcedure import Cardano.Api.Hash import Cardano.Api.Keys.Byron import Cardano.Api.Keys.Shelley @@ -240,7 +243,9 @@ 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) @@ -250,7 +255,7 @@ 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 @@ -823,6 +828,18 @@ 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) + +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 +862,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,22 +1228,81 @@ 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) -- 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) => 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 -- @@ -1238,7 +1314,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 +1332,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 +1385,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 +1437,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 +1458,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 +1586,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 +1620,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 +1647,10 @@ createTransactionBody sbe bc = , setReferenceInputs , setCollateralReturn , setTotalCollateral + , setProposalProcedures + , setVotingProcedures + , setCurrentTreasuryValue + , setTreasuryDonation ] ) @@ -1802,16 +1900,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 +1949,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 +2449,22 @@ 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 +-- | 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 :: TxProposalProcedures build era -> OSet (L.ProposalProcedure (ShelleyLedgerEra era)) convProposalProcedures TxProposalProceduresNone = OSet.empty -convProposalProcedures (TxProposalProcedures procedures _) = procedures +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 = @@ -2834,8 +2933,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 ) @@ -3193,7 +3292,7 @@ collectTxBodyScriptWitnesses | Map.null mScriptWitnesses = [] | otherwise = [ (ScriptWitnessIndexProposing ix, AnyScriptWitness witness) - | let proposalsList = toList $ OSet.toSet proposalProcedures + | let proposalsList = toList proposalProcedures , (ix, proposal) <- zip [0 ..] proposalsList , witness <- maybeToList (Map.lookup proposal mScriptWitnesses) ] diff --git a/cardano-api/src/Cardano/Api.hs b/cardano-api/src/Cardano/Api.hs index 406af60a4..7b73c22c8 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,12 +365,16 @@ module Cardano.Api , TxUpdateProposal (..) , TxMintValue (..) , 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 b11b54ff3..217caa9e7 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 df5d28a13..cead101db 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 @@ -6,16 +9,19 @@ 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.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, failure, (===)) +import Hedgehog (MonadTest, Property, (===)) import qualified Hedgehog as H import Test.Tasty (TestTree, testGroup) import Test.Tasty.Hedgehog (testProperty) @@ -23,25 +29,19 @@ import Test.Tasty.Hedgehog (testProperty) {- HLINT ignore "Use camelCase" -} -- | 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 :: 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 @@ -61,11 +61,12 @@ prop_roundtrip_txbodycontent_txouts = -- 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 @@ -77,9 +78,44 @@ 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 + let sbe = ShelleyBasedEraConway + (body, content) <- H.forAll $ genValidTxBody sbe + -- Convert ledger body back via 'getTxBodyContent' and 'fromLedgerTxBody' + let (TxBody content') = body + + 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 + 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 + getProposalProcedures + :: TxProposalProcedures build era + -> Maybe [L.ProposalProcedure (ShelleyLedgerEra era)] + getProposalProcedures TxProposalProceduresNone = Nothing + 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 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 ]