WIP Abstract ShelleyBlock over protocol.

cabal.project

@@ -219,8 +219,8 @@ source-repository-package
 source-repository-package
   type: git
   location: https://github.com/input-output-hk/cardano-ledger
-  tag: ba20b1f7546b029750b52d091a1234ea4922bf90
-  --sha256: 0lv4qa7mk9qmpnvrc3gh6f8cgqk8bnw88f8gskqbf84gmn0ilq7y
+  tag: d6a4e1098e08e1231684d6bb05a0d08fdc00c5bf
+  --sha256: 1b8nj9976zimg0nk613dhkwb9v8vra4kmbychx3069w7lg44vycq
   subdir:
     eras/alonzo/impl
     eras/alonzo/test-suite

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

@@ -69,7 +69,7 @@ import           Test.ThreadNet.TxGen.Shelley ()
 
 -- | Two eras, both Shelley-based.
 type ShelleyBasedHardForkEras era1 era2 =
-    '[ShelleyBlock era1, ShelleyBlock era2]
+    '[ShelleyBlock era proto1, ShelleyBlock era proto2]
 
 type ShelleyBasedHardForkBlock era1 era2 =
   HardForkBlock (ShelleyBasedHardForkEras era1 era2)
@@ -82,12 +82,12 @@ type ShelleyBasedHardForkGenTx era1 era2 =
   GenTx (ShelleyBasedHardForkBlock era1 era2)
 
 pattern GenTxShelley1 ::
-     GenTx (ShelleyBlock era1)
+     GenTx (ShelleyBlock era proto1)
   -> ShelleyBasedHardForkGenTx era1 era2
 pattern GenTxShelley1 tx = HardForkGenTx (OneEraGenTx (Z tx))
 
 pattern GenTxShelley2 ::
-     GenTx (ShelleyBlock era2)
+     GenTx (ShelleyBlock era proto2)
   -> ShelleyBasedHardForkGenTx era1 era2
 pattern GenTxShelley2 tx = HardForkGenTx (OneEraGenTx (S (Z tx)))
 
@@ -120,8 +120,8 @@ pattern ShelleyBasedHardForkNodeToClientVersion1 =
 type ShelleyBasedHardForkConstraints era1 era2 =
   ( ShelleyBasedEra era1
   , ShelleyBasedEra era2
-  , TxLimits (ShelleyBlock era1)
-  , TxLimits (ShelleyBlock era2)
+  , TxLimits (ShelleyBlock era proto1)
+  , TxLimits (ShelleyBlock era proto2)
   , EraCrypto era1 ~ EraCrypto era2
   , SL.PreviousEra era2 ~ era1
 
@@ -151,8 +151,8 @@ instance ShelleyBasedHardForkConstraints era1 era2
            InPairs.RequiringBoth
              WrapLedgerConfig
              (HFC.Translate LedgerState)
-             (ShelleyBlock era1)
-             (ShelleyBlock era2)
+             (ShelleyBlock era proto1)
+             (ShelleyBlock era proto2)
       translateLedgerState =
           InPairs.RequireBoth
         $ \_cfg1 cfg2 -> HFC.Translate
@@ -166,8 +166,8 @@ instance ShelleyBasedHardForkConstraints era1 era2
            InPairs.RequiringBoth
               WrapLedgerConfig
               (HFC.TranslateForecast LedgerState WrapLedgerView)
-              (ShelleyBlock era1)
-              (ShelleyBlock era2)
+              (ShelleyBlock era proto1)
+              (ShelleyBlock era proto2)
       translateLedgerView =
           InPairs.RequireBoth $ \(WrapLedgerConfig cfg1) (WrapLedgerConfig cfg2) ->
             HFC.TranslateForecast $ forecastAcrossShelley cfg1 cfg2
@@ -185,17 +185,17 @@ instance ShelleyBasedHardForkConstraints era1 era2
     where
       translateTx ::
            SL.TranslationContext era2
-        ->        GenTx (ShelleyBlock era1)
-        -> Maybe (GenTx (ShelleyBlock era2))
+        ->        GenTx (ShelleyBlock era proto1)
+        -> Maybe (GenTx (ShelleyBlock era proto2))
       translateTx transCtxt =
           fmap unComp
         . eitherToMaybe . runExcept . SL.translateEra transCtxt
         . Comp
 
       translateValidatedTx ::
            SL.TranslationContext era2
-        ->        WrapValidatedGenTx (ShelleyBlock era1)
-        -> Maybe (WrapValidatedGenTx (ShelleyBlock era2))
+        ->        WrapValidatedGenTx (ShelleyBlock era proto1)
+        -> Maybe (WrapValidatedGenTx (ShelleyBlock era proto2))
       translateValidatedTx transCtxt =
             fmap unComp
           . eitherToMaybe . runExcept . SL.translateEra transCtxt
@@ -251,7 +251,7 @@ protocolInfoShelleyBasedHardFork protocolParamsShelleyBased
     genesis1 :: SL.ShelleyGenesis era1
     genesis1 = shelleyBasedGenesis
 
-    protocolInfo1 :: ProtocolInfo m (ShelleyBlock era1)
+    protocolInfo1 :: ProtocolInfo m (ShelleyBlock era proto1)
     protocolInfo1 =
         protocolInfoShelleyBased
           protocolParamsShelleyBased
@@ -268,8 +268,8 @@ protocolInfoShelleyBasedHardFork protocolParamsShelleyBased
       } = protocolTransitionParams
 
     toPartialLedgerConfig1 ::
