From 4ce38b0e46fd25aec0217d687443764b511c3ed4 Mon Sep 17 00:00:00 2001 From: Yuriy Syrovetskiy Date: Fri, 10 Dec 2021 19:04:55 +0300 Subject: [PATCH] cardano-api: Fix genProtocolParametersUpdate to distinguish Alonzo-specifix protocol parameters --- cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs | 66 +++++++++++-------- .../test/Test/Cardano/Api/Typed/CBOR.hs | 20 +++--- .../test/Test/Cardano/Api/Typed/JSON.hs | 21 +++--- 3 files changed, 63 insertions(+), 44 deletions(-) diff --git a/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs b/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs index 3bca3c39308..af1127b5023 100644 --- a/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs +++ b/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs @@ -581,7 +581,7 @@ genTxUpdateProposal era = Just supported -> Gen.choice [ pure TxUpdateProposalNone - , TxUpdateProposal supported <$> genUpdateProposal + , TxUpdateProposal supported <$> genUpdateProposal era ] genTxMintValue :: CardanoEra era -> Gen (TxMintValue BuildTx era) @@ -611,7 +611,7 @@ genTxBodyContent era = do txMetadata <- genTxMetadataInEra era txAuxScripts <- genTxAuxScripts era let txExtraKeyWits = TxExtraKeyWitnessesNone --TODO: Alonzo era: Generate witness key hashes - txProtocolParams <- BuildTxWith <$> Gen.maybe genProtocolParameters + txProtocolParams <- BuildTxWith <$> Gen.maybe (genProtocolParameters era) txWithdrawals <- genTxWithdrawals era txCertificates <- genTxCertificates era txUpdateProposal <- genTxUpdateProposal era @@ -831,8 +831,8 @@ genPraosNonce = makePraosNonce <$> Gen.bytes (Range.linear 0 32) genMaybePraosNonce :: Gen (Maybe PraosNonce) genMaybePraosNonce = Gen.maybe genPraosNonce -genProtocolParameters :: Gen ProtocolParameters -genProtocolParameters = +genProtocolParameters :: CardanoEra era -> Gen ProtocolParameters +genProtocolParameters era = ProtocolParameters <$> ((,) <$> genNat <*> genNat) <*> Gen.maybe genRational @@ -852,9 +852,7 @@ genProtocolParameters = <*> genRational <*> genRational <*> Gen.maybe genLovelace - <*> return mempty - --TODO: Babbage figure out how to deal with - -- asymmetric cost model JSON instances + <*> genCostModels era <*> Gen.maybe genExecutionUnitPrices <*> Gen.maybe genExecutionUnits <*> Gen.maybe genExecutionUnits @@ -863,8 +861,8 @@ genProtocolParameters = <*> Gen.maybe genNat <*> Gen.maybe genLovelace -genProtocolParametersUpdate :: Gen ProtocolParametersUpdate -genProtocolParametersUpdate = do +genProtocolParametersUpdate :: CardanoEra era -> Gen ProtocolParametersUpdate +genProtocolParametersUpdate era = do protocolUpdateProtocolVersion <- Gen.maybe ((,) <$> genNat <*> genNat) protocolUpdateDecentralization <- Gen.maybe genRational protocolUpdateExtraPraosEntropy <- Gen.maybe genMaybePraosNonce @@ -873,7 +871,7 @@ genProtocolParametersUpdate = do protocolUpdateMaxTxSize <- Gen.maybe genNat protocolUpdateTxFeeFixed <- Gen.maybe genNat protocolUpdateTxFeePerByte <- Gen.maybe genNat - protocolUpdateMinUTxOValue <- Gen.maybe genLovelace + protocolUpdateMinUTxOValue <- preAlonzoParam era genLovelace protocolUpdateStakeAddressDeposit <- Gen.maybe genLovelace protocolUpdateStakePoolDeposit <- Gen.maybe genLovelace protocolUpdateMinPoolCost <- Gen.maybe genLovelace @@ -882,26 +880,24 @@ genProtocolParametersUpdate = do protocolUpdatePoolPledgeInfluence <- Gen.maybe genRationalInt64 protocolUpdateMonetaryExpansion <- Gen.maybe genRational protocolUpdateTreasuryCut <- Gen.maybe genRational - protocolUpdateUTxOCostPerWord <- Gen.maybe genLovelace - let protocolUpdateCostModels = mempty -- genCostModels - --TODO: Babbage figure out how to deal with - -- asymmetric cost model JSON instances - protocolUpdatePrices <- Gen.maybe genExecutionUnitPrices - protocolUpdateMaxTxExUnits <- Gen.maybe genExecutionUnits - protocolUpdateMaxBlockExUnits <- Gen.maybe genExecutionUnits - protocolUpdateMaxValueSize <- Gen.maybe genNat - protocolUpdateCollateralPercent <- Gen.maybe genNat - protocolUpdateMaxCollateralInputs <- Gen.maybe genNat + protocolUpdateUTxOCostPerWord <- alonzoParam era genLovelace + protocolUpdateCostModels <- genCostModels era + protocolUpdatePrices <- alonzoParam era genExecutionUnitPrices + protocolUpdateMaxTxExUnits <- alonzoParam era genExecutionUnits + protocolUpdateMaxBlockExUnits <- alonzoParam era genExecutionUnits + protocolUpdateMaxValueSize <- alonzoParam era genNat + protocolUpdateCollateralPercent <- alonzoParam era genNat + protocolUpdateMaxCollateralInputs <- alonzoParam era genNat protocolUpdateUTxOCostPerByte <- Gen.maybe genLovelace pure ProtocolParametersUpdate{..} -genUpdateProposal :: Gen UpdateProposal -genUpdateProposal = +genUpdateProposal :: CardanoEra era -> Gen UpdateProposal +genUpdateProposal era = UpdateProposal <$> Gen.map (Range.constant 1 3) ((,) <$> genVerificationKeyHash AsGenesisKey - <*> genProtocolParametersUpdate) + <*> genProtocolParametersUpdate era) <*> genEpochNo genCostModel :: Gen CostModel @@ -916,11 +912,13 @@ genCostModel = do genPlutusLanguage :: Gen Language genPlutusLanguage = Gen.element [PlutusV1, PlutusV2] -_genCostModels :: Gen (Map AnyPlutusScriptVersion CostModel) -_genCostModels = - Gen.map (Range.linear 0 (List.length plutusScriptVersions)) - ((,) <$> Gen.element plutusScriptVersions - <*> genCostModel) +genCostModels :: CardanoEra era -> Gen (Map AnyPlutusScriptVersion CostModel) +genCostModels era + | anyCardanoEra era >= anyCardanoEra AlonzoEra = + Gen.map + (Range.linear 0 (length plutusScriptVersions)) + ((,) <$> Gen.element plutusScriptVersions <*> genCostModel) + | otherwise = pure Map.empty where plutusScriptVersions :: [AnyPlutusScriptVersion] plutusScriptVersions = [minBound..maxBound] @@ -929,6 +927,18 @@ genExecutionUnits :: Gen ExecutionUnits genExecutionUnits = ExecutionUnits <$> Gen.integral (Range.constant 0 1000) <*> Gen.integral (Range.constant 0 1000) +-- | Gen for Alonzo-specific parameters +alonzoParam :: CardanoEra era -> Gen a -> Gen (Maybe a) +alonzoParam era gen + | anyCardanoEra era >= anyCardanoEra AlonzoEra = Just <$> gen + | otherwise = pure Nothing + +-- | 'Gen.maybe' but with condition if era is not Alonzo-based +preAlonzoParam :: CardanoEra era -> Gen a -> Gen (Maybe a) +preAlonzoParam era gen + | anyCardanoEra era >= anyCardanoEra AlonzoEra = pure Nothing + | otherwise = Gen.maybe gen + genExecutionUnitPrices :: Gen ExecutionUnitPrices genExecutionUnitPrices = ExecutionUnitPrices <$> genRational <*> genRational diff --git a/cardano-api/test/Test/Cardano/Api/Typed/CBOR.hs b/cardano-api/test/Test/Cardano/Api/Typed/CBOR.hs index 5ae41145950..7064db0cb4f 100644 --- a/cardano-api/test/Test/Cardano/Api/Typed/CBOR.hs +++ b/cardano-api/test/Test/Cardano/Api/Typed/CBOR.hs @@ -151,9 +151,12 @@ prop_roundtrip_ScriptData_CBOR :: Property prop_roundtrip_ScriptData_CBOR = roundtrip_CBOR AsHashableScriptData genHashableScriptData -prop_roundtrip_UpdateProposal_CBOR :: Property -prop_roundtrip_UpdateProposal_CBOR = - roundtrip_CBOR AsUpdateProposal genUpdateProposal +test_roundtrip_UpdateProposal_CBOR :: [TestTree] +test_roundtrip_UpdateProposal_CBOR = + [ testPropertyNamed (show era) (fromString (show era)) $ + roundtrip_CBOR AsUpdateProposal $ genUpdateProposal era + | AnyCardanoEra era <- [minBound..] + ] test_roundtrip_Tx_Cddl :: [TestTree] @@ -219,10 +222,11 @@ tests = testGroup "Test.Cardano.Api.Typed.CBOR" , testPropertyNamed "roundtrip script SimpleScriptV2 CBOR" "roundtrip script SimpleScriptV2 CBOR" prop_roundtrip_script_SimpleScriptV2_CBOR , testPropertyNamed "roundtrip script PlutusScriptV1 CBOR" "roundtrip script PlutusScriptV1 CBOR" prop_roundtrip_script_PlutusScriptV1_CBOR , testPropertyNamed "roundtrip script PlutusScriptV2 CBOR" "roundtrip script PlutusScriptV2 CBOR" prop_roundtrip_script_PlutusScriptV2_CBOR - , testPropertyNamed "roundtrip UpdateProposal CBOR" "roundtrip UpdateProposal CBOR" prop_roundtrip_UpdateProposal_CBOR , testPropertyNamed "roundtrip ScriptData CBOR" "roundtrip ScriptData CBOR" prop_roundtrip_ScriptData_CBOR - , testGroup "roundtrip txbody CBOR" test_roundtrip_txbody_CBOR - , testGroup "roundtrip tx CBOR" test_roundtrip_tx_CBOR - , testGroup "roundtrip Tx Cddl" test_roundtrip_Tx_Cddl - , testGroup "roundtrip TxWitness Cddl" test_roundtrip_TxWitness_Cddl + , testGroup "roundtrip tx CBOR" test_roundtrip_tx_CBOR + , testGroup "roundtrip tx CBOR" test_roundtrip_tx_CBOR + , testGroup "roundtrip Tx Cddl" test_roundtrip_Tx_Cddl + , testGroup "roundtrip txbody CBOR" test_roundtrip_txbody_CBOR + , testGroup "roundtrip TxWitness Cddl" test_roundtrip_TxWitness_Cddl + , testGroup "roundtrip UpdateProposal CBOR" test_roundtrip_UpdateProposal_CBOR ] diff --git a/cardano-api/test/Test/Cardano/Api/Typed/JSON.hs b/cardano-api/test/Test/Cardano/Api/Typed/JSON.hs index 1ab7048d751..99698625470 100644 --- a/cardano-api/test/Test/Cardano/Api/Typed/JSON.hs +++ b/cardano-api/test/Test/Cardano/Api/Typed/JSON.hs @@ -9,15 +9,16 @@ module Test.Cardano.Api.Typed.JSON ) where import Data.Aeson (eitherDecode, encode) - import Hedgehog (Property, forAll, tripping) +import qualified Hedgehog as H +import qualified Hedgehog.Gen as Gen import Test.Cardano.Api.Typed.Orphans () import Test.Gen.Cardano.Api.Typed (genMaybePraosNonce, genProtocolParameters) import Test.Tasty (TestTree, testGroup) import Test.Tasty.Hedgehog (testPropertyNamed) -import qualified Hedgehog as H -import qualified Hedgehog.Gen as Gen +import Cardano.Api +import Data.String (IsString (..)) {- HLINT ignore "Use camelCase" -} @@ -26,15 +27,19 @@ prop_roundtrip_praos_nonce_JSON = H.property $ do pNonce <- forAll $ Gen.just genMaybePraosNonce tripping pNonce encode eitherDecode -prop_roundtrip_protocol_parameters_JSON :: Property -prop_roundtrip_protocol_parameters_JSON = H.property $ do - pp <- forAll genProtocolParameters - tripping pp encode eitherDecode +test_roundtrip_protocol_parameters_JSON :: [TestTree] +test_roundtrip_protocol_parameters_JSON = + [ testPropertyNamed (show era) (fromString (show era)) $ + H.property $ do + pp <- forAll $ genProtocolParameters era + tripping pp encode eitherDecode + | AnyCardanoEra era <- [minBound..] + ] -- ----------------------------------------------------------------------------- tests :: TestTree tests = testGroup "Test.Cardano.Api.Typed.JSON" [ testPropertyNamed "roundtrip praos nonce JSON" "roundtrip praos nonce JSON" prop_roundtrip_praos_nonce_JSON - , testPropertyNamed "roundtrip protocol parameters JSON" "roundtrip protocol parameters JSON" prop_roundtrip_protocol_parameters_JSON + , testGroup "roundtrip protocol parameters JSON" test_roundtrip_protocol_parameters_JSON ]