From a210ce47da0e19e5ae0fc826aa8a7f51c76e54f6 Mon Sep 17 00:00:00 2001 From: Duncan Coutts Date: Tue, 8 Jun 2021 12:00:10 +0100 Subject: [PATCH] Complete the round trip tests for protocol params and updates Extend the generators for the new Alonzo era fields. Add a CBOR round trip test for UpdateProposals. Fix some bugs in the JSON serialisation for the new Alonzo fields in the ProtocolParameters type, as found by the round trip test. --- cardano-api/src/Cardano/Api.hs | 4 + .../src/Cardano/Api/ProtocolParameters.hs | 37 ++++-- cardano-api/src/Cardano/Api/TxBody.hs | 3 +- .../test/Test/Cardano/Api/Typed/CBOR.hs | 5 + .../test/Test/Cardano/Api/Typed/Gen.hs | 117 +++++++++++++----- 5 files changed, 123 insertions(+), 43 deletions(-) diff --git a/cardano-api/src/Cardano/Api.hs b/cardano-api/src/Cardano/Api.hs index e44790882ac..42071daadbf 100644 --- a/cardano-api/src/Cardano/Api.hs +++ b/cardano-api/src/Cardano/Api.hs @@ -297,6 +297,7 @@ module Cardano.Api ( SimpleScriptVersion(..), PlutusScriptVersion(..), AnyScriptLanguage(..), + AnyPlutusScriptVersion(..), IsScriptLanguage(..), IsSimpleScriptLanguage(..), @@ -357,6 +358,9 @@ module Cardano.Api ( -- * Script execution units ExecutionUnits(..), + ExecutionUnitPrices(..), + CostModel(..), + validateCostModel, -- ** Script addresses -- | Making addresses from scripts. diff --git a/cardano-api/src/Cardano/Api/ProtocolParameters.hs b/cardano-api/src/Cardano/Api/ProtocolParameters.hs index 4b321a1615b..0a64761df3b 100644 --- a/cardano-api/src/Cardano/Api/ProtocolParameters.hs +++ b/cardano-api/src/Cardano/Api/ProtocolParameters.hs @@ -57,7 +57,7 @@ import Data.ByteString (ByteString) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.String (IsString) -import Data.Scientific (Scientific) +import qualified Data.Scientific as Scientific import Data.Text (Text) import GHC.Generics import Numeric.Natural @@ -66,6 +66,7 @@ import Control.Monad import Data.Aeson (FromJSON (..), ToJSON (..), object, withObject, (.!=), (.:), (.:?), (.=)) +import qualified Data.Aeson as Aeson import Data.Bifunctor (bimap) import qualified Cardano.Binary as CBOR @@ -300,10 +301,10 @@ instance FromJSON ProtocolParameters where <*> o .: "monetaryExpansion" <*> o .: "treasuryCut" <*> o .:? "utxoCostPerWord" - <*> o .:? "costModel" .!= Map.empty + <*> o .:? "costModels" .!= Map.empty <*> o .:? "executionUnitPrices" - <*> o .:? "maxTxExecUnits" - <*> o .:? "maxBlockExecUnits" + <*> o .:? "maxTxExecutionUnits" + <*> o .:? "maxBlockExecutionUnits" <*> o .:? "maxValueSize" <*> o .:? "collateralPercentage" <*> o .:? "maxCollateralInputs" @@ -315,25 +316,22 @@ instance ToJSON ProtocolParameters where , "stakePoolTargetNum" .= protocolParamStakePoolTargetNum , "minUTxOValue" .= protocolParamMinUTxOValue , "poolRetireMaxEpoch" .= protocolParamPoolRetireMaxEpoch - , "decentralization" .= (fromRational protocolParamDecentralization - :: Scientific) + , "decentralization" .= toRationalJSON protocolParamDecentralization , "stakePoolDeposit" .= protocolParamStakePoolDeposit , "maxBlockHeaderSize" .= protocolParamMaxBlockHeaderSize , "maxBlockBodySize" .= protocolParamMaxBlockBodySize , "maxTxSize" .= protocolParamMaxTxSize - , "treasuryCut" .= (fromRational protocolParamTreasuryCut - :: Scientific) + , "treasuryCut" .= toRationalJSON protocolParamTreasuryCut , "minPoolCost" .= protocolParamMinPoolCost - , "monetaryExpansion" .= (fromRational protocolParamMonetaryExpansion - :: Scientific) + , "monetaryExpansion" .= toRationalJSON protocolParamMonetaryExpansion , "stakeAddressDeposit" .= protocolParamStakeAddressDeposit - , "poolPledgeInfluence" .= (fromRational protocolParamPoolPledgeInfluence - :: Scientific) + , "poolPledgeInfluence" .= toRationalJSON protocolParamPoolPledgeInfluence , "protocolVersion" .= let (major, minor) = protocolParamProtocolVersion in object ["major" .= major, "minor" .= minor] , "txFeeFixed" .= protocolParamTxFeeFixed , "txFeePerByte" .= protocolParamTxFeePerByte -- Alonzo era: + , "utxoCostPerWord" .= protocolParamUTxOCostPerWord , "costModels" .= protocolParamCostModels , "executionUnitPrices" .= protocolParamPrices , "maxTxExecutionUnits" .= protocolParamMaxTxExUnits @@ -342,6 +340,19 @@ instance ToJSON ProtocolParameters where , "collateralPercentage" .= protocolParamCollateralPercent , "maxCollateralInputs" .= protocolParamMaxCollateralInputs ] + where + -- Rationals and JSON are an awkward mix. We cannot convert rationals + -- like @1/3@ to JSON numbers. But _most_ of the numbers we want to use + -- in practice have simple decimal representations. Our solution here is + -- to use simple decimal representations where we can and representation + -- in a @{"numerator": 1, "denominator": 3}@ style otherwise. + -- + toRationalJSON :: Rational -> Aeson.Value + toRationalJSON r = + case Scientific.fromRationalRepetend (Just 5) r of + Right (s, Nothing) -> toJSON s + _ -> toJSON r + -- ---------------------------------------------------------------------------- -- Updates to the protocol paramaters @@ -821,6 +832,8 @@ makeShelleyUpdateProposal :: ProtocolParametersUpdate -> UpdateProposal makeShelleyUpdateProposal params genesisKeyHashes = --TODO decide how to handle parameter validation + -- for example we need to validate the Rational values can convert + -- into the UnitInterval type ok. UpdateProposal (Map.fromList [ (kh, params) | kh <- genesisKeyHashes ]) diff --git a/cardano-api/src/Cardano/Api/TxBody.hs b/cardano-api/src/Cardano/Api/TxBody.hs index c05642552b1..03e9842a7f9 100644 --- a/cardano-api/src/Cardano/Api/TxBody.hs +++ b/cardano-api/src/Cardano/Api/TxBody.hs @@ -2096,7 +2096,8 @@ makeShelleyTransactionBody era@ShelleyBasedEraAlonzo case txProtocolParams of BuildTxWith Nothing | not (Set.null languages) -> Left TxBodyMissingProtocolParams - _ -> return () + _ -> return () --TODO alonzo: validate protocol params for the Alonzo era. + -- All the necessary params must be provided. return $ ShelleyTxBody era diff --git a/cardano-api/test/Test/Cardano/Api/Typed/CBOR.hs b/cardano-api/test/Test/Cardano/Api/Typed/CBOR.hs index fe109371447..ea4a3b9ec3a 100644 --- a/cardano-api/test/Test/Cardano/Api/Typed/CBOR.hs +++ b/cardano-api/test/Test/Cardano/Api/Typed/CBOR.hs @@ -147,6 +147,11 @@ prop_roundtrip_script_PlutusScriptV1_CBOR = roundtrip_CBOR (AsScript AsPlutusScriptV1) (genScript (PlutusScriptLanguage PlutusScriptV1)) +prop_roundtrip_UpdateProposal_CBOR :: Property +prop_roundtrip_UpdateProposal_CBOR = + roundtrip_CBOR AsUpdateProposal genUpdateProposal + + -- ----------------------------------------------------------------------------- roundtrip_CBOR diff --git a/cardano-api/test/Test/Cardano/Api/Typed/Gen.hs b/cardano-api/test/Test/Cardano/Api/Typed/Gen.hs index 06856f6357a..a9c0627a621 100644 --- a/cardano-api/test/Test/Cardano/Api/Typed/Gen.hs +++ b/cardano-api/test/Test/Cardano/Api/Typed/Gen.hs @@ -36,6 +36,8 @@ module Test.Cardano.Api.Typed.Gen , genValue , genValueDefault , genVerificationKey + , genUpdateProposal + , genProtocolParametersUpdate ) where import Cardano.Api @@ -45,7 +47,6 @@ import Cardano.Api.Shelley import Cardano.Prelude import Control.Monad.Fail (fail) -import qualified Data.Map.Strict as Map import Data.String import qualified Data.ByteString as BS import qualified Data.ByteString.Short as SBS @@ -55,7 +56,6 @@ import qualified Cardano.Crypto.Hash as Crypto import qualified Cardano.Crypto.Seed as Crypto import qualified Shelley.Spec.Ledger.TxBody as Ledger (EraIndependentTxBody) - import Hedgehog (Gen, Range) import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range @@ -513,27 +513,13 @@ genTxCertificates era = genTxUpdateProposal :: CardanoEra era -> Gen (TxUpdateProposal era) genTxUpdateProposal era = - case era of - ByronEra -> pure TxUpdateProposalNone - ShelleyEra -> - Gen.choice - [ pure TxUpdateProposalNone - , pure (TxUpdateProposal UpdateProposalInShelleyEra emptyUpdateProposal) -- TODO: Generate proposals - ] - AllegraEra -> + case updateProposalSupportedInEra era of + Nothing -> pure TxUpdateProposalNone + Just supported -> Gen.choice [ pure TxUpdateProposalNone - , pure (TxUpdateProposal UpdateProposalInAllegraEra emptyUpdateProposal) -- TODO: Generate proposals + , TxUpdateProposal supported <$> genUpdateProposal ] - MaryEra -> - Gen.choice - [ pure TxUpdateProposalNone - , pure (TxUpdateProposal UpdateProposalInMaryEra emptyUpdateProposal) -- TODO: Generate proposals - ] - AlonzoEra -> panic "genTxUpdateProposal: Alonzo not implemented yet" - where - emptyUpdateProposal :: UpdateProposal - emptyUpdateProposal = UpdateProposal Map.empty (EpochNo 0) genTxMintValue :: CardanoEra era -> Gen (TxMintValue BuildTx era) genTxMintValue era = @@ -630,6 +616,10 @@ genTx era = genVerificationKey :: Key keyrole => AsType keyrole -> Gen (VerificationKey keyrole) genVerificationKey roletoken = getVerificationKey <$> genSigningKey roletoken +genVerificationKeyHash :: Key keyrole => AsType keyrole -> Gen (Hash keyrole) +genVerificationKeyHash roletoken = + verificationKeyHash <$> genVerificationKey roletoken + genByronKeyWitness :: Gen (KeyWitness ByronEra) genByronKeyWitness = do pmId <- genProtocolMagicId @@ -689,7 +679,14 @@ genNat :: Gen Natural genNat = Gen.integral (Range.linear 0 10) genRational :: Gen Rational -genRational = Gen.realFrac_ (Range.linearFrac 0 1) +genRational = + (\d -> ratioToRational (1 % d)) <$> genDenominator + where + genDenominator :: Gen Word64 + genDenominator = Gen.integral (Range.linear 1 maxBound) + + ratioToRational :: Ratio Word64 -> Rational + ratioToRational = toRational genEpochNo :: Gen EpochNo genEpochNo = EpochNo <$> Gen.word64 (Range.linear 0 10) @@ -720,13 +717,73 @@ genProtocolParameters = <*> genRational <*> genRational <*> genRational - -- TODO alonzo: Add proper support for these generators. - <*> return Nothing - <*> return mempty - <*> return Nothing - <*> return Nothing - <*> return Nothing - <*> return Nothing - <*> return Nothing - <*> return Nothing + <*> Gen.maybe genLovelace + <*> genCostModels + <*> Gen.maybe genExecutionUnitPrices + <*> Gen.maybe genExecutionUnits + <*> Gen.maybe genExecutionUnits + <*> Gen.maybe genNat + <*> Gen.maybe genNat + <*> Gen.maybe genNat + +genProtocolParametersUpdate :: Gen ProtocolParametersUpdate +genProtocolParametersUpdate = + ProtocolParametersUpdate + <$> Gen.maybe ((,) <$> genNat <*> genNat) + <*> Gen.maybe genRational + <*> Gen.maybe genMaybePraosNonce + <*> Gen.maybe genNat + <*> Gen.maybe genNat + <*> Gen.maybe genNat + <*> Gen.maybe genNat + <*> Gen.maybe genNat + <*> Gen.maybe genLovelace + <*> Gen.maybe genLovelace + <*> Gen.maybe genLovelace + <*> Gen.maybe genLovelace + <*> Gen.maybe genEpochNo + <*> Gen.maybe genNat + <*> Gen.maybe genRational + <*> Gen.maybe genRational + <*> Gen.maybe genRational + <*> Gen.maybe genLovelace + <*> genCostModels + <*> Gen.maybe genExecutionUnitPrices + <*> Gen.maybe genExecutionUnits + <*> Gen.maybe genExecutionUnits + <*> Gen.maybe genNat + <*> Gen.maybe genNat + <*> Gen.maybe genNat + + +genUpdateProposal :: Gen UpdateProposal +genUpdateProposal = + UpdateProposal + <$> Gen.map (Range.constant 1 3) + ((,) <$> genVerificationKeyHash AsGenesisKey + <*> genProtocolParametersUpdate) + <*> genEpochNo + +genCostModel :: Gen CostModel +genCostModel = + CostModel + <$> Gen.map (Range.constant 1 10) + ((,) <$> Gen.text (Range.constant 1 10) Gen.alphaNum + <*> Gen.integral (Range.linear 0 5000)) + +genCostModels :: Gen (Map AnyPlutusScriptVersion CostModel) +genCostModels = + Gen.map (Range.linear 0 (length plutusScriptVersions)) + ((,) <$> Gen.element plutusScriptVersions + <*> genCostModel) + where + plutusScriptVersions :: [AnyPlutusScriptVersion] + plutusScriptVersions = [minBound..maxBound] + +genExecutionUnits :: Gen ExecutionUnits +genExecutionUnits = ExecutionUnits <$> Gen.integral (Range.constant 0 1000) + <*> Gen.integral (Range.constant 0 1000) + +genExecutionUnitPrices :: Gen ExecutionUnitPrices +genExecutionUnitPrices = ExecutionUnitPrices <$> genLovelace <*> genLovelace