cardano-api: Fix genProtocolParametersUpdate to distinguish Alonzo-sp…

…ecifix protocol parameters
IntersectMBO · Apr 2, 2023 · 84ebff9 · 84ebff9
1 parent 8e46291
commit 84ebff9
Show file tree

Hide file tree

Showing 3 changed files with 63 additions and 44 deletions.
diff --git 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
@@ -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
@@ -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
   ]