-         LedgerConfig (ShelleyBlock era1)
-      -> PartialLedgerConfig (ShelleyBlock era1)
+         LedgerConfig (ShelleyBlock era proto1)
+      -> PartialLedgerConfig (ShelleyBlock era proto1)
     toPartialLedgerConfig1 cfg = ShelleyPartialLedgerConfig {
           shelleyLedgerConfig    = cfg
         , shelleyTriggerHardFork = transitionTrigger
@@ -280,7 +280,7 @@ protocolInfoShelleyBasedHardFork protocolParamsShelleyBased
     genesis2 :: SL.ShelleyGenesis era2
     genesis2 = SL.translateEra' transCtxt2 genesis1
 
-    protocolInfo2 :: ProtocolInfo m (ShelleyBlock era2)
+    protocolInfo2 :: ProtocolInfo m (ShelleyBlock era proto2)
     protocolInfo2 =
         protocolInfoShelleyBased
           ProtocolParamsShelleyBased {
@@ -296,8 +296,8 @@ protocolInfoShelleyBasedHardFork protocolParamsShelleyBased
     eraParams2 = shelleyEraParams genesis2
 
     toPartialLedgerConfig2 ::
-         LedgerConfig (ShelleyBlock era2)
-      -> PartialLedgerConfig (ShelleyBlock era2)
+         LedgerConfig (ShelleyBlock era proto2)
+      -> PartialLedgerConfig (ShelleyBlock era proto2)
     toPartialLedgerConfig2 cfg = ShelleyPartialLedgerConfig {
           shelleyLedgerConfig    = cfg
         , shelleyTriggerHardFork = TriggerHardForkNever
@@ -308,8 +308,8 @@ protocolInfoShelleyBasedHardFork protocolParamsShelleyBased
 -------------------------------------------------------------------------------}
 
 -- | Use a generic implementation for 'TxGen'
-instance ( TxGen (ShelleyBlock era1)
-         , TxGen (ShelleyBlock era2)
+instance ( TxGen (ShelleyBlock era proto1)
+         , TxGen (ShelleyBlock era proto2)
          , ShelleyBasedHardForkConstraints era1 era2
          ) => TxGen (ShelleyBasedHardForkBlock era1 era2) where
   type TxGenExtra (ShelleyBasedHardForkBlock era1 era2) =

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

@@ -273,7 +273,7 @@ ejectShelleyNS = \case
     S (Z x) -> Just x
     _       -> Nothing
 
-getUTxOShelley :: Ticked (LedgerState (ShelleyBlock era))
+getUTxOShelley :: Ticked (LedgerState (ShelleyBlock proto era))
                -> SL.UTxO era
 getUTxOShelley tls =
     SL._utxo $

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

@@ -21,6 +21,6 @@ import           Ouroboros.Consensus.Cardano.CanHardFork
 
 instance CondenseConstraints ByronBlock
 
-instance ShelleyBasedEra era => CondenseConstraints (ShelleyBlock era)
+instance ShelleyBasedEra era => CondenseConstraints (ShelleyBlock proto era)
 
 instance CardanoHardForkConstraints c => CondenseConstraints (CardanoBlock c)

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

@@ -523,18 +523,18 @@ protocolInfoCardano protocolParamsByron@ProtocolParamsByron {
           initialNonceShelley
           genesisShelley
 
-    blockConfigShelley :: BlockConfig (ShelleyBlock (ShelleyEra c))
+    blockConfigShelley :: BlockConfig (ShelleyBlock (TPraos c) (ShelleyEra c))
     blockConfigShelley =
         Shelley.mkShelleyBlockConfig
           protVerShelley
           genesisShelley
           (tpraosBlockIssuerVKey <$> credssShelleyBased)
 
     partialConsensusConfigShelley ::
-         PartialConsensusConfig (BlockProtocol (ShelleyBlock (ShelleyEra c)))
+         PartialConsensusConfig (BlockProtocol (ShelleyBlock (TPraos c) (ShelleyEra c)))
     partialConsensusConfigShelley = tpraosParams
 
-    partialLedgerConfigShelley :: PartialLedgerConfig (ShelleyBlock (ShelleyEra c))
+    partialLedgerConfigShelley :: PartialLedgerConfig (ShelleyBlock (TPraos c) (ShelleyEra c))
     partialLedgerConfigShelley =
         mkPartialLedgerConfigShelley
           genesisShelley
@@ -558,10 +558,10 @@ protocolInfoCardano protocolParamsByron@ProtocolParamsByron {
           (tpraosBlockIssuerVKey <$> credssShelleyBased)
 
     partialConsensusConfigAllegra ::
-         PartialConsensusConfig (BlockProtocol (ShelleyBlock (AllegraEra c)))
+         PartialConsensusConfig (BlockProtocol (ShelleyBlock (TPraos c) (AllegraEra c)))
     partialConsensusConfigAllegra = tpraosParams
 
-    partialLedgerConfigAllegra :: PartialLedgerConfig (ShelleyBlock (AllegraEra c))
+    partialLedgerConfigAllegra :: PartialLedgerConfig (ShelleyBlock (TPraos c) (AllegraEra c))
     partialLedgerConfigAllegra =
         mkPartialLedgerConfigShelley
           genesisAllegra
@@ -695,8 +695,8 @@ protocolInfoCardano protocolParamsByron@ProtocolParamsByron {
 
         register ::
              (EraCrypto era ~ c, ShelleyBasedEra era)
-          => LedgerState (ShelleyBlock era)
-          -> LedgerState (ShelleyBlock era)
+          => LedgerState (ShelleyBlock proto era)
+          -> LedgerState (ShelleyBlock proto era)
         register st = st {
               Shelley.shelleyLedgerState =
                 -- We must first register the initial funds, because the stake
@@ -797,7 +797,7 @@ mkPartialLedgerConfigShelley ::
   -> Core.TranslationContext era
   -> MaxMajorProtVer
   -> TriggerHardFork
-  -> PartialLedgerConfig (ShelleyBlock era)
+  -> PartialLedgerConfig (ShelleyBlock proto era)
 mkPartialLedgerConfigShelley
   genesisShelley
   transCtxt

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

@@ -22,8 +22,8 @@ import           Ouroboros.Consensus.Shelley.ShelleyBased
 overShelleyBasedLedgerState ::
      forall c. PraosCrypto c
   => (   forall era. (EraCrypto era ~ c, ShelleyBasedEra era)
-      => LedgerState (ShelleyBlock era)
-      -> LedgerState (ShelleyBlock era)
+      => LedgerState (ShelleyBlock proto era)
+      -> LedgerState (ShelleyBlock proto era)
      )
   -> LedgerState (CardanoBlock c)
   -> LedgerState (CardanoBlock c)

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

@@ -46,7 +46,7 @@ import           HasAnalysis
 -- | Usable for each Shelley-based era
 instance ( ShelleyBasedEra era
          , HasField "outputs" (Core.TxBody era) (StrictSeq (Core.TxOut era))
-         ) => HasAnalysis (ShelleyBlock era) where
+         ) => HasAnalysis (ShelleyBlock proto era) where
 
   countTxOutputs blk = case Shelley.shelleyBlockRaw blk of
       SL.Block _ body -> sum $ fmap countOutputs (CL.fromTxSeq @era body)

ouroboros-consensus-protocol/src/Ouroboros/Consensus/Protocol/Praos.hs

@@ -16,7 +16,14 @@
 {-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-}
 
 module Ouroboros.Consensus.Protocol.Praos (
-    Praos
+    ConsensusConfig (..)
+  , Praos
+  , PraosCannotForge (..)
+  , PraosCrypto
+  , PraosFields (..)
+  , PraosIsLeader (..)
+  , PraosParams (..)
+  , PraosToSign (..)
   , forgePraosFields
   , praosCheckCanForge
   ) where
@@ -40,7 +47,8 @@ import           Cardano.Ledger.PoolDistr
 import           Cardano.Ledger.Shelley.API (computeStabilityWindow)
 import qualified Cardano.Ledger.Shelley.API as SL
 import           Cardano.Ledger.Slot (Duration (Duration), (+*))
-import           Cardano.Protocol.TPraos.BHeader (checkLeaderValue, prevHashToNonce)
+import           Cardano.Protocol.TPraos.BHeader (checkLeaderValue,
+                     prevHashToNonce)
 import           Cardano.Protocol.TPraos.OCert (KESPeriod (KESPeriod),
                      OCert (OCert), OCertSignable)
 import qualified Cardano.Protocol.TPraos.OCert as OCert
@@ -54,7 +62,6 @@ import           Codec.Serialise (Serialise (decode, encode))
 import           Control.Exception (throw)
 import           Control.Monad (unless)
 import           Control.Monad.Except (Except, runExcept, throwError)
-import           Data.ByteString (ByteString)
 import           Data.Coerce (coerce)
 import           Data.Functor.Identity (runIdentity)
 import           Data.Map.Strict (Map)
@@ -71,20 +78,22 @@ import           Ouroboros.Consensus.Protocol.Ledger.HotKey (HotKey)
 import qualified Ouroboros.Consensus.Protocol.Ledger.HotKey as HotKey
 import           Ouroboros.Consensus.Protocol.Ledger.Util (isNewEpoch)
 import           Ouroboros.Consensus.Protocol.Praos.Common
+import           Ouroboros.Consensus.Protocol.Praos.Header (HeaderBody)
 import           Ouroboros.Consensus.Protocol.Praos.VRF (UnifiedVRF,
                      mkUnifiedVRF, vrfLeaderCheckValue, vrfNonceValue)
 import qualified Ouroboros.Consensus.Protocol.Praos.Views as Views
 import           Ouroboros.Consensus.Ticked (Ticked)
 import           Ouroboros.Consensus.Util.Versioned (VersionDecoder (Decode),
                      VersionNumber, decodeVersion, encodeVersion)
+import GHC.Natural (Natural)
 
 data Praos c
 
 class
   ( Crypto c,
     DSIGN.Signable (DSIGN c) (OCertSignable c),
     DSIGN.Signable (DSIGN c) (SL.Hash c EraIndependentTxBody),
-    KES.Signable (KES c) ByteString,
+    KES.Signable (KES c) (HeaderBody c),
     VRF.Signable (VRF c) UnifiedVRF
   ) =>
   PraosCrypto c
@@ -196,22 +205,14 @@ data PraosParams = PraosParams
     -- | Testnet or mainnet?
     praosNetworkId         :: !SL.Network,
     -- | The system start, as projected from the chain's genesis block.
-    praosSystemStart       :: !SystemStart
+    praosSystemStart       :: !SystemStart,
+    -- | Maximum header size
+    praosMaxHeaderSize     :: !Natural,
+    -- | Maximum block body size
+    praosMaxBodySize       :: !Natural
   }
   deriving (Generic, NoThunks)
 
-data PraosCanBeLeader c = PraosCanBeLeader
-  { -- | Certificate delegating rights from the stake pool cold key (or
-    -- genesis stakeholder delegate cold key) to the online KES key.
-    praosCanBeLeaderOpCert     :: !(OCert.OCert c),
-    -- | Stake pool cold key or genesis stakeholder delegate cold key.
-    praosCanBeLeaderColdVerKey :: !(SL.VKey 'SL.BlockIssuer c),
-    praosCanBeLeaderSignKeyVRF :: !(SL.SignKeyVRF c)
-  }
-  deriving (Generic)
-
-instance PraosCrypto c => NoThunks (PraosCanBeLeader c)
-
 -- | Assembled proof that the issuer has the right to issue a block in the
 -- selected slot.
 newtype PraosIsLeader c = PraosIsLeader
@@ -580,7 +581,7 @@ validateKESSignature
 
     DSIGN.verifySignedDSIGN () vkcold (OCert.ocertToSignable oc) tau ?!:
       InvalidSignatureOCERT n c0
-    KES.verifySignedKES () vk_hot t (Views.hvSignedBytes b) (Views.hvSignature b) ?!:
+    KES.verifySignedKES () vk_hot t (Views.hvSigned b) (Views.hvSignature b) ?!:
       InvalidKesSignatureOCERT kp_ c0_ t
 
     case currentIssueNo of

ouroboros-consensus-protocol/src/Ouroboros/Consensus/Protocol/Praos/Common.hs

@@ -7,6 +7,7 @@ module Ouroboros.Consensus.Protocol.Praos.Common
   ( MaxMajorProtVer (..),
     SelfIssued (..),
     PraosChainSelectView (..),
+    PraosCanBeLeader (..)
   )
 where
 
@@ -21,6 +22,7 @@ import Data.Word (Word64)
 import GHC.Generics (Generic)
 import NoThunks.Class (NoThunks)
 import Numeric.Natural (Natural)
+import qualified Cardano.Protocol.TPraos.OCert as OCert
 
 -- | The maximum major protocol version.
 --
@@ -87,3 +89,14 @@ instance Crypto c => Ord (PraosChainSelectView c) where
             comp v1 v2
         | otherwise =
             EQ
+data PraosCanBeLeader c = PraosCanBeLeader
+  { -- | Certificate delegating rights from the stake pool cold key (or
+    -- genesis stakeholder delegate cold key) to the online KES key.
+    praosCanBeLeaderOpCert     :: !(OCert.OCert c),
+    -- | Stake pool cold key or genesis stakeholder delegate cold key.
+    praosCanBeLeaderColdVerKey :: !(SL.VKey 'SL.BlockIssuer c),
+    praosCanBeLeaderSignKeyVRF :: !(SL.SignKeyVRF c)
+  }
+  deriving (Generic)
+
+instance Crypto c => NoThunks (PraosCanBeLeader c)