Skip to content

Commit

Permalink
Merge pull request #457 from IntersectMBO/unify-json-instances
Browse files Browse the repository at this point in the history
Add golden tests to `ProtocolParameters` serialization
  • Loading branch information
palas authored Apr 16, 2024
2 parents 579c359 + 527f16c commit 3204650
Show file tree
Hide file tree
Showing 16 changed files with 942 additions and 26 deletions.
2 changes: 1 addition & 1 deletion .github/workflows/haskell.yml
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
4 changes: 4 additions & 0 deletions cardano-api/cardano-api.cabal
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand All @@ -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
Expand All @@ -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
33 changes: 15 additions & 18 deletions cardano-api/internal/Cardano/Api/ProtocolParameters.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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

Expand Down Expand Up @@ -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
Expand All @@ -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
Expand Down
Original file line number Diff line number Diff line change
Expand Up @@ -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"
Original file line number Diff line number Diff line change
@@ -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
}
Original file line number Diff line number Diff line change
Expand Up @@ -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 =
Expand Down
Loading

0 comments on commit 3204650

Please sign in to comment.