diff --git a/.github/workflows/haskell.yml b/.github/workflows/haskell.yml index 8250d903e4..0b275aaf41 100644 --- a/.github/workflows/haskell.yml +++ b/.github/workflows/haskell.yml @@ -40,7 +40,7 @@ jobs: env: # Modify this value to "invalidate" the cabal cache. - CABAL_CACHE_VERSION: "2024-02-15" + CABAL_CACHE_VERSION: "2024-02-29-golden" # these two are msys2 env vars, they have no effect on non-msys2 installs. MSYS2_PATH_TYPE: inherit MSYSTEM: MINGW64 diff --git a/cardano-api/cardano-api.cabal b/cardano-api/cardano-api.cabal index 1cf0acdc1c..8c024426b0 100644 --- a/cardano-api/cardano-api.cabal +++ b/cardano-api/cardano-api.cabal @@ -333,6 +333,7 @@ test-suite cardano-api-test Test.Cardano.Api.KeysByron Test.Cardano.Api.Ledger Test.Cardano.Api.Metadata + Test.Cardano.Api.ProtocolParameters Test.Cardano.Api.Typed.Address Test.Cardano.Api.Typed.Bech32 Test.Cardano.Api.Typed.CBOR @@ -358,11 +359,13 @@ test-suite cardano-api-golden , bytestring , cardano-api , cardano-api:gen + , cardano-api:internal , cardano-binary , cardano-crypto-class ^>= 2.1.2 , cardano-data >= 1.0 , cardano-ledger-alonzo , cardano-ledger-api ^>= 1.9 + , cardano-ledger-babbage >= 1.6.0 , cardano-ledger-core:{cardano-ledger-core, testlib} >= 1.8 , cardano-ledger-shelley , cardano-ledger-shelley-test >= 1.2.0.1 @@ -389,4 +392,5 @@ test-suite cardano-api-golden , Test.Golden.Cardano.Api.Ledger , Test.Golden.Cardano.Api.Typed.Script , Test.Golden.Cardano.Api.Value + , Test.Golden.Cardano.Api.ProtocolParameters , Test.Golden.ErrorsSpec diff --git a/cardano-api/internal/Cardano/Api/ProtocolParameters.hs b/cardano-api/internal/Cardano/Api/ProtocolParameters.hs index 36edcf38e2..66cca504eb 100644 --- a/cardano-api/internal/Cardano/Api/ProtocolParameters.hs +++ b/cardano-api/internal/Cardano/Api/ProtocolParameters.hs @@ -1632,22 +1632,9 @@ toAlonzoPParams protocolParamDecentralization } = do ppAlonzoCommon <- toAlonzoCommonPParams protocolParameters - -- QUESTION? This is strange, why do we need to construct Alonzo Tx with Babbage PParams? - -- This feels to me like an issue with the api design, as there should never be such an - -- inconsistency, because PParams affect the validity of the transaction. - d <- case protocolParamDecentralization of - -- The decentralization parameter is deprecated in Babbage - -- so we default to 0 if no decentralization parameter is found - -- in the api's 'ProtocolParameter' type. If we don't do this - -- we won't be able to construct an Alonzo tx using the Babbage - -- era's protocol parameter because our only other option is to - -- error. - Nothing -> Right minBound - Just dParam -> boundRationalEither "D" dParam - -- This is the correct implementation that should be the used instead: - -- d <- requireParam "protocolParamDecentralization" - -- (boundRationalEither "D") - -- protocolParamDecentralization + d <- requireParam "protocolParamDecentralization" + (boundRationalEither "D") + protocolParamDecentralization let ppAlonzo = ppAlonzoCommon & ppDL .~ d @@ -1685,7 +1672,7 @@ fromLedgerPParams fromLedgerPParams ShelleyBasedEraShelley = fromShelleyPParams fromLedgerPParams ShelleyBasedEraAllegra = fromShelleyPParams fromLedgerPParams ShelleyBasedEraMary = fromShelleyPParams -fromLedgerPParams ShelleyBasedEraAlonzo = fromAlonzoPParams +fromLedgerPParams ShelleyBasedEraAlonzo = fromExactlyAlonzoPParams fromLedgerPParams ShelleyBasedEraBabbage = fromBabbagePParams fromLedgerPParams ShelleyBasedEraConway = fromConwayPParams @@ -1743,6 +1730,7 @@ fromAlonzoPParams :: AlonzoEraPParams ledgerera fromAlonzoPParams pp = (fromShelleyCommonPParams pp) { protocolParamCostModels = fromAlonzoCostModels $ pp ^. ppCostModelsL + , protocolParamDecentralization = Just . Ledger.unboundRational $ pp ^. ppDG , protocolParamPrices = Just . fromAlonzoPrices $ pp ^. ppPricesL , protocolParamMaxTxExUnits = Just . fromAlonzoExUnits $ pp ^. ppMaxTxExUnitsL , protocolParamMaxBlockExUnits = Just . fromAlonzoExUnits $ pp ^. ppMaxBlockExUnitsL @@ -1751,13 +1739,22 @@ fromAlonzoPParams pp = , protocolParamMaxCollateralInputs = Just $ pp ^. ppMaxCollateralInputsL } +fromExactlyAlonzoPParams :: (AlonzoEraPParams ledgerera, Ledger.ExactEra Ledger.AlonzoEra ledgerera) + => PParams ledgerera + -> ProtocolParameters +fromExactlyAlonzoPParams pp = + (fromAlonzoPParams pp) { + protocolParamUTxOCostPerByte = Just . unCoinPerWord $ pp ^. ppCoinsPerUTxOWordL + } + fromBabbagePParams :: BabbageEraPParams ledgerera => PParams ledgerera -> ProtocolParameters fromBabbagePParams pp = (fromAlonzoPParams pp) { protocolParamUTxOCostPerByte = Just . unCoinPerByte $ pp ^. ppCoinsPerUTxOByteL - } + , protocolParamDecentralization = Nothing + } fromConwayPParams :: BabbageEraPParams ledgerera => PParams ledgerera diff --git a/cardano-api/test/cardano-api-golden/Test/Golden/Cardano/Api/Ledger.hs b/cardano-api/test/cardano-api-golden/Test/Golden/Cardano/Api/Ledger.hs index 958e63c908..44863fb2c9 100644 --- a/cardano-api/test/cardano-api-golden/Test/Golden/Cardano/Api/Ledger.hs +++ b/cardano-api/test/cardano-api-golden/Test/Golden/Cardano/Api/Ledger.hs @@ -11,4 +11,4 @@ import Test.Tasty.Hedgehog (testProperty) test_golden_ShelleyGenesis :: TestTree test_golden_ShelleyGenesis = testProperty "golden ShelleyGenesis" $ - H.goldenTestJsonValuePretty exampleShelleyGenesis "test/cardano-api-golden/files/golden/ShelleyGenesis" + H.goldenTestJsonValuePretty exampleShelleyGenesis "test/cardano-api-golden/files/golden/ShelleyGenesis.json" diff --git a/cardano-api/test/cardano-api-golden/Test/Golden/Cardano/Api/ProtocolParameters.hs b/cardano-api/test/cardano-api-golden/Test/Golden/Cardano/Api/ProtocolParameters.hs new file mode 100644 index 0000000000..1e9df10ba0 --- /dev/null +++ b/cardano-api/test/cardano-api-golden/Test/Golden/Cardano/Api/ProtocolParameters.hs @@ -0,0 +1,121 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Test.Golden.Cardano.Api.ProtocolParameters + ( test_golden_ProtocolParameters + , test_golden_ProtocolParameters_to_PParams + ) where + +import Cardano.Api (AnyPlutusScriptVersion (AnyPlutusScriptVersion), CostModel (..), + ExecutionUnits (..), PlutusScriptVersion (..), makePraosNonce) +import Cardano.Api.Ledger (Coin (..), EpochInterval (EpochInterval), StandardCrypto) +import Cardano.Api.ProtocolParameters (ExecutionUnitPrices (..), ProtocolParameters (..)) + +import Cardano.Ledger.Alonzo (AlonzoEra) +import Cardano.Ledger.Alonzo.PParams (AlonzoPParams (..)) +import Cardano.Ledger.Babbage (BabbageEra) +import Cardano.Ledger.Babbage.PParams (BabbagePParams (..)) +import Cardano.Ledger.Plutus.CostModels (costModelParamsCount) +import Cardano.Ledger.Plutus.Language (Language (..)) +import Cardano.Ledger.Shelley (ShelleyEra) +import Cardano.Ledger.Shelley.PParams (ShelleyPParams (..)) + +import Data.Aeson (FromJSON, eitherDecode, encode) +import Data.ByteString.Lazy (ByteString) +import Data.Functor.Identity (Identity) +import Data.Map (Map) +import qualified Data.Map as M +import Data.Proxy (Proxy (..)) + +import Hedgehog (Property, property, success) +import qualified Hedgehog.Extras.Aeson as H +import Hedgehog.Internal.Property (failWith) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.Hedgehog (testProperty) + +test_golden_ProtocolParameters :: TestTree +test_golden_ProtocolParameters = testProperty "golden ProtocolParameters" $ do + H.goldenTestJsonValuePretty legacyCardanoApiProtocolParameters "test/cardano-api-golden/files/golden/LegacyProtocolParameters.json" + +test_golden_ProtocolParameters_to_PParams :: TestTree +test_golden_ProtocolParameters_to_PParams = + testGroup "golden ProtocolParameter tests" + [ testProperty "ShelleyPParams" $ + goldenLegacyProtocolParametersToPParams (Proxy :: Proxy (ShelleyPParams Identity (ShelleyEra StandardCrypto))) + , testProperty "AlonzoPParams" $ + goldenLegacyProtocolParametersToPParams (Proxy :: Proxy (AlonzoPParams Identity (AlonzoEra StandardCrypto))) + , testProperty "BabbagePParams" $ + goldenLegacyProtocolParametersToPParams (Proxy :: Proxy (BabbagePParams Identity (BabbageEra StandardCrypto))) + ] + +-- Test that tries decoding the legacy protocol parameters golden file +-- 'legacyCardanoApiProtocolParameters' as the type provided as a 'Proxy'. +goldenLegacyProtocolParametersToPParams :: forall pp. FromJSON pp => Proxy pp -> Property +goldenLegacyProtocolParametersToPParams proxy = + property $ case decodedLegacyCardanoApiProtocolParameters of + Left err -> failWith Nothing + ("goldenLegacyProtocolParametersToPParams could not decode golden file as " + <> show proxy + <> ": " + <> show err) + Right _ -> success + where + bytestringLegacyCardanoApiProtocolParameters :: ByteString + bytestringLegacyCardanoApiProtocolParameters = encode legacyCardanoApiProtocolParameters + + decodedLegacyCardanoApiProtocolParameters :: Either String pp + decodedLegacyCardanoApiProtocolParameters = eitherDecode bytestringLegacyCardanoApiProtocolParameters + +legacyCardanoApiProtocolParameters :: ProtocolParameters +legacyCardanoApiProtocolParameters = ProtocolParameters { protocolParamUTxOCostPerByte = Just $ Coin 1_000_000 + , protocolParamTxFeePerByte = Coin 2_000_000 + , protocolParamTxFeeFixed = Coin 1_500_000 + , protocolParamTreasuryCut = 0.1 + , protocolParamStakePoolTargetNum = 100 + , protocolParamStakePoolDeposit = Coin 1_000_000_000 + , protocolParamStakeAddressDeposit = Coin 10_000_000 + , protocolParamProtocolVersion = (2, 3) + , protocolParamPrices = Just executionUnitPrices + , protocolParamPoolRetireMaxEpoch = Cardano.Api.Ledger.EpochInterval 4 + , protocolParamPoolPledgeInfluence = 0.54 + , protocolParamMonetaryExpansion = 0.23 + , protocolParamMinUTxOValue = Just $ Coin 3_000_000 + , protocolParamMinPoolCost = Coin 3_500_000 + , protocolParamMaxValueSize = Just 10 + , protocolParamMaxTxSize = 3000 + , protocolParamMaxTxExUnits = Just executionUnits + , protocolParamMaxCollateralInputs = Just 10 + , protocolParamMaxBlockHeaderSize = 1200 + , protocolParamMaxBlockExUnits = Just executionUnits2 + , protocolParamMaxBlockBodySize = 5000 + , protocolParamExtraPraosEntropy = Just $ makePraosNonce "entropyEntropy" + , protocolParamDecentralization = Just 0.52 + , protocolParamCostModels = costModels + , protocolParamCollateralPercent = Just 23 + } + where + executionUnitPrices :: ExecutionUnitPrices + executionUnitPrices = ExecutionUnitPrices { priceExecutionSteps = 0.3 + , priceExecutionMemory = 0.2 + } + + costModels :: Map AnyPlutusScriptVersion CostModel + costModels = M.fromList [ (AnyPlutusScriptVersion PlutusScriptV3, CostModel [1..numParams PlutusV3]) + , (AnyPlutusScriptVersion PlutusScriptV2, CostModel [1..numParams PlutusV2]) + , (AnyPlutusScriptVersion PlutusScriptV1, CostModel [1..numParams PlutusV1]) + ] + + numParams :: Language -> Integer + numParams = fromIntegral . costModelParamsCount + + executionUnits :: ExecutionUnits + executionUnits = ExecutionUnits { executionSteps = 4300 + , executionMemory = 2300 + } + + executionUnits2 :: ExecutionUnits + executionUnits2 = ExecutionUnits { executionSteps = 5600 + , executionMemory = 3400 + } diff --git a/cardano-api/test/cardano-api-golden/Test/Golden/Cardano/Api/Typed/Script.hs b/cardano-api/test/cardano-api-golden/Test/Golden/Cardano/Api/Typed/Script.hs index 571f862eb4..138a48ab79 100644 --- a/cardano-api/test/cardano-api-golden/Test/Golden/Cardano/Api/Typed/Script.hs +++ b/cardano-api/test/cardano-api-golden/Test/Golden/Cardano/Api/Typed/Script.hs @@ -92,32 +92,32 @@ goldenPath = "test/cardano-api-golden/files/golden/Script" test_golden_SimpleScriptV1_All :: TestTree test_golden_SimpleScriptV1_All = testProperty "golden SimpleScriptV1 All" $ - goldenTestJsonValuePretty exampleSimpleScriptV1_All (goldenPath "SimpleV1/all") + goldenTestJsonValuePretty exampleSimpleScriptV1_All (goldenPath "SimpleV1/all.script") test_golden_SimpleScriptV1_Any :: TestTree test_golden_SimpleScriptV1_Any = testProperty "golden SimpleScriptV1 Any" $ - goldenTestJsonValuePretty exampleSimpleScriptV1_Any (goldenPath "SimpleV1/any") + goldenTestJsonValuePretty exampleSimpleScriptV1_Any (goldenPath "SimpleV1/any.script") test_golden_SimpleScriptV1_MofN :: TestTree test_golden_SimpleScriptV1_MofN = testProperty "golden SimpleScriptV1 MofN" $ - goldenTestJsonValuePretty exampleSimpleScriptV1_MofN (goldenPath "SimpleV1/atleast") + goldenTestJsonValuePretty exampleSimpleScriptV1_MofN (goldenPath "SimpleV1/atleast.script") test_golden_SimpleScriptV2_All :: TestTree test_golden_SimpleScriptV2_All = testProperty "golden SimpleScriptV2 All" $ - goldenTestJsonValuePretty exampleSimpleScriptV2_All (goldenPath "SimpleV2/all") + goldenTestJsonValuePretty exampleSimpleScriptV2_All (goldenPath "SimpleV2/all.script") test_golden_SimpleScriptV2_Any :: TestTree test_golden_SimpleScriptV2_Any = testProperty "golden SimpleScriptV2 Any" $ - goldenTestJsonValuePretty exampleSimpleScriptV2_Any (goldenPath "SimpleV2/any") + goldenTestJsonValuePretty exampleSimpleScriptV2_Any (goldenPath "SimpleV2/any.script") test_golden_SimpleScriptV2_MofN :: TestTree test_golden_SimpleScriptV2_MofN = testProperty "golden SimpleScriptV2 MofN" $ - goldenTestJsonValuePretty exampleSimpleScriptV2_MofN (goldenPath "SimpleV2/atleast") + goldenTestJsonValuePretty exampleSimpleScriptV2_MofN (goldenPath "SimpleV2/atleast.script") test_roundtrip_SimpleScript_JSON :: TestTree test_roundtrip_SimpleScript_JSON = diff --git a/cardano-api/test/cardano-api-golden/files/golden/LegacyProtocolParameters.json b/cardano-api/test/cardano-api-golden/files/golden/LegacyProtocolParameters.json new file mode 100644 index 0000000000..f2dd7a00c8 --- /dev/null +++ b/cardano-api/test/cardano-api-golden/files/golden/LegacyProtocolParameters.json @@ -0,0 +1,620 @@ +{ + "collateralPercentage": 23, + "costModels": { + "PlutusV1": [ + 1, + 2, + 3, + 4, + 5, + 6, + 7, + 8, + 9, + 10, + 11, + 12, + 13, + 14, + 15, + 16, + 17, + 18, + 19, + 20, + 21, + 22, + 23, + 24, + 25, + 26, + 27, + 28, + 29, + 30, + 31, + 32, + 33, + 34, + 35, + 36, + 37, + 38, + 39, + 40, + 41, + 42, + 43, + 44, + 45, + 46, + 47, + 48, + 49, + 50, + 51, + 52, + 53, + 54, + 55, + 56, + 57, + 58, + 59, + 60, + 61, + 62, + 63, + 64, + 65, + 66, + 67, + 68, + 69, + 70, + 71, + 72, + 73, + 74, + 75, + 76, + 77, + 78, + 79, + 80, + 81, + 82, + 83, + 84, + 85, + 86, + 87, + 88, + 89, + 90, + 91, + 92, + 93, + 94, + 95, + 96, + 97, + 98, + 99, + 100, + 101, + 102, + 103, + 104, + 105, + 106, + 107, + 108, + 109, + 110, + 111, + 112, + 113, + 114, + 115, + 116, + 117, + 118, + 119, + 120, + 121, + 122, + 123, + 124, + 125, + 126, + 127, + 128, + 129, + 130, + 131, + 132, + 133, + 134, + 135, + 136, + 137, + 138, + 139, + 140, + 141, + 142, + 143, + 144, + 145, + 146, + 147, + 148, + 149, + 150, + 151, + 152, + 153, + 154, + 155, + 156, + 157, + 158, + 159, + 160, + 161, + 162, + 163, + 164, + 165, + 166 + ], + "PlutusV2": [ + 1, + 2, + 3, + 4, + 5, + 6, + 7, + 8, + 9, + 10, + 11, + 12, + 13, + 14, + 15, + 16, + 17, + 18, + 19, + 20, + 21, + 22, + 23, + 24, + 25, + 26, + 27, + 28, + 29, + 30, + 31, + 32, + 33, + 34, + 35, + 36, + 37, + 38, + 39, + 40, + 41, + 42, + 43, + 44, + 45, + 46, + 47, + 48, + 49, + 50, + 51, + 52, + 53, + 54, + 55, + 56, + 57, + 58, + 59, + 60, + 61, + 62, + 63, + 64, + 65, + 66, + 67, + 68, + 69, + 70, + 71, + 72, + 73, + 74, + 75, + 76, + 77, + 78, + 79, + 80, + 81, + 82, + 83, + 84, + 85, + 86, + 87, + 88, + 89, + 90, + 91, + 92, + 93, + 94, + 95, + 96, + 97, + 98, + 99, + 100, + 101, + 102, + 103, + 104, + 105, + 106, + 107, + 108, + 109, + 110, + 111, + 112, + 113, + 114, + 115, + 116, + 117, + 118, + 119, + 120, + 121, + 122, + 123, + 124, + 125, + 126, + 127, + 128, + 129, + 130, + 131, + 132, + 133, + 134, + 135, + 136, + 137, + 138, + 139, + 140, + 141, + 142, + 143, + 144, + 145, + 146, + 147, + 148, + 149, + 150, + 151, + 152, + 153, + 154, + 155, + 156, + 157, + 158, + 159, + 160, + 161, + 162, + 163, + 164, + 165, + 166, + 167, + 168, + 169, + 170, + 171, + 172, + 173, + 174, + 175 + ], + "PlutusV3": [ + 1, + 2, + 3, + 4, + 5, + 6, + 7, + 8, + 9, + 10, + 11, + 12, + 13, + 14, + 15, + 16, + 17, + 18, + 19, + 20, + 21, + 22, + 23, + 24, + 25, + 26, + 27, + 28, + 29, + 30, + 31, + 32, + 33, + 34, + 35, + 36, + 37, + 38, + 39, + 40, + 41, + 42, + 43, + 44, + 45, + 46, + 47, + 48, + 49, + 50, + 51, + 52, + 53, + 54, + 55, + 56, + 57, + 58, + 59, + 60, + 61, + 62, + 63, + 64, + 65, + 66, + 67, + 68, + 69, + 70, + 71, + 72, + 73, + 74, + 75, + 76, + 77, + 78, + 79, + 80, + 81, + 82, + 83, + 84, + 85, + 86, + 87, + 88, + 89, + 90, + 91, + 92, + 93, + 94, + 95, + 96, + 97, + 98, + 99, + 100, + 101, + 102, + 103, + 104, + 105, + 106, + 107, + 108, + 109, + 110, + 111, + 112, + 113, + 114, + 115, + 116, + 117, + 118, + 119, + 120, + 121, + 122, + 123, + 124, + 125, + 126, + 127, + 128, + 129, + 130, + 131, + 132, + 133, + 134, + 135, + 136, + 137, + 138, + 139, + 140, + 141, + 142, + 143, + 144, + 145, + 146, + 147, + 148, + 149, + 150, + 151, + 152, + 153, + 154, + 155, + 156, + 157, + 158, + 159, + 160, + 161, + 162, + 163, + 164, + 165, + 166, + 167, + 168, + 169, + 170, + 171, + 172, + 173, + 174, + 175, + 176, + 177, + 178, + 179, + 180, + 181, + 182, + 183, + 184, + 185, + 186, + 187, + 188, + 189, + 190, + 191, + 192, + 193, + 194, + 195, + 196, + 197, + 198, + 199, + 200, + 201, + 202, + 203, + 204, + 205, + 206, + 207, + 208, + 209, + 210, + 211, + 212, + 213, + 214, + 215, + 216, + 217, + 218, + 219, + 220, + 221, + 222, + 223, + 224, + 225, + 226, + 227, + 228, + 229, + 230, + 231, + 232, + 233 + ] + }, + "decentralization": 0.52, + "executionUnitPrices": { + "priceMemory": 0.2, + "priceSteps": 0.3 + }, + "extraPraosEntropy": "853a190a0ee6ca25de8b22f69624799a8db530d561dce9183029fe7a2ed29c6f", + "maxBlockBodySize": 5000, + "maxBlockExecutionUnits": { + "memory": 3400, + "steps": 5600 + }, + "maxBlockHeaderSize": 1200, + "maxCollateralInputs": 10, + "maxTxExecutionUnits": { + "memory": 2300, + "steps": 4300 + }, + "maxTxSize": 3000, + "maxValueSize": 10, + "minPoolCost": 3500000, + "minUTxOValue": 3000000, + "monetaryExpansion": 0.23, + "poolPledgeInfluence": 0.54, + "poolRetireMaxEpoch": 4, + "protocolVersion": { + "major": 2, + "minor": 3 + }, + "stakeAddressDeposit": 10000000, + "stakePoolDeposit": 1000000000, + "stakePoolTargetNum": 100, + "treasuryCut": 0.1, + "txFeeFixed": 1500000, + "txFeePerByte": 2000000, + "utxoCostPerByte": 1000000 +} \ No newline at end of file diff --git a/cardano-api/test/cardano-api-golden/files/golden/Script/SimpleV1/all b/cardano-api/test/cardano-api-golden/files/golden/Script/SimpleV1/all.script similarity index 100% rename from cardano-api/test/cardano-api-golden/files/golden/Script/SimpleV1/all rename to cardano-api/test/cardano-api-golden/files/golden/Script/SimpleV1/all.script diff --git a/cardano-api/test/cardano-api-golden/files/golden/Script/SimpleV1/any b/cardano-api/test/cardano-api-golden/files/golden/Script/SimpleV1/any.script similarity index 100% rename from cardano-api/test/cardano-api-golden/files/golden/Script/SimpleV1/any rename to cardano-api/test/cardano-api-golden/files/golden/Script/SimpleV1/any.script diff --git a/cardano-api/test/cardano-api-golden/files/golden/Script/SimpleV1/atleast b/cardano-api/test/cardano-api-golden/files/golden/Script/SimpleV1/atleast.script similarity index 100% rename from cardano-api/test/cardano-api-golden/files/golden/Script/SimpleV1/atleast rename to cardano-api/test/cardano-api-golden/files/golden/Script/SimpleV1/atleast.script diff --git a/cardano-api/test/cardano-api-golden/files/golden/Script/SimpleV2/all b/cardano-api/test/cardano-api-golden/files/golden/Script/SimpleV2/all.script similarity index 100% rename from cardano-api/test/cardano-api-golden/files/golden/Script/SimpleV2/all rename to cardano-api/test/cardano-api-golden/files/golden/Script/SimpleV2/all.script diff --git a/cardano-api/test/cardano-api-golden/files/golden/Script/SimpleV2/any b/cardano-api/test/cardano-api-golden/files/golden/Script/SimpleV2/any.script similarity index 100% rename from cardano-api/test/cardano-api-golden/files/golden/Script/SimpleV2/any rename to cardano-api/test/cardano-api-golden/files/golden/Script/SimpleV2/any.script diff --git a/cardano-api/test/cardano-api-golden/files/golden/Script/SimpleV2/atleast b/cardano-api/test/cardano-api-golden/files/golden/Script/SimpleV2/atleast.script similarity index 100% rename from cardano-api/test/cardano-api-golden/files/golden/Script/SimpleV2/atleast rename to cardano-api/test/cardano-api-golden/files/golden/Script/SimpleV2/atleast.script diff --git a/cardano-api/test/cardano-api-golden/files/golden/ShelleyGenesis b/cardano-api/test/cardano-api-golden/files/golden/ShelleyGenesis.json similarity index 100% rename from cardano-api/test/cardano-api-golden/files/golden/ShelleyGenesis rename to cardano-api/test/cardano-api-golden/files/golden/ShelleyGenesis.json diff --git a/cardano-api/test/cardano-api-test/Test/Cardano/Api/ProtocolParameters.hs b/cardano-api/test/cardano-api-test/Test/Cardano/Api/ProtocolParameters.hs new file mode 100644 index 0000000000..8f566ce0a7 --- /dev/null +++ b/cardano-api/test/cardano-api-test/Test/Cardano/Api/ProtocolParameters.hs @@ -0,0 +1,172 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + +module Test.Cardano.Api.ProtocolParameters + ( tests + ) where + +import Cardano.Api (CardanoEra (..), ProtocolParametersConversionError, inEonForEra, + prettyPrintJSON) +import Cardano.Api.Eon.ShelleyBasedEra (ShelleyBasedEra (..), ShelleyLedgerEra) +import Cardano.Api.Ledger (PParams (..)) +import Cardano.Api.ProtocolParameters (LedgerProtocolParameters (..), + convertToLedgerProtocolParameters, fromLedgerPParams) + +import Control.Monad (void) +import Data.Aeson (FromJSON, Object, ToJSON, eitherDecode) +import qualified Data.Aeson.Key as Aeson +import qualified Data.Aeson.KeyMap as Aeson +import qualified Data.ByteString.Lazy as LBS +import Data.Foldable (foldl') + +import Test.Gen.Cardano.Api.Typed (genProtocolParameters) + +import Hedgehog (Gen, MonadTest, Property, forAll, property, success, (===)) +import Hedgehog.Extras (leftFail) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.Hedgehog (testProperty) + +-- Originally, cardano-api used a different type than cardano-ledger to represent +-- protocol parameters. From conway on, we aim to unify those types and use PParams. +-- These tests aim to ensure backwards compatibility between the legacy type ProtocolParams +-- and PParams for eras before conway. Conway should use PParams directly, so we don't +-- provide any tests for it. +tests :: TestTree +tests = + testGroup "ProtocolParameter tests" + [ testGroup "ToJSON instances produce the same" + [ testProperty "ShelleyEra" $ protocolParametersSerializeTheSame ShelleyEra + , testProperty "AlonzoEra" $ protocolParametersSerializeTheSame AlonzoEra + , testProperty "BabbageEra" $ protocolParametersSerializeTheSame BabbageEra + ] + , testGroup "ProtocolParameters ToJSON can be read by PParams FromJSON" + [ testProperty "ShelleyEra" $ protocolParametersAreCompatible ShelleyEra + , testProperty "AlonzoEra" $ protocolParametersAreCompatible AlonzoEra + , testProperty "BabbageEra" $ protocolParametersAreCompatible BabbageEra + ] + , testGroup "PParams roundtrip" + [ testProperty "ShelleyEra" $ roundtripBetweenPParamsAndLegacyProtocolParameters ShelleyEra + , testProperty "AlonzoEra" $ roundtripBetweenPParamsAndLegacyProtocolParameters AlonzoEra + , testProperty "BabbageEra" $ roundtripBetweenPParamsAndLegacyProtocolParameters BabbageEra + ] + ] + +-- | Compares the JSON serialization of cardano-ledger's PParams and cardano-api's ProtocolParameters and +-- | ensures that they are the same (except for the agreed changes specified in `patchProtocolParamsJSONOrFail`) +protocolParametersSerializeTheSame :: forall era. ToJSON (PParams (ShelleyLedgerEra era)) => CardanoEra era -> Property +protocolParametersSerializeTheSame era = + property $ do ValidatedSerializedPair { serializedProtocolParameters + , serializedPParams + } <- forAll $ genValidSerializedPair era + patchedserializedProtocolParameters <- patchProtocolParamsJSONOrFail era serializedProtocolParameters + serializedPParams === patchedserializedProtocolParameters + +-- | Ensure that cardano-api's legacy ProtocolParameter serialization can be deserialized by cardano-ledger's PParams FromJSON instance +protocolParametersAreCompatible :: forall era. ( ToJSON (PParams (ShelleyLedgerEra era)) + , FromJSON (PParams (ShelleyLedgerEra era)) + ) => CardanoEra era -> Property +protocolParametersAreCompatible era = + property $ do ValidatedSerializedPair { serializedProtocolParameters + , serializedPParams = _ + } <- forAll $ genValidSerializedPair era + void (leftFail (eitherDecode serializedProtocolParameters :: Either String (PParams (ShelleyLedgerEra era)))) + success + +-- | This tests that, for protocol parameter sets that can roundtrip between PParams and ProtocolParameters +-- (i.e. sets of parameters that are valid/work according to the constraints in both PParams and ProtocolParameters +-- and their conversion functions), deserializing them using PParams FromJSON instance and then serializing +-- again using PParams ToJSON instance results in the same thing. +roundtripBetweenPParamsAndLegacyProtocolParameters :: forall era. ( FromJSON (PParams (ShelleyLedgerEra era)) + , ToJSON (PParams (ShelleyLedgerEra era)) + ) => CardanoEra era -> Property +roundtripBetweenPParamsAndLegacyProtocolParameters era = + property $ do ValidatedSerializedPair { serializedProtocolParameters + , serializedPParams = _ + } <- forAll $ genValidSerializedPair era + patchedserializedProtocolParameters <- patchProtocolParamsJSONOrFail era serializedProtocolParameters + case eitherDecode serializedProtocolParameters :: Either String (PParams (ShelleyLedgerEra era)) of + Left err -> fail err + Right pParams -> prettyPrintJSON pParams === LBS.toStrict patchedserializedProtocolParameters + +------------------------- +-- Auxiliary generator -- +------------------------- + +-- | Represents a corresponding pair of serialized protocol parameters in two formats +data ValidatedSerializedPair era = ValidatedSerializedPair + { -- | Serialized cardano-api's legacy `ProtocolParameters` as a ByteString. + serializedProtocolParameters :: LBS.ByteString + , -- | Serialized cardano-ledger's `PParams` as a ByteString. + serializedPParams :: LBS.ByteString + } deriving Show + + +-- | Produces a pair of a valid cardano-api's legacy ProtocolParameters and corresponding cardano-ledger's PParams by doing a round trip +genValidSerializedPair :: forall era. ToJSON (PParams (ShelleyLedgerEra era)) => CardanoEra era -> Gen (ValidatedSerializedPair era) +genValidSerializedPair era = do + unrefinedProtocolParameters <- genProtocolParameters era + let mValidatedSerializedPair = + do unrefinedPParams <- convertToLedgerProtocolParameters sbe unrefinedProtocolParameters :: (Either ProtocolParametersConversionError (LedgerProtocolParameters era)) + let refinedProtocolParams = fromLedgerPParams sbe $ unLedgerProtocolParameters unrefinedPParams + refinedPParams <- convertToLedgerProtocolParameters sbe refinedProtocolParams + return $ ValidatedSerializedPair { serializedProtocolParameters = LBS.fromStrict $ prettyPrintJSON refinedProtocolParams + , serializedPParams = LBS.fromStrict $ prettyPrintJSON . unLedgerProtocolParameters $ refinedPParams + } + case mValidatedSerializedPair of + Right result -> return result + Left _ -> genValidSerializedPair era + where + sbe :: ShelleyBasedEra era + sbe = toShelleyBased era + + toShelleyBased :: CardanoEra era -> ShelleyBasedEra era + toShelleyBased = inEonForEra (error "Not a Shelley-based era") id + +-- Legacy representation of 'ProtocolParameters' in cardano-api is not 100% compatible with +-- the 'PParams' representation in cardano-ledger. This functions modifies the JSON object +-- produced by the serialization of 'ProtocolParameters' type to match 'PParams' serialization +-- format. +patchProtocolParamsJSONOrFail :: (MonadTest m, MonadFail m) => CardanoEra era -> LBS.ByteString -> m LBS.ByteString +patchProtocolParamsJSONOrFail era s = LBS.fromStrict . prettyPrintJSON + <$> (patchProtocolParamRepresentation + =<< leftFail (eitherDecode s)) + where + -- We are renaming two of the fields to match the spec. Based on discussion here: + -- https://github.com/IntersectMBO/cardano-ledger/pull/4129#discussion_r1507373498 + patchProtocolParamRepresentation :: MonadFail m => Object -> m Object + patchProtocolParamRepresentation o = do filters <- filtersForEra era + renameKey "committeeTermLength" "committeeMaxTermLength" + =<< renameKey "minCommitteeSize" "committeeMinSize" + (applyFilters filters o) + + -- Legacy ProtocolParams ToJSON renders all fields from all eras in all eras, + -- because it is the same data type for every era. But this is not backwards compatible + -- because it means that new eras can modify the fields in old eras. For this reason, when + -- comparing to PParams we use this function to filter fields that don't belong to + -- particular era we are testing. + filtersForEra :: MonadFail m => CardanoEra era -> m [String] + filtersForEra ShelleyEra = return [ "collateralPercentage", "costModels", "executionUnitPrices" + , "maxBlockExecutionUnits", "maxCollateralInputs", "maxTxExecutionUnits" + , "maxValueSize", "utxoCostPerByte" ] + filtersForEra AlonzoEra = return [ "minUTxOValue" ] + filtersForEra BabbageEra = return [ "decentralization", "extraPraosEntropy", "minUTxOValue" ] + filtersForEra era' = fail $ "filtersForEra is not defined for: " <> show era' + + applyFilters :: [String] -> Object -> Object + applyFilters filters o = foldl' (flip Aeson.delete) o (map Aeson.fromString filters) + + -- Renames the key of an entry in a JSON object. + -- If there already is a key with the new name in the object the function fails. + renameKey :: MonadFail m => String -> String -> Object -> m Object + renameKey src dest o = + let srcKey = Aeson.fromString src + destKey = Aeson.fromString dest in + case Aeson.lookup srcKey o of + Nothing -> return o + Just v -> if Aeson.member destKey o + then fail $ "renameKey failed because there is already an entry with the new name: " <> dest + else return $ Aeson.insert destKey v $ Aeson.delete srcKey o + + diff --git a/cardano-api/test/cardano-api-test/cardano-api-test.hs b/cardano-api/test/cardano-api-test/cardano-api-test.hs index 76529522ca..b0322a6f1d 100644 --- a/cardano-api/test/cardano-api-test/cardano-api-test.hs +++ b/cardano-api/test/cardano-api-test/cardano-api-test.hs @@ -13,6 +13,7 @@ import qualified Test.Cardano.Api.Json import qualified Test.Cardano.Api.KeysByron import qualified Test.Cardano.Api.Ledger import qualified Test.Cardano.Api.Metadata +import qualified Test.Cardano.Api.ProtocolParameters import qualified Test.Cardano.Api.Typed.Address import qualified Test.Cardano.Api.Typed.Bech32 import qualified Test.Cardano.Api.Typed.CBOR @@ -44,6 +45,7 @@ tests = , Test.Cardano.Api.KeysByron.tests , Test.Cardano.Api.Ledger.tests , Test.Cardano.Api.Metadata.tests + , Test.Cardano.Api.ProtocolParameters.tests , Test.Cardano.Api.Typed.Address.tests , Test.Cardano.Api.Typed.Bech32.tests , Test.Cardano.Api.Typed.CBOR.tests