diff --git a/eras/conway/impl/CHANGELOG.md b/eras/conway/impl/CHANGELOG.md index da174da2fd5..99bf6f8c1c8 100644 --- a/eras/conway/impl/CHANGELOG.md +++ b/eras/conway/impl/CHANGELOG.md @@ -75,6 +75,8 @@ * Add `insertGovActionsState` * Change type of `rsRemoved` in `RatifyState` to use `GovActionState` instead of a tuple * Change `RatifySignal` to use `GovActionsState` instead of a tuple +* Add `FromJSON` instance for `Committee` +* Add `constitution` and `committee` fields to `ConwayGenesis` ## 1.7.1.0 diff --git a/eras/conway/impl/cardano-ledger-conway.cabal b/eras/conway/impl/cardano-ledger-conway.cabal index 7bdbdf6b9c5..46d0a42b675 100644 --- a/eras/conway/impl/cardano-ledger-conway.cabal +++ b/eras/conway/impl/cardano-ledger-conway.cabal @@ -11,6 +11,7 @@ description: category: Network build-type: Simple +data-files: data/*.json extra-source-files: CHANGELOG.md source-repository head @@ -115,6 +116,8 @@ test-suite tests other-modules: Test.Cardano.Ledger.Conway.BinarySpec Test.Cardano.Ledger.Conway.RatifySpec + Test.Cardano.Ledger.Conway.GenesisSpec + Paths_cardano_ledger_conway default-language: Haskell2010 ghc-options: @@ -123,9 +126,11 @@ test-suite tests -Wunused-packages -threaded -rtsopts -with-rtsopts=-N build-depends: + aeson, base, cardano-ledger-core:testlib, cardano-ledger-conway, cardano-ledger-core, containers, + data-default-class, testlib diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Genesis.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Genesis.hs index 6328480e658..a15701dec43 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 #-} @@ -13,30 +14,66 @@ import Cardano.Ledger.Binary ( DecCBOR (..), EncCBOR (..), ) +import Cardano.Ledger.Conway.Era (ConwayEra) +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 Data.Aeson ( + FromJSON (..), + KeyValue (..), + ToJSON (..), + object, + pairs, + withObject, + (.:), + ) +import Data.Default.Class (Default (def)) import Data.Functor.Identity (Identity) import GHC.Generics (Generic) import NoThunks.Class (NoThunks) -newtype ConwayGenesis c = ConwayGenesis - { cgUpgradePParams :: UpgradeConwayPParams Identity +data ConwayGenesis c = ConwayGenesis + { cgUpgradePParams :: !(UpgradeConwayPParams Identity) + , cgConstitution :: !(Constitution (ConwayEra c)) + , cgCommittee :: !(Committee (ConwayEra c)) } deriving (Eq, Generic, Show) -instance NoThunks (ConwayGenesis c) +instance Crypto 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 + decCBOR = + ConwayGenesis + <$> decCBOR + <*> decCBOR + <*> decCBOR instance Crypto c => EncCBOR (ConwayGenesis c) where - encCBOR (ConwayGenesis x) = encCBOR x + encCBOR (ConwayGenesis pparams constitution committee) = + encCBOR pparams + <> encCBOR constitution + <> encCBOR committee instance Crypto c => ToJSON (ConwayGenesis c) where - toJSON ConwayGenesis {..} = toJSON cgUpgradePParams + toJSON = object . toConwayGenesisPairs + toEncoding = pairs . mconcat . toConwayGenesisPairs instance Crypto c => FromJSON (ConwayGenesis c) where - parseJSON x = ConwayGenesis <$> parseJSON x + parseJSON = + withObject "ConwayGenesis" $ \obj -> + ConwayGenesis + <$> obj .: "upgradeProtocolParams" + <*> obj .: "constitution" + <*> obj .: "committee" + +toConwayGenesisPairs :: (Crypto c, KeyValue a) => ConwayGenesis c -> [a] +toConwayGenesisPairs cg@(ConwayGenesis _ _ _) = + let ConwayGenesis {..} = cg + in [ "upgradeProtocolParams" .= cgUpgradePParams + , "constitution" .= cgConstitution + , "committee" .= cgCommittee + ] + +instance Crypto c => Default (ConwayGenesis c) where + def = ConwayGenesis def def def diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Governance/Procedures.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Governance/Procedures.hs index 744c018a821..bf2a3c0769f 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Governance/Procedures.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/Governance/Procedures.hs @@ -82,18 +82,23 @@ import Cardano.Slotting.Slot (EpochNo) import Control.DeepSeq (NFData (..)) import Control.Monad (when) import Data.Aeson ( + FromJSON (..), KeyValue (..), ToJSON (..), ToJSONKey (..), object, pairs, + withObject, + (.:), ) import Data.Aeson.Types (toJSONKeyText) +import Data.Default.Class import Data.Map.Strict (Map) import Data.Maybe.Strict (StrictMaybe (..)) import Data.Sequence (Seq (..)) import Data.Set (Set) import qualified Data.Text as Text +import Data.Unit.Strict (forceElemsToWHNF) import Data.Word (Word32) import GHC.Generics (Generic) import Lens.Micro (Lens', lens) @@ -349,6 +354,9 @@ instance Era era => NoThunks (Committee era) instance Era era => NFData (Committee era) +instance Default (Committee era) where + def = Committee mempty minBound + committeeMembersL :: Lens' (Committee era) (Map (Credential 'ColdCommitteeRole (EraCrypto era)) EpochNo) committeeMembersL = lens committeeMembers (\c m -> c {committeeMembers = m}) @@ -374,6 +382,14 @@ instance EraPParams era => ToJSON (Committee era) where toJSON = object . toCommitteePairs toEncoding = pairs . mconcat . toCommitteePairs +instance Era era => FromJSON (Committee era) where + parseJSON = withObject "Committee" parseCommittee + where + parseCommittee o = + Committee + <$> (forceElemsToWHNF <$> o .: "members") + <*> o .: "quorum" + toCommitteePairs :: (KeyValue a, EraPParams era) => Committee era -> [a] toCommitteePairs committee@(Committee _ _) = let Committee {..} = committee diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Translation.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Translation.hs index 86ff81aa1f5..27e5150a50c 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Translation.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/Translation.hs @@ -28,7 +28,11 @@ import Cardano.Ledger.CertState (CommitteeState (..)) import Cardano.Ledger.Conway.Core hiding (Tx) import Cardano.Ledger.Conway.Era (ConwayEra) import Cardano.Ledger.Conway.Genesis (ConwayGenesis (..)) -import Cardano.Ledger.Conway.Governance () +import Cardano.Ledger.Conway.Governance ( + cgEnactStateL, + ensCommitteeL, + ensConstitutionL, + ) import Cardano.Ledger.Conway.Scripts () import Cardano.Ledger.Conway.Tx () import qualified Cardano.Ledger.Core as Core (Tx) @@ -45,6 +49,7 @@ import Cardano.Ledger.Shelley.API ( ) import qualified Cardano.Ledger.Shelley.API as API import Cardano.Ledger.Shelley.LedgerState (curPParamsEpochStateL, prevPParamsEpochStateL) +import Data.Default.Class (Default (def)) import qualified Data.Map.Strict as Map import Lens.Micro @@ -154,10 +159,15 @@ translateGovState :: TranslationContext (ConwayEra c) -> GovState (BabbageEra c) -> GovState (ConwayEra c) -translateGovState ctxt sgov = +translateGovState ctxt@(ConwayGenesis _ constitution committee) sgov = emptyGovState & curPParamsGovStateL .~ translateEra' ctxt (sgov ^. curPParamsGovStateL) & prevPParamsGovStateL .~ translateEra' ctxt (sgov ^. prevPParamsGovStateL) + & cgEnactStateL + .~ ( def + & ensConstitutionL .~ constitution + & ensCommitteeL .~ SJust committee + ) instance Crypto c => TranslateEra (ConwayEra c) UTxOState where translateEra ctxt us = diff --git a/eras/conway/impl/test/Main.hs b/eras/conway/impl/test/Main.hs index 1e97c97966a..c1ecba7da90 100644 --- a/eras/conway/impl/test/Main.hs +++ b/eras/conway/impl/test/Main.hs @@ -2,6 +2,7 @@ module Main where import Test.Cardano.Ledger.Common import qualified Test.Cardano.Ledger.Conway.BinarySpec as BinarySpec +import qualified Test.Cardano.Ledger.Conway.GenesisSpec as GenesisSpec import qualified Test.Cardano.Ledger.Conway.RatifySpec as RatifySpec main :: IO () @@ -10,3 +11,4 @@ main = describe "Conway" $ do BinarySpec.spec RatifySpec.spec + GenesisSpec.spec diff --git a/eras/conway/impl/test/Test/Cardano/Ledger/Conway/GenesisSpec.hs b/eras/conway/impl/test/Test/Cardano/Ledger/Conway/GenesisSpec.hs new file mode 100644 index 00000000000..7d137e54e1c --- /dev/null +++ b/eras/conway/impl/test/Test/Cardano/Ledger/Conway/GenesisSpec.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Test.Cardano.Ledger.Conway.GenesisSpec (spec) where + +import Cardano.Ledger.Conway +import Cardano.Ledger.Conway.Genesis (ConwayGenesis (..)) +import Cardano.Ledger.Conway.Governance (Committee (..)) +import Cardano.Ledger.Core +import Cardano.Ledger.Credential +import Cardano.Ledger.Crypto (StandardCrypto) +import Cardano.Ledger.Keys +import Cardano.Ledger.Slot (EpochNo (..)) +import Data.Aeson hiding (Encoding) +import Data.Default.Class (Default (def)) +import Data.Map as Map +import Data.Ratio ((%)) +import Paths_cardano_ledger_conway (getDataFileName) +import Test.Cardano.Ledger.Common +import Test.Cardano.Ledger.Core.Utils (unsafeBoundRational) + +spec :: Spec +spec = do + describe "Genesis Golden Spec" $ do + goldenConwayGenesisJSON + +goldenConwayGenesisJSON :: Spec +goldenConwayGenesisJSON = + it "should deserialize to the default value" $ do + let fileName = "test/data/conway-genesis.json" + credMember = + KeyHashObj + (KeyHash "4e88cc2d27c364aaf90648a87dfb95f8ee103ba67fa1f12f5e86c42a") :: + Credential 'ColdCommitteeRole StandardCrypto + scriptMember = + ScriptHashObj + (ScriptHash "4e88cc2d27c364aaf90648a87dfb95f8ee103ba67fa1f12f5e86c42a") :: + Credential 'ColdCommitteeRole StandardCrypto + comm = + Committee + ( Map.fromList + [ + ( credMember + , EpochNo 1 + ) + , + ( scriptMember + , EpochNo 2 + ) + ] + ) + (unsafeBoundRational (1 % 2)) :: + Committee Conway + file <- getDataFileName fileName + dec <- eitherDecodeFileStrict' file + cg <- case dec of + Left err -> error ("Failed to deserialize JSON: " ++ err) + Right x -> pure x + let expectedCg = def {cgCommittee = comm} + cg `shouldBe` expectedCg diff --git a/eras/conway/impl/test/data/conway-genesis.json b/eras/conway/impl/test/data/conway-genesis.json new file mode 100644 index 00000000000..e326c18f17f --- /dev/null +++ b/eras/conway/impl/test/data/conway-genesis.json @@ -0,0 +1,41 @@ +{ + "upgradeProtocolParams":{ + "poolVotingThresholds":{ + "pvtCommitteeNormal":0, + "pvtCommitteeNoConfidence":0, + "pvtHardForkInitiation":0, + "pvtMotionNoConfidence":0 + }, + "dRepVotingThresholds":{ + "dvtMotionNoConfidence":0, + "dvtCommitteeNormal":0, + "dvtCommitteeNoConfidence":0, + "dvtUpdateToConstitution":0, + "dvtHardForkInitiation":0, + "dvtPPNetworkGroup":0, + "dvtPPEconomicGroup":0, + "dvtPPTechnicalGroup":0, + "dvtPPGovGroup":0, + "dvtTreasuryWithdrawal":0 + }, + "minCommitteeSize":0, + "committeeTermLimit":0, + "govActionExpiration":0, + "govActionDeposit":0, + "dRepDeposit":0, + "dRepActivity":0 + }, + "constitution": { + "anchor": { + "url": "", + "dataHash": "0000000000000000000000000000000000000000000000000000000000000000" + } + }, + "committee" :{ + "members" : { + "keyhash-4e88cc2d27c364aaf90648a87dfb95f8ee103ba67fa1f12f5e86c42a": 1 , + "scripthash-4e88cc2d27c364aaf90648a87dfb95f8ee103ba67fa1f12f5e86c42a": 2 + }, + "quorum": 0.5 + } +} 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 999550de267..a4c216ea767 100644 --- a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Arbitrary.hs +++ b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Arbitrary.hs @@ -33,7 +33,7 @@ import Test.Cardano.Ledger.Babbage.Arbitrary () import Test.Cardano.Ledger.Common instance Crypto c => Arbitrary (ConwayGenesis c) where - arbitrary = ConwayGenesis <$> arbitrary + 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..fb98730a4d8 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 @@ -38,7 +38,7 @@ import Cardano.Ledger.Conway.TxBody (ConwayTxBody (..)) import Cardano.Ledger.Conway.TxCert (ConwayTxCert (..)) import Cardano.Ledger.Conway.TxWits (AlonzoTxWits (..)) import Cardano.Ledger.Credential (Credential (KeyHashObj, ScriptHashObj)) -import Cardano.Ledger.Crypto (StandardCrypto) +import Cardano.Ledger.Crypto (Crypto, StandardCrypto) import Cardano.Ledger.Keys (asWitness) import Cardano.Ledger.Mary.Value (MaryValue (..)) import Cardano.Ledger.SafeHash (hashAnnotated) @@ -200,6 +200,5 @@ exampleConwayNewEpochState = emptyPParams (emptyPParams & ppCoinsPerUTxOByteL .~ CoinPerByte (Coin 1)) -exampleConwayGenesis :: ConwayGenesis c -exampleConwayGenesis = - ConwayGenesis def +exampleConwayGenesis :: Crypto c => ConwayGenesis c +exampleConwayGenesis = def diff --git a/eras/shelley/impl/CHANGELOG.md b/eras/shelley/impl/CHANGELOG.md index 371a78d0017..763f69fa8f2 100644 --- a/eras/shelley/impl/CHANGELOG.md +++ b/eras/shelley/impl/CHANGELOG.md @@ -3,6 +3,7 @@ ## 1.6.0.0 * Add lenses for `UTxOEnv` #3688 +* Add `FromJSON` instance for `Constitution` * Add `getTotalTxDepositsBody` to `ShelleyEraTxBody` * Add `obligationGovState` to `EraGov` * Add `ToExpr` instance to `Constitution` diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Governance.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Governance.hs index 939b9d116eb..e4022998811 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Governance.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Governance.hs @@ -40,10 +40,21 @@ import Cardano.Ledger.Shelley.PParams (ProposedPPUpdates, emptyPPPUpdates) import Cardano.Ledger.TreeDiff (ToExpr) import Cardano.Ledger.Val (Val (..)) import Control.DeepSeq (NFData) -import Data.Aeson (KeyValue, ToJSON (..), object, pairs, (.=)) +import Data.Aeson ( + FromJSON, + KeyValue, + ToJSON (..), + object, + pairs, + withObject, + (.:), + (.:?), + (.=), + ) +import Data.Aeson.Types (FromJSON (..)) import Data.Default.Class (Default (..)) import Data.Kind (Type) -import Data.Maybe.Strict (StrictMaybe (..)) +import Data.Maybe.Strict (StrictMaybe (..), maybeToStrictMaybe) import GHC.Generics (Generic) import Lens.Micro (Lens', lens) import NoThunks.Class (NoThunks (..)) @@ -233,11 +244,17 @@ instance Era era => ToJSON (Constitution era) where toJSON = object . toConstitutionPairs toEncoding = pairs . mconcat . toConstitutionPairs +instance Era era => FromJSON (Constitution era) where + parseJSON = withObject "Constitution" $ \o -> + Constitution + <$> o .: "anchor" + <*> (maybeToStrictMaybe <$> (o .:? "script")) + toConstitutionPairs :: (KeyValue a, Era era) => Constitution era -> [a] toConstitutionPairs c@(Constitution _ _) = let Constitution {..} = c - in ["constitutionAnchor" .= constitutionAnchor] - <> ["constitutionScript" .= cScript | SJust cScript <- [constitutionScript]] + in ["anchor" .= constitutionAnchor] + <> ["script" .= cScript | SJust cScript <- [constitutionScript]] deriving instance Eq (Constitution era) diff --git a/libs/cardano-ledger-core/CHANGELOG.md b/libs/cardano-ledger-core/CHANGELOG.md index 0cc678e624e..ec42aec6d88 100644 --- a/libs/cardano-ledger-core/CHANGELOG.md +++ b/libs/cardano-ledger-core/CHANGELOG.md @@ -14,6 +14,7 @@ * Add `ToExpr` instance for `PoolCert` * Require `ToExpr` instance for `Script`, `TxAuxData` and `TxCert` * Require an extra argument for `decodePositiveCoin` in order to improve error reporting #3694 +* Add `FromJSON` instance to `Anchor` ## 1.5.0.0 diff --git a/libs/cardano-ledger-core/src/Cardano/Ledger/BaseTypes.hs b/libs/cardano-ledger-core/src/Cardano/Ledger/BaseTypes.hs index 7d3278c04b8..3427da0f24c 100644 --- a/libs/cardano-ledger-core/src/Cardano/Ledger/BaseTypes.hs +++ b/libs/cardano-ledger-core/src/Cardano/Ledger/BaseTypes.hs @@ -131,6 +131,7 @@ import Data.Aeson ( ToJSON (..), object, pairs, + withObject, (.:), (.=), ) @@ -821,6 +822,12 @@ instance Crypto c => ToJSON (Anchor c) where toJSON = object . toAnchorPairs toEncoding = pairs . mconcat . toAnchorPairs +instance Crypto c => FromJSON (Anchor c) where + parseJSON = withObject "Anchor" $ \o -> do + anchorUrl <- o .: "url" + anchorDataHash <- o .: "dataHash" + pure $ Anchor {..} + instance ToExpr (Anchor c) instance Crypto c => Default (Anchor c) where