WIP ThreadNet: resurrect protocolInfoPraosShelleyBased

Author: geo2a

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

@@ -14,32 +14,61 @@ module Ouroboros.Consensus.Shelley.Node.Praos
   ( -- * BlockForging
     praosBlockForging
   , praosSharedBlockForging
+  , protocolInfoPraosShelleyBased
   ) where
 
 import qualified Cardano.Ledger.Api.Era as L
+import qualified Cardano.Ledger.Api.Transition as L
+import Cardano.Ledger.BaseTypes (NonZero (unNonZero))
+import qualified Cardano.Ledger.BaseTypes as SL
+import qualified Cardano.Ledger.Shelley.API as SL
+import qualified Cardano.Protocol.TPraos.API as SL
 import qualified Cardano.Protocol.TPraos.OCert as Absolute
 import qualified Cardano.Protocol.TPraos.OCert as SL
+import Cardano.Slotting.EpochInfo
+import Cardano.Slotting.Time (mkSlotLength)
+import Control.Monad.Except (Except)
+import qualified Control.Tracer as Tracer
 import qualified Data.Text as T
+import Lens.Micro ((^.))
 import Ouroboros.Consensus.Block
-import Ouroboros.Consensus.Config (configConsensus)
+import Ouroboros.Consensus.Config
+import qualified Ouroboros.Consensus.HardFork.History as History
+import Ouroboros.Consensus.HeaderValidation
+import Ouroboros.Consensus.Ledger.Abstract
+import Ouroboros.Consensus.Ledger.Extended
+import Ouroboros.Consensus.Ledger.SupportsMempool (TxLimits)
 import qualified Ouroboros.Consensus.Ledger.SupportsMempool as Mempool
+import Ouroboros.Consensus.Ledger.Tables.Utils
+import Ouroboros.Consensus.Node.ProtocolInfo
+import Ouroboros.Consensus.Protocol.Abstract
+import Ouroboros.Consensus.Protocol.Ledger.HotKey (HotKey)
 import qualified Ouroboros.Consensus.Protocol.Ledger.HotKey as HotKey
 import Ouroboros.Consensus.Protocol.Praos
