From 6e731f6405574a93f68d849d6db4bc0cb087e2a2 Mon Sep 17 00:00:00 2001 From: teodanciu Date: Sat, 26 Aug 2023 00:18:43 +0100 Subject: [PATCH] Add `constitution` and `committee` to `ConwayGenesis` --- .../impl/src/Cardano/Ledger/Conway/Genesis.hs | 68 +++++++++++++++---- .../src/Cardano/Ledger/Conway/Translation.hs | 2 +- .../Test/Cardano/Ledger/Conway/Arbitrary.hs | 4 +- .../Ledger/Conway/Examples/Consensus.hs | 5 +- .../Ledger/Conway/Serialisation/Roundtrip.hs | 4 +- 5 files changed, 61 insertions(+), 22 deletions(-) diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Genesis.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Genesis.hs index 6328480e658..ee58c72b9dc 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Genesis.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/Genesis.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE UndecidableInstances #-} @@ -12,31 +13,70 @@ where import Cardano.Ledger.Binary ( DecCBOR (..), EncCBOR (..), + decodeNullStrictMaybe, + encodeNullStrictMaybe, ) +import Cardano.Ledger.Conway.Governance import Cardano.Ledger.Conway.PParams (UpgradeConwayPParams) -import Cardano.Ledger.Crypto (Crypto) -import Data.Aeson (FromJSON (..), ToJSON) -import Data.Aeson.Types (ToJSON (..)) +import Cardano.Ledger.Core +import Data.Aeson ( + FromJSON (..), + KeyValue (..), + ToJSON (..), + object, + pairs, + withObject, + (.:), + (.:?), + ) +import Data.Default.Class (Default (def)) import Data.Functor.Identity (Identity) +import Data.Maybe.Strict (StrictMaybe, maybeToStrictMaybe) import GHC.Generics (Generic) import NoThunks.Class (NoThunks) -newtype ConwayGenesis c = ConwayGenesis - { cgUpgradePParams :: UpgradeConwayPParams Identity +data ConwayGenesis c = ConwayGenesis + { cgUpgradePParams :: !(UpgradeConwayPParams Identity) + , cgConstitution :: !(Constitution c) + , cgCommittee :: !(StrictMaybe (Committee c)) } deriving (Eq, Generic, Show) -instance NoThunks (ConwayGenesis c) +instance Era c => NoThunks (ConwayGenesis c) -- | Genesis are always encoded with the version of era they are defined in. -instance Crypto c => DecCBOR (ConwayGenesis c) where - decCBOR = ConwayGenesis <$> decCBOR +instance Era c => DecCBOR (ConwayGenesis c) where + decCBOR = + ConwayGenesis + <$> decCBOR + <*> decCBOR + <*> decodeNullStrictMaybe decCBOR + +instance Era c => EncCBOR (ConwayGenesis c) where + encCBOR (ConwayGenesis pparams c comm) = + encCBOR pparams + <> encCBOR c + <> encodeNullStrictMaybe encCBOR comm + +instance Era c => ToJSON (ConwayGenesis c) where + toJSON = object . toConwayGenesisPairs + toEncoding = pairs . mconcat . toConwayGenesisPairs -instance Crypto c => EncCBOR (ConwayGenesis c) where - encCBOR (ConwayGenesis x) = encCBOR x +instance Era c => FromJSON (ConwayGenesis c) where + parseJSON = + withObject "ConwayGenesis" $ \obj -> + ConwayGenesis + <$> obj .: "upgradeProtocolParams" + <*> obj .: "constitution" + <*> (maybeToStrictMaybe <$> obj .:? "committee") -instance Crypto c => ToJSON (ConwayGenesis c) where - toJSON ConwayGenesis {..} = toJSON cgUpgradePParams +toConwayGenesisPairs :: (Era c, KeyValue a) => ConwayGenesis c -> [a] +toConwayGenesisPairs cg@(ConwayGenesis _ _ _) = + let ConwayGenesis {..} = cg + in [ "upgradeProtocolParams" .= cgUpgradePParams + , "constitution" .= cgConstitution + , "committee" .= cgConstitution + ] -instance Crypto c => FromJSON (ConwayGenesis c) where - parseJSON x = ConwayGenesis <$> parseJSON x +instance Era c => Default (ConwayGenesis c) where + def = ConwayGenesis def def def diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Translation.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Translation.hs index 86ff81aa1f5..e3ab51acfac 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Translation.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/Translation.hs @@ -63,7 +63,7 @@ import Lens.Micro -- being total. Do not change it! -------------------------------------------------------------------------------- -type instance TranslationContext (ConwayEra c) = ConwayGenesis c +type instance TranslationContext (ConwayEra c) = ConwayGenesis (ConwayEra c) instance Crypto c => TranslateEra (ConwayEra c) NewEpochState where translateEra ctxt nes = diff --git a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Arbitrary.hs b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Arbitrary.hs index ba2b2c59a6c..055f3b316b0 100644 --- a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Arbitrary.hs +++ b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Arbitrary.hs @@ -32,8 +32,8 @@ import Test.Cardano.Ledger.Alonzo.Arbitrary (genAlonzoScript) import Test.Cardano.Ledger.Babbage.Arbitrary () import Test.Cardano.Ledger.Common -instance Crypto c => Arbitrary (ConwayGenesis c) where - arbitrary = ConwayGenesis <$> arbitrary +instance Era c => Arbitrary (ConwayGenesis c) where + arbitrary = ConwayGenesis <$> arbitrary <*> arbitrary <*> arbitrary instance Arbitrary (UpgradeConwayPParams Identity) where arbitrary = diff --git a/eras/conway/test-suite/src/Test/Cardano/Ledger/Conway/Examples/Consensus.hs b/eras/conway/test-suite/src/Test/Cardano/Ledger/Conway/Examples/Consensus.hs index 22e4c0fc469..e784096ad20 100644 --- a/eras/conway/test-suite/src/Test/Cardano/Ledger/Conway/Examples/Consensus.hs +++ b/eras/conway/test-suite/src/Test/Cardano/Ledger/Conway/Examples/Consensus.hs @@ -200,6 +200,5 @@ exampleConwayNewEpochState = emptyPParams (emptyPParams & ppCoinsPerUTxOByteL .~ CoinPerByte (Coin 1)) -exampleConwayGenesis :: ConwayGenesis c -exampleConwayGenesis = - ConwayGenesis def +exampleConwayGenesis :: ConwayGenesis Conway +exampleConwayGenesis = def diff --git a/eras/conway/test-suite/src/Test/Cardano/Ledger/Conway/Serialisation/Roundtrip.hs b/eras/conway/test-suite/src/Test/Cardano/Ledger/Conway/Serialisation/Roundtrip.hs index e432d4a133b..967cf434588 100644 --- a/eras/conway/test-suite/src/Test/Cardano/Ledger/Conway/Serialisation/Roundtrip.hs +++ b/eras/conway/test-suite/src/Test/Cardano/Ledger/Conway/Serialisation/Roundtrip.hs @@ -27,11 +27,11 @@ allprops = testGroup (show (typeRep (Proxy @e)) <> " CBOR") [ testProperty "ConwayGenesis" $ - roundTripCborRangeExpectation @(ConwayGenesis (EraCrypto e)) + roundTripCborRangeExpectation @(ConwayGenesis e) (natVersion @2) maxBound , testProperty "ConwayGenesis (Plain)" $ - roundTripCborRangeExpectation @(ConwayGenesis (EraCrypto e)) + roundTripCborRangeExpectation @(ConwayGenesis e) (eraProtVerLow @Conway) (eraProtVerHigh @Conway) , testProperty "v9 CostModels" $