Conway Genesis additions

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
 

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

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

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

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 =

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

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

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

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 =

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

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`