-  ( Praos
+  ( ConsensusConfig (..)
+  , Praos
   , PraosParams (..)
+  , PraosState (..)
   , praosCheckCanForge
   )
+import Ouroboros.Consensus.Protocol.Praos.AgentClient
+import Ouroboros.Consensus.Protocol.Praos.Common
+import Ouroboros.Consensus.Protocol.TPraos
 import Ouroboros.Consensus.Shelley.Ledger
-  ( ShelleyBlock
-  , ShelleyCompatible
-  , forgeShelleyBlock
-  )
+import Ouroboros.Consensus.Shelley.Ledger.Inspect ()
+import Ouroboros.Consensus.Shelley.Ledger.NetworkProtocolVersion ()
 import Ouroboros.Consensus.Shelley.Node.Common
-  ( ShelleyEraWithCrypto
+  ( ProtocolParamsShelleyBased (..)
+  , ShelleyEraWithCrypto
   , ShelleyLeaderCredentials (..)
+  , shelleyBlockIssuerVKey
+  , validateGenesis
   )
+import Ouroboros.Consensus.Shelley.Node.Serialisation ()
 import Ouroboros.Consensus.Shelley.Protocol.Praos ()
-import Ouroboros.Consensus.Util.IOLike (IOLike)
+import Ouroboros.Consensus.Shelley.Protocol.TPraos ()
+import Ouroboros.Consensus.Util.Assert
+import Ouroboros.Consensus.Util.IOLike
 
 {-------------------------------------------------------------------------------
   BlockForging
@@ -102,3 +131,136 @@ praosSharedBlockForging
             cfg
       , finalize = HotKey.finalize hotKey
       }
+
+protocolInfoPraosShelleyBased ::
+  forall m era c.
+  ( ShelleyCompatible (Praos c) era
+  , TxLimits (ShelleyBlock (Praos c) era)
+  , KESAgentContext c m
+  ) =>
+  ProtocolParamsShelleyBased c ->
+  L.TransitionConfig era ->
+  -- | see 'shelleyProtVer', mutatis mutandi
+  SL.ProtVer ->
+  ( ProtocolInfo (ShelleyBlock (Praos c) era)
+  , Tracer.Tracer m KESAgentClientTrace -> m [MkBlockForging m (ShelleyBlock (Praos c) era)]
+  )
+protocolInfoPraosShelleyBased
+  ProtocolParamsShelleyBased
+    { shelleyBasedInitialNonce = initialNonce
+    , shelleyBasedLeaderCredentials = credentialss
+    }
+  transitionCfg
+  protVer =
+    assertWithMsg (validateGenesis genesis) $
+      ( ProtocolInfo
+          { pInfoConfig = topLevelConfig
+          , pInfoInitLedger = initExtLedgerState
+          }
+      , \tr -> pure $ mkBlockForging tr <$> credentialss
+      )
+   where
+    mkBlockForging ::
+      Tracer.Tracer m KESAgentClientTrace ->
+      ShelleyLeaderCredentials c ->
+      MkBlockForging m (ShelleyBlock (Praos c) era)
+    mkBlockForging tr credentials = MkBlockForging $ do
+      let canBeLeader = shelleyLeaderCredentialsCanBeLeader credentials
+
+      hotKey :: HotKey c m <-
+        instantiatePraosCredentials
+          (praosMaxKESEvo praosParams)
+          tr
+          (praosCanBeLeaderCredentialsSource canBeLeader)
+
+      return $ praosBlockForging praosParams hotKey credentials
+
+    genesis :: SL.ShelleyGenesis
+    genesis = transitionCfg ^. L.tcShelleyGenesisL
+
+    maxMajorProtVer :: MaxMajorProtVer
+    maxMajorProtVer = MaxMajorProtVer $ SL.pvMajor protVer
+
+    topLevelConfig :: TopLevelConfig (ShelleyBlock (Praos c) era)
+    topLevelConfig =
+      TopLevelConfig
+        { topLevelConfigProtocol = consensusConfig
+        , topLevelConfigLedger = ledgerConfig
+        , topLevelConfigBlock = blockConfig
+        , topLevelConfigCodec = ShelleyCodecConfig
+        , topLevelConfigStorage = storageConfig
+        , topLevelConfigCheckpoints = emptyCheckpointsMap
+        }
+
+    consensusConfig :: ConsensusConfig (BlockProtocol (ShelleyBlock (Praos c) era))
+    consensusConfig =
+      PraosConfig
+        { praosParams
+        , praosEpochInfo = epochInfo
+        }
+
+    ledgerConfig :: LedgerConfig (ShelleyBlock (Praos c) era)
+    ledgerConfig =
+      mkShelleyLedgerConfig
+        genesis
+        (transitionCfg ^. L.tcTranslationContextL)
+        epochInfo
+
+    epochInfo :: EpochInfo (Except History.PastHorizonException)
+    epochInfo =
+      fixedEpochInfo
+        (SL.sgEpochLength genesis)
+        (mkSlotLength $ SL.fromNominalDiffTimeMicro $ SL.sgSlotLength genesis)
+
+    praosParams :: PraosParams
+    praosParams =
+      PraosParams
+        { praosSlotsPerKESPeriod = SL.sgSlotsPerKESPeriod genesis
+        , praosLeaderF = SL.mkActiveSlotCoeff $ SL.sgActiveSlotsCoeff genesis
+        , praosSecurityParam = SecurityParam $ SL.sgSecurityParam genesis
+        , praosMaxKESEvo = SL.sgMaxKESEvolutions genesis
+        , praosMaxMajorPV = maxMajorProtVer
+        , praosRandomnessStabilisationWindow =
+            SL.computeRandomnessStabilisationWindow
+              (unNonZero $ SL.sgSecurityParam genesis)
+              (SL.mkActiveSlotCoeff $ SL.sgActiveSlotsCoeff genesis)
+        }
+
+    blockConfig :: BlockConfig (ShelleyBlock (Praos c) era)
+    blockConfig =
+      mkShelleyBlockConfig
+        protVer
+        genesis
+        (shelleyBlockIssuerVKey <$> credentialss)
+
+    storageConfig :: StorageConfig (ShelleyBlock (Praos c) era)
+    storageConfig =
+      ShelleyStorageConfig
+        { shelleyStorageConfigSlotsPerKESPeriod = praosSlotsPerKESPeriod praosParams
+        , shelleyStorageConfigSecurityParam = praosSecurityParam praosParams
+        }
+
+    initLedgerState :: LedgerState (ShelleyBlock (Praos c) era) ValuesMK
+    initLedgerState =
+      unstowLedgerTables
+        ShelleyLedgerState
+          { shelleyLedgerTip = Origin
+          , shelleyLedgerState =
+              L.injectIntoTestState transitionCfg $
+                L.createInitialState transitionCfg
+          , shelleyLedgerTransition = ShelleyTransitionInfo{shelleyAfterVoting = 0}
+          , shelleyLedgerTables = emptyLedgerTables
+          }
+
+    initChainDepState :: PraosState
+    initChainDepState =
+      translateChainDepState (Proxy @(TPraos c, Praos c)) $
+        TPraosState Origin $
+          SL.initialChainDepState initialNonce (SL.sgGenDelegs genesis)
+
+    initExtLedgerState :: ExtLedgerState (ShelleyBlock (Praos c) era) ValuesMK
+    initExtLedgerState =
+      ExtLedgerState
+        { ledgerState = initLedgerState
+        , headerState = genesisHeaderState initChainDepState
+        }