Merge #2832

2832: Allow multiple credentials for Cardano testnets r=mrBliss a=mrBliss

Allow multiple Shelley-based credentials for Cardano, but only for testnets, not for mainnnet.

Co-authored-by: Thomas Winant <thomas@well-typed.com>

ouroboros-consensus-cardano-test/src/Test/ThreadNet/Infra/ShelleyBasedHardFork.hs

@@ -187,7 +187,7 @@ instance ShelleyBasedHardForkConstraints era1 era2
 
 protocolInfoShelleyBasedHardFork ::
      forall m era1 era2. (IOLike m, ShelleyBasedHardForkConstraints era1 era2)
-  => ProtocolParamsShelleyBased era1 Identity
+  => ProtocolParamsShelleyBased era1
   -> SL.ProtVer
   -> SL.ProtVer
   -> ProtocolParamsTransition (ShelleyBlock era1) (ShelleyBlock era2)

ouroboros-consensus-cardano-test/test/Test/ThreadNet/Cardano.hs

@@ -498,7 +498,7 @@ mkProtocolCardanoAndHardForkTxs
         ProtocolParamsShelleyBased {
             shelleyBasedGenesis           = genesisShelley
           , shelleyBasedInitialNonce      = initialNonce
-          , shelleyBasedLeaderCredentials = Just leaderCredentialsShelley
+          , shelleyBasedLeaderCredentials = [leaderCredentialsShelley]
           }
         ProtocolParamsShelley {
             shelleyProtVer = SL.ProtVer shelleyMajorVersion 0

ouroboros-consensus-cardano-test/test/Test/ThreadNet/ShelleyAllegra.hs

@@ -19,7 +19,6 @@ module Test.ThreadNet.ShelleyAllegra (
   ) where
 
 import           Control.Monad (replicateM)
-import           Data.Functor.Identity (Identity (..))
 import qualified Data.Map as Map
 import           Data.Maybe (maybeToList)
 import           Data.Proxy (Proxy (..))
@@ -268,8 +267,9 @@ prop_simple_shelleyAllegra_convergence TestSetup
                     ProtocolParamsShelleyBased {
                         shelleyBasedGenesis           = genesisShelley
                       , shelleyBasedInitialNonce      = setupInitialNonce
-                      , shelleyBasedLeaderCredentials = Identity $
-                          Shelley.mkLeaderCredentials (coreNodes !! fromIntegral nid)
+                      , shelleyBasedLeaderCredentials =
+                          [Shelley.mkLeaderCredentials
+                            (coreNodes !! fromIntegral nid)]
                       }
                     (SL.ProtVer majorVersion1 0)
                     (SL.ProtVer majorVersion2 0)

ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal

@@ -42,6 +42,7 @@ library
                      , nothunks
                      , serialise         >=0.2   && <0.3
                      , text              >=1.2   && <1.3
+                     , these             >=1.1   && <1.2
 
                      , cardano-binary
                      , cardano-crypto-class

ouroboros-consensus-cardano/src/Ouroboros/Consensus/Cardano.hs

@@ -70,7 +70,6 @@ import           Ouroboros.Consensus.Cardano.ShelleyHFC
 
 type ProtocolByron   = HardForkProtocol '[ ByronBlock ]
 type ProtocolShelley = HardForkProtocol '[ ShelleyBlock StandardShelley ]
-type ProtocolMary    = HardForkProtocol '[ ShelleyBlock StandardMary ]
 type ProtocolCardano = HardForkProtocol '[ ByronBlock
                                          , ShelleyBlock StandardShelley
                                          , ShelleyBlock StandardAllegra
@@ -90,20 +89,17 @@ data Protocol (m :: Type -> Type) blk p where
 
   -- | Run TPraos against the Shelley ledger
   ProtocolShelley
-    :: ProtocolParamsShelleyBased StandardShelley []
+    :: ProtocolParamsShelleyBased StandardShelley
     -> ProtocolParamsShelley
     -> Protocol m (ShelleyBlockHFC StandardShelley) ProtocolShelley
 
-  -- | Run TPraos against the Mary ledger
-  ProtocolMary
-    :: ProtocolParamsShelleyBased StandardMary []
-    -> ProtocolParamsMary
-    -> Protocol m (ShelleyBlockHFC StandardMary) ProtocolMary
-
   -- | Run the protocols of /the/ Cardano block
+  --
+  -- WARNING: only a single set of Shelley credentials is allowed when used for
+  -- mainnet. Testnets allow multiple Shelley credentials.
   ProtocolCardano
     :: ProtocolParamsByron
-    -> ProtocolParamsShelleyBased StandardShelley Maybe
+    -> ProtocolParamsShelleyBased StandardShelley
     -> ProtocolParamsShelley
     -> ProtocolParamsAllegra
     -> ProtocolParamsMary
@@ -121,7 +117,6 @@ data Protocol (m :: Type -> Type) blk p where
 verifyProtocol :: Protocol m blk p -> (p :~: BlockProtocol blk)
 verifyProtocol ProtocolByron{}   = Refl
 verifyProtocol ProtocolShelley{} = Refl
-verifyProtocol ProtocolMary{}    = Refl
 verifyProtocol ProtocolCardano{} = Refl
 
 {-------------------------------------------------------------------------------
@@ -137,9 +132,6 @@ protocolInfo (ProtocolByron params) =
 protocolInfo (ProtocolShelley paramsShelleyBased paramsShelley) =
     inject $ protocolInfoShelley paramsShelleyBased paramsShelley
 
-protocolInfo (ProtocolMary paramsShelleyBased paramsMary) =
-    inject $ protocolInfoMary paramsShelleyBased paramsMary
-
 protocolInfo (ProtocolCardano
                paramsByron
                paramsShelleyBased
@@ -166,7 +158,6 @@ protocolInfo (ProtocolCardano
 runProtocol :: Protocol m blk p -> Dict (RunNode blk)
 runProtocol ProtocolByron{}   = Dict
 runProtocol ProtocolShelley{} = Dict
-runProtocol ProtocolMary{}    = Dict
 runProtocol ProtocolCardano{} = Dict
 
 {-------------------------------------------------------------------------------

ouroboros-consensus-cardano/src/Ouroboros/Consensus/Cardano/Node.hs

@@ -36,8 +36,8 @@ import           Codec.CBOR.Encoding (Encoding)
 import qualified Codec.CBOR.Encoding as CBOR
 import           Control.Exception (assert)
 import qualified Data.ByteString.Short as Short
+import           Data.Functor.These (These1 (..))
 import qualified Data.Map.Strict as Map
-import           Data.Maybe (maybeToList)
 import           Data.SOP.Strict hiding (shape, shift)
 import           Data.Word (Word16)
 
@@ -333,10 +333,13 @@ data ProtocolParamsTransition eraFrom eraTo = ProtocolParamsTransition {
 -- NOTE: the initial staking and funds in the 'ShelleyGenesis' are ignored,
 -- /unless/ configured to skip the Byron era and hard fork to Shelley or a later
 -- era from the start using @TriggerHardForkAtEpoch 0@ for testing purposes.
+--
+-- PRECONDITION: only a single set of Shelley credentials is allowed when used
+-- for mainnet (check against @'SL.gNetworkId' 'shelleyBasedGenesis'@).
 protocolInfoCardano ::
      forall c m. (IOLike m, CardanoHardForkConstraints c)
   => ProtocolParamsByron
-  -> ProtocolParamsShelleyBased (ShelleyEra c) Maybe
+  -> ProtocolParamsShelleyBased (ShelleyEra c)
   -> ProtocolParamsShelley
   -> ProtocolParamsAllegra
   -> ProtocolParamsMary
@@ -357,7 +360,7 @@ protocolInfoCardano protocolParamsByron@ProtocolParamsByron {
                     ProtocolParamsShelleyBased {
                         shelleyBasedGenesis           = genesisShelley
                       , shelleyBasedInitialNonce      = initialNonceShelley
-                      , shelleyBasedLeaderCredentials = mCredsShelleyBased
+                      , shelleyBasedLeaderCredentials = credssShelleyBased
                       }
                     ProtocolParamsShelley {
                         shelleyProtVer = protVerShelley
@@ -376,13 +379,16 @@ protocolInfoCardano protocolParamsByron@ProtocolParamsByron {
                       }
                     ProtocolParamsTransition {
                         transitionTrigger = triggerHardForkAllegraMary
-                      } =
-    assertWithMsg (validateGenesis genesisShelley) $
+                      }
+  | SL.Mainnet <- SL.sgNetworkId genesisShelley
+  , length credssShelleyBased > 1
+  = error "Multiple Shelley-based credentials not allowed for mainnet"
+  | otherwise
+  = assertWithMsg (validateGenesis genesisShelley) $
     ProtocolInfo {
         pInfoConfig       = cfg
       , pInfoInitLedger   = initExtLedgerStateCardano
-      , pInfoBlockForging =
-          maybeToList <$> mBlockForging
+      , pInfoBlockForging = blockForging
       }
   where
     -- The major protocol version of the last era is the maximum major protocol
@@ -426,7 +432,7 @@ protocolInfoCardano protocolParamsByron@ProtocolParamsByron {
         Shelley.mkShelleyBlockConfig
           protVerShelley
           genesisShelley
-          (tpraosBlockIssuerVKey <$> maybeToList mCredsShelleyBased)
+          (tpraosBlockIssuerVKey <$> credssShelleyBased)
 
     partialConsensusConfigShelley ::
          PartialConsensusConfig (BlockProtocol (ShelleyBlock (ShelleyEra c)))
@@ -452,7 +458,7 @@ protocolInfoCardano protocolParamsByron@ProtocolParamsByron {
         Shelley.mkShelleyBlockConfig
           protVerAllegra
           genesisAllegra
-          (tpraosBlockIssuerVKey <$> maybeToList mCredsShelleyBased)
+          (tpraosBlockIssuerVKey <$> credssShelleyBased)
 
     partialConsensusConfigAllegra ::
          PartialConsensusConfig (BlockProtocol (ShelleyBlock (AllegraEra c)))
@@ -475,7 +481,7 @@ protocolInfoCardano protocolParamsByron@ProtocolParamsByron {
         Shelley.mkShelleyBlockConfig
           protVerMary
           genesisMary
-          (tpraosBlockIssuerVKey <$> maybeToList mCredsShelleyBased)
+          (tpraosBlockIssuerVKey <$> credssShelleyBased)
 
     partialConsensusConfigMary ::
          PartialConsensusConfig (BlockProtocol (ShelleyBlock (MaryEra c)))
@@ -573,25 +579,52 @@ protocolInfoCardano protocolParamsByron@ProtocolParamsByron {
                 $ Shelley.shelleyLedgerState st
             }
 
-    mBlockForging :: m (Maybe (BlockForging m (CardanoBlock c)))
-    mBlockForging = do
-        mShelleyBased <- mBlockForgingShelleyBased
-        return
-          $ fmap (hardForkBlockForging "Cardano")
-          $ OptNP.combine mBlockForgingByron mShelleyBased
+    -- | For each element in the list, a block forging thread will be started.
+    --
+    -- When no credentials are passed, there will be no threads.
+    --
+    -- Typically, there will only be a single set of credentials for Shelley.
+    --
+    -- In case there are multiple credentials for Shelley, which is only done
+    -- for testing/benchmarking purposes, we'll have a separate thread for each
+    -- of them.
+    --
+    -- If Byron credentials are passed, we merge them with the Shelley
+    -- credentials if possible, so that we only have a single thread running in
+    -- the case we have Byron credentials and a single set of Shelley
+    -- credentials. If there are multiple Shelley credentials, we merge the
+    -- Byron credentials with the first Shelley one but still have separate
+    -- threads for the remaining Shelley ones.
+    blockForging :: m [BlockForging m (CardanoBlock c)]
+    blockForging = do
+        shelleyBased <- blockForgingShelleyBased
+        let blockForgings :: [OptNP 'False (BlockForging m) (CardanoEras c)]
+            blockForgings = case (mBlockForgingByron, shelleyBased) of
+              (Nothing,    shelleys)         -> shelleys
+              (Just byron, [])               -> [byron]
+              (Just byron, shelley:shelleys) ->
+                  OptNP.zipWith merge byron shelley : shelleys
+                where
+                  -- When merging Byron with Shelley-based eras, we should never
+                  -- merge two from the same era.
+                  merge (These1 _ _) = error "forgings of the same era"
+                  merge (This1 x)    = x
+                  merge (That1 y)    = y
+
+        return $ hardForkBlockForging "Cardano" <$> blockForgings
 
     mBlockForgingByron :: Maybe (OptNP 'False (BlockForging m) (CardanoEras c))
     mBlockForgingByron = do
         creds <- mCredsByron
         return $ byronBlockForging creds `OptNP.at` IZ
 
-    mBlockForgingShelleyBased :: m (Maybe (OptNP 'False (BlockForging m) (CardanoEras c)))
-    mBlockForgingShelleyBased = do
-        mShelleyBased <-
+    blockForgingShelleyBased :: m [OptNP 'False (BlockForging m) (CardanoEras c)]
+    blockForgingShelleyBased = do
+        shelleyBased <-
           traverse
             (shelleySharedBlockForging (Proxy @(ShelleyBasedEras c)) tpraosParams)
-            mCredsShelleyBased
-        return $ reassoc <$> mShelleyBased
+            credssShelleyBased
+        return $ reassoc <$> shelleyBased
       where
         reassoc ::
              NP (BlockForging m :.: ShelleyBlock) (ShelleyBasedEras c)

ouroboros-consensus-cardano/tools/db-analyser/Block/Cardano.hs

@@ -100,7 +100,7 @@ mkCardanoProtocolInfo genesisByron signatureThreshold genesisShelley initialNonc
       ProtocolParamsShelleyBased {
           shelleyBasedGenesis           = genesisShelley
         , shelleyBasedInitialNonce      = initialNonce
-        , shelleyBasedLeaderCredentials = Nothing
+        , shelleyBasedLeaderCredentials = []
         }
       ProtocolParamsShelley {
           shelleyProtVer = ProtVer 2 0

ouroboros-consensus-shelley-test/src/Test/ThreadNet/Infra/Shelley.hs

@@ -405,7 +405,7 @@ mkProtocolShelley genesis initialNonce protVer coreNode =
       ProtocolParamsShelleyBased {
           shelleyBasedGenesis           = genesis
         , shelleyBasedInitialNonce      = initialNonce
-        , shelleyBasedLeaderCredentials = Just $ mkLeaderCredentials coreNode
+        , shelleyBasedLeaderCredentials = [mkLeaderCredentials coreNode]
         }
       ProtocolParamsShelley {
           shelleyProtVer = protVer

ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Node.hs

@@ -20,7 +20,6 @@
 module Ouroboros.Consensus.Shelley.Node (
     protocolInfoShelleyBased
   , protocolInfoShelley
-  , protocolInfoMary
   , ProtocolParamsShelleyBased (..)
   , ProtocolParamsShelley (..)
   , ProtocolParamsAllegra (..)
@@ -42,7 +41,6 @@ module Ouroboros.Consensus.Shelley.Node (
   ) where
 
 import           Data.Bifunctor (first)
-import           Data.Foldable (toList)
 import           Data.Functor.Identity (Identity)
 import           Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
@@ -217,15 +215,15 @@ validateGenesis = first errsToString . SL.validateGenesis
 --
 -- The @era@ parameter determines from which era the genesis config will be
 -- used.
-data ProtocolParamsShelleyBased era f = ProtocolParamsShelleyBased {
+data ProtocolParamsShelleyBased era = ProtocolParamsShelleyBased {
       shelleyBasedGenesis           :: SL.ShelleyGenesis era
       -- | The initial nonce, typically derived from the hash of Genesis
       -- config JSON file.
       --
       -- WARNING: chains using different values of this parameter will be
       -- mutually incompatible.
     , shelleyBasedInitialNonce      :: SL.Nonce
-    , shelleyBasedLeaderCredentials :: f (TPraosLeaderCredentials (EraCrypto era))
+    , shelleyBasedLeaderCredentials :: [TPraosLeaderCredentials (EraCrypto era)]
     }
 
 -- | Parameters needed to run Shelley
@@ -244,8 +242,8 @@ data ProtocolParamsMary = ProtocolParamsMary {
     }
 
 protocolInfoShelley ::
-     forall m c f. (IOLike m, ShelleyBasedEra (ShelleyEra c), Foldable f)
-  => ProtocolParamsShelleyBased (ShelleyEra c) f
+     forall m c. (IOLike m, ShelleyBasedEra (ShelleyEra c))
+  => ProtocolParamsShelleyBased (ShelleyEra c)
   -> ProtocolParamsShelley
   -> ProtocolInfo m (ShelleyBlock (ShelleyEra c))
 protocolInfoShelley protocolParamsShelleyBased
@@ -254,20 +252,9 @@ protocolInfoShelley protocolParamsShelleyBased
                       } =
     protocolInfoShelleyBased protocolParamsShelleyBased protVer
 
-protocolInfoMary ::
-     forall m c f. (IOLike m, ShelleyBasedEra (MaryEra c), Foldable f)
-  => ProtocolParamsShelleyBased (MaryEra c) f
-  -> ProtocolParamsMary
-  -> ProtocolInfo m (ShelleyBlock (MaryEra c))
-protocolInfoMary protocolParamsShelleyBased
-                 ProtocolParamsMary {
-                     maryProtVer = protVer
-                   } =
-    protocolInfoShelleyBased protocolParamsShelleyBased protVer
-
 protocolInfoShelleyBased ::
-     forall m era f. (IOLike m, ShelleyBasedEra era, Foldable f)
-  => ProtocolParamsShelleyBased era f
+     forall m era. (IOLike m, ShelleyBasedEra era)
+  => ProtocolParamsShelleyBased era
   -> SL.ProtVer
   -> ProtocolInfo m (ShelleyBlock era)
 protocolInfoShelleyBased ProtocolParamsShelleyBased {
@@ -280,7 +267,8 @@ protocolInfoShelleyBased ProtocolParamsShelleyBased {
     ProtocolInfo {
         pInfoConfig       = topLevelConfig
       , pInfoInitLedger   = initExtLedgerState
-      , pInfoBlockForging = sequence $ shelleyBlockForging tpraosParams <$> toList credentialss
+      , pInfoBlockForging =
+          traverse (shelleyBlockForging tpraosParams) credentialss
       }
   where
     maxMajorProtVer :: MaxMajorProtVer
@@ -315,7 +303,7 @@ protocolInfoShelleyBased ProtocolParamsShelleyBased {
         mkShelleyBlockConfig
           protVer
           genesis
-          (tpraosBlockIssuerVKey <$> toList credentialss)
+          (tpraosBlockIssuerVKey <$> credentialss)
 
     storageConfig :: StorageConfig (ShelleyBlock era)
     storageConfig = ShelleyStorageConfig {