Add golden tests to ProtocolParameters serialization

.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

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

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

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"

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
+                                     }

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 =