From 55fadc945dc07a42be3a954c56e474043ee22f9f Mon Sep 17 00:00:00 2001 From: Mateusz Galazyn Date: Fri, 9 Aug 2024 18:20:18 +0200 Subject: [PATCH] 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 ]