Merge pull request #4436 from IntersectMBO/lehins/authorize-known-cc-…

…members-only

Authorize known cc members only

eras/conway/impl/CHANGELOG.md

@@ -1,8 +1,12 @@
 # Version history for `cardano-ledger-conway`
 
-## 1.15.1.1
+## 1.16.0.0
 
-*
+* Added `ConwayCommitteeIsUnknown` predicate failure to  `ConwayGovCertPredFailure`
+* Added `ceCurrentCommittee` and `ceCommitteeProposals` to `CertEnv`
+* Added `certsCurrentCommittee` and `certsCommitteeProposals` to `CertsEnv`
+* Added `cgceCurrentCommittee` and `cgceCommitteeProposals` to `ConwayGovCertEnv`
+* Added `proposalsWithPurpose`, `isGovActionWithPurpose` and `ToGovActionPurpose`
 
 ## 1.15.1.0
 

eras/conway/impl/cardano-ledger-conway.cabal

@@ -1,6 +1,6 @@
 cabal-version:      3.0
 name:               cardano-ledger-conway
-version:            1.15.1.0
+version:            1.16.0.0
 license:            Apache-2.0
 maintainer:         [email protected]
 author:             IOHK

eras/conway/impl/src/Cardano/Ledger/Conway/Governance.hs

@@ -28,6 +28,8 @@ module Cardano.Ledger.Conway.Governance (
   GovActionIx (..),
   GovActionId (..),
   GovActionPurpose (..),
+  ToGovActionPurpose,
+  isGovActionWithPurpose,
   DRepPulsingState (..),
   DRepPulser (..),
   govActionIdToText,
@@ -85,6 +87,7 @@ module Cardano.Ledger.Conway.Governance (
   proposalsSize,
   proposalsLookupId,
   proposalsActionsMap,
+  proposalsWithPurpose,
   cgsProposalsL,
   cgsDRepPulsingStateL,
   cgsCurPParamsL,

eras/conway/impl/src/Cardano/Ledger/Conway/Governance/Procedures.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE AllowAmbiguousTypes #-}
 {-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DeriveGeneric #-}
@@ -38,6 +39,8 @@ module Cardano.Ledger.Conway.Governance.Procedures (
   GovActionIx (..),
   GovPurposeId (..),
   GovActionPurpose (..),
+  ToGovActionPurpose,
+  isGovActionWithPurpose,
   GovRelation (..),
   grPParamUpdateL,
   grHardForkL,
@@ -606,6 +609,29 @@ data GovActionPurpose
   | ConstitutionPurpose
   deriving (Eq, Show, Generic)
 
+class ToGovActionPurpose (p :: GovActionPurpose) where
+  toGovActionPurpose :: GovActionPurpose
+
+instance ToGovActionPurpose 'PParamUpdatePurpose where
+  toGovActionPurpose = PParamUpdatePurpose
+instance ToGovActionPurpose 'HardForkPurpose where
+  toGovActionPurpose = HardForkPurpose
+instance ToGovActionPurpose 'CommitteePurpose where
+  toGovActionPurpose = CommitteePurpose
+instance ToGovActionPurpose 'ConstitutionPurpose where
+  toGovActionPurpose = ConstitutionPurpose
+
+isGovActionWithPurpose :: forall p era. ToGovActionPurpose p => GovAction era -> Bool
+isGovActionWithPurpose govAction =
+  case govAction of
+    ParameterChange {} -> toGovActionPurpose @p == PParamUpdatePurpose
+    HardForkInitiation {} -> toGovActionPurpose @p == HardForkPurpose
+    TreasuryWithdrawals {} -> False
+    NoConfidence {} -> toGovActionPurpose @p == CommitteePurpose
+    UpdateCommittee {} -> toGovActionPurpose @p == CommitteePurpose
+    NewConstitution {} -> toGovActionPurpose @p == ConstitutionPurpose
+    InfoAction -> False
+
 newtype GovPurposeId (p :: GovActionPurpose) era = GovPurposeId
   { unGovPurposeId :: GovActionId (EraCrypto era)
   }

eras/conway/impl/src/Cardano/Ledger/Conway/Governance/Proposals.hs

@@ -16,6 +16,7 @@
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE UndecidableInstances #-}
 
 -- | This module isolates all the types and functionality around
@@ -90,6 +91,7 @@ module Cardano.Ledger.Conway.Governance.Proposals (
   proposalsAddVote,
   proposalsLookupId,
   proposalsActionsMap,
+  proposalsWithPurpose,
   toPrevGovActionIds,
   fromPrevGovActionIds,
 
@@ -236,6 +238,25 @@ instance EraPParams era => ToJSON (Proposals era) where
   toJSON = toJSON . pProps
   toEncoding = toEncoding . pProps
 
+proposalsWithPurpose ::
+  forall p era.
+  ToGovActionPurpose p =>
+  (forall f. Lens' (GovRelation f era) (f (GovPurposeId p era))) ->
+  Proposals era ->
+  Map (GovPurposeId p era) (GovActionState era)
+proposalsWithPurpose propL Proposals {pProps, pGraph} =
+  fromMaybe (assert False fallBackMapWithPurpose) $
+    Map.traverseWithKey
+      (\(GovPurposeId govActionId) _ -> OMap.lookup govActionId pProps)
+      (unPGraph (pGraph ^. propL))
+  where
+    -- In case there is a bug and there is an inconsistency in state we want to report in
+    -- testing, while falling back onto alternative slower implementation
+    fallBackMapWithPurpose :: Map (GovPurposeId p era) (GovActionState era)
+    fallBackMapWithPurpose =
+      Map.mapKeysMonotonic GovPurposeId $
+        Map.filter (isGovActionWithPurpose @p . pProcGovAction . gasProposalProcedure) (OMap.toMap pProps)
+
 -- | Add a single @`GovActionState`@ to the @`Proposals`@ forest.
 -- The tree to which it is added is picked according to its
 -- @`GovActionPurpose`@. Returns `Nothing` when the operation cannot

eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Cert.hs

@@ -22,7 +22,7 @@ module Cardano.Ledger.Conway.Rules.Cert (
   CertEnv (..),
 ) where
 
-import Cardano.Ledger.BaseTypes (EpochNo, ShelleyBase, SlotNo)
+import Cardano.Ledger.BaseTypes (EpochNo, ShelleyBase, SlotNo, StrictMaybe)
 import Cardano.Ledger.Binary (DecCBOR (..), EncCBOR (..))
 import Cardano.Ledger.Binary.Coders
 import Cardano.Ledger.Conway.Core
@@ -32,6 +32,12 @@ import Cardano.Ledger.Conway.Era (
   ConwayEra,
   ConwayGOVCERT,
  )
+import Cardano.Ledger.Conway.Governance (
+  Committee,
+  GovActionPurpose (..),
+  GovActionState,
+  GovPurposeId,
+ )
 import Cardano.Ledger.Conway.Rules.Deleg (
   ConwayDelegEnv (..),
   ConwayDelegPredFailure (..),
@@ -64,6 +70,7 @@ import Control.State.Transition.Extended (
   wrapEvent,
   wrapFailed,
  )
+import qualified Data.Map.Strict as Map
 import Data.Typeable (Typeable)
 import Data.Void (absurd)
 import GHC.Generics (Generic)
@@ -73,13 +80,15 @@ data CertEnv era = CertEnv
   { ceSlotNo :: !SlotNo
   , cePParams :: !(PParams era)
   , ceCurrentEpoch :: !EpochNo
+  , ceCurrentCommittee :: StrictMaybe (Committee era)
+  , ceCommitteeProposals :: Map.Map (GovPurposeId 'CommitteePurpose era) (GovActionState era)
   }
   deriving (Generic)
 
-deriving instance Eq (PParams era) => Eq (CertEnv era)
-deriving instance Show (PParams era) => Show (CertEnv era)
+deriving instance EraPParams era => Eq (CertEnv era)
+deriving instance EraPParams era => Show (CertEnv era)
 
-instance NFData (PParams era) => NFData (CertEnv era)
+instance EraPParams era => NFData (CertEnv era)
 
 data ConwayCertPredFailure era
   = DelegFailure (PredicateFailure (EraRule "DELEG" era))
@@ -196,7 +205,7 @@ certTransition ::
   ) =>
   TransitionRule (ConwayCERT era)
 certTransition = do
-  TRC (CertEnv slot pp currentEpoch, cState, c) <- judgmentContext
+  TRC (CertEnv slot pp currentEpoch committee committeeProposals, cState, c) <- judgmentContext
   let
     CertState {certDState, certPState, certVState} = cState
     pools = psStakePoolParams certPState
@@ -209,7 +218,8 @@ certTransition = do
       pure $ cState {certPState = newPState}
     ConwayTxCertGov govCert -> do
       newVState <-
-        trans @(EraRule "GOVCERT" era) $ TRC (ConwayGovCertEnv pp currentEpoch, certVState, govCert)
+        trans @(EraRule "GOVCERT" era) $
+          TRC (ConwayGovCertEnv pp currentEpoch committee committeeProposals, certVState, govCert)
       pure $ cState {certVState = newVState}
 
 instance

eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Certs.hs

@@ -29,6 +29,7 @@ import Cardano.Ledger.BaseTypes (
   Globals (..),
   ShelleyBase,
   SlotNo,
+  StrictMaybe,
   binOpEpochNo,
  )
 import Cardano.Ledger.Binary (DecCBOR (..), EncCBOR (..))
@@ -43,7 +44,14 @@ import Cardano.Ledger.Binary.Coders (
 import Cardano.Ledger.CertState (VState, certDStateL, certVStateL, vsDRepsL, vsNumDormantEpochsL)
 import Cardano.Ledger.Conway.Core
 import Cardano.Ledger.Conway.Era (ConwayCERT, ConwayCERTS, ConwayEra)
-import Cardano.Ledger.Conway.Governance (Voter (DRepVoter), VotingProcedures (unVotingProcedures))
+import Cardano.Ledger.Conway.Governance (
+  Committee,
+  GovActionPurpose (..),
+  GovActionState,
+  GovPurposeId,
+  Voter (DRepVoter),
+  VotingProcedures (unVotingProcedures),
+ )
 import Cardano.Ledger.Conway.Rules.Cert (CertEnv (CertEnv), ConwayCertEvent, ConwayCertPredFailure)
 import Cardano.Ledger.Conway.Rules.Deleg (ConwayDelegPredFailure)
 import Cardano.Ledger.Conway.Rules.GovCert (ConwayGovCertPredFailure, updateDRepExpiry)
@@ -82,6 +90,8 @@ data CertsEnv era = CertsEnv
   , certsPParams :: !(PParams era)
   , certsSlotNo :: !SlotNo
   , certsCurrentEpoch :: !EpochNo
+  , certsCurrentCommittee :: StrictMaybe (Committee era)
+  , certsCommitteeProposals :: Map.Map (GovPurposeId 'CommitteePurpose era) (GovActionState era)
   }
 
 data ConwayCertsPredFailure era
@@ -189,7 +199,7 @@ conwayCertsTransition ::
   TransitionRule (ConwayCERTS era)
 conwayCertsTransition = do
   TRC
-    ( env@(CertsEnv tx pp slot currentEpoch)
+    ( env@(CertsEnv tx pp slot currentEpoch committee committeeProposals)
       , certState
       , certificates
       ) <-
@@ -240,7 +250,7 @@ conwayCertsTransition = do
       certState' <-
         trans @(ConwayCERTS era) $ TRC (env, certState, gamma)
       trans @(EraRule "CERT" era) $
-        TRC (CertEnv slot pp currentEpoch, certState', txCert)
+        TRC (CertEnv slot pp currentEpoch committee committeeProposals, certState', txCert)
 
 instance
   ( Era era