{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Ouroboros.Consensus.ByronDual.Node (protocolInfoDualByron) where

import qualified Byron.Spec.Ledger.Core as Spec
import qualified Byron.Spec.Ledger.Delegation as Spec
import qualified Byron.Spec.Ledger.UTxO as Spec
import qualified Byron.Spec.Ledger.Update as Spec
import qualified Cardano.Chain.Block as Impl
import qualified Cardano.Chain.Genesis as Impl
import qualified Cardano.Chain.UTxO as Impl
import qualified Cardano.Chain.Update as Impl
import qualified Cardano.Chain.Update.Validation.Interface as Impl
import Data.Either (fromRight)
import Data.Map.Strict (Map)
import Data.Maybe (fromMaybe)
import Ouroboros.Consensus.Block
import Ouroboros.Consensus.Byron.Ledger
import Ouroboros.Consensus.Byron.Node
import Ouroboros.Consensus.Byron.Protocol
import Ouroboros.Consensus.ByronDual.Ledger
import Ouroboros.Consensus.ByronDual.Node.Serialisation ()
import Ouroboros.Consensus.ByronSpec.Ledger
import qualified Ouroboros.Consensus.ByronSpec.Ledger.Genesis as Genesis
import Ouroboros.Consensus.Config
import Ouroboros.Consensus.HeaderValidation
import Ouroboros.Consensus.Ledger.Abstract
import Ouroboros.Consensus.Ledger.Dual
import Ouroboros.Consensus.Ledger.Extended
import Ouroboros.Consensus.Node.InitStorage
import Ouroboros.Consensus.Node.ProtocolInfo
import Ouroboros.Consensus.Node.Run
import Ouroboros.Consensus.NodeId
import Ouroboros.Consensus.Protocol.PBFT
import qualified Ouroboros.Consensus.Protocol.PBFT.State as S
import Ouroboros.Consensus.Storage.ChainDB.Init (InitChainDB (..))
import Ouroboros.Consensus.Util ((.....:))
import qualified Test.Cardano.Chain.Elaboration.Block as Spec.Test
import qualified Test.Cardano.Chain.Elaboration.Delegation as Spec.Test
import qualified Test.Cardano.Chain.Elaboration.Keys as Spec.Test
import qualified Test.Cardano.Chain.Elaboration.Update as Spec.Test
import qualified Test.Cardano.Chain.UTxO.Model as Spec.Test

{-------------------------------------------------------------------------------
  BlockForging
-------------------------------------------------------------------------------}

dualByronBlockForging ::
  Monad m =>
  ByronLeaderCredentials ->
  BlockForging m DualByronBlock
dualByronBlockForging :: forall (m :: * -> *).
Monad m =>
ByronLeaderCredentials -> BlockForging m DualByronBlock
dualByronBlockForging ByronLeaderCredentials
creds =
  BlockForging
    { forgeLabel :: Text
forgeLabel = Text
forgeLabel
    , canBeLeader :: CanBeLeader (BlockProtocol DualByronBlock)
canBeLeader = CanBeLeader (BlockProtocol DualByronBlock)
CanBeLeader (BlockProtocol ByronBlock)
canBeLeader
    , updateForgeState :: TopLevelConfig DualByronBlock
-> SlotNo
-> Ticked (ChainDepState (BlockProtocol DualByronBlock))
-> m (ForgeStateUpdateInfo DualByronBlock)
updateForgeState = \TopLevelConfig DualByronBlock
cfg ->
        (ForgeStateUpdateInfo ByronBlock
 -> ForgeStateUpdateInfo DualByronBlock)
-> m (ForgeStateUpdateInfo ByronBlock)
-> m (ForgeStateUpdateInfo DualByronBlock)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ForgeStateUpdateInfo ByronBlock
-> ForgeStateUpdateInfo DualByronBlock
forall blk blk'.
(ForgeStateInfo blk ~ ForgeStateInfo blk',
 ForgeStateUpdateError blk ~ ForgeStateUpdateError blk') =>
ForgeStateUpdateInfo blk -> ForgeStateUpdateInfo blk'
castForgeStateUpdateInfo (m (ForgeStateUpdateInfo ByronBlock)
 -> m (ForgeStateUpdateInfo DualByronBlock))
-> (SlotNo
    -> Ticked (PBftState PBftByronCrypto)
    -> m (ForgeStateUpdateInfo ByronBlock))
-> SlotNo
-> Ticked (PBftState PBftByronCrypto)
-> m (ForgeStateUpdateInfo DualByronBlock)
forall y z x0 x1. (y -> z) -> (x0 -> x1 -> y) -> x0 -> x1 -> z
.: TopLevelConfig ByronBlock
-> SlotNo
-> Ticked (ChainDepState (BlockProtocol ByronBlock))
-> m (ForgeStateUpdateInfo ByronBlock)
updateForgeState (TopLevelConfig DualByronBlock -> TopLevelConfig ByronBlock
forall m a. TopLevelConfig (DualBlock m a) -> TopLevelConfig m
dualTopLevelConfigMain TopLevelConfig DualByronBlock
cfg)
    , checkCanForge :: TopLevelConfig DualByronBlock
-> SlotNo
-> Ticked (ChainDepState (BlockProtocol DualByronBlock))
-> IsLeader (BlockProtocol DualByronBlock)
-> ForgeStateInfo DualByronBlock
-> Either (CannotForge DualByronBlock) ()
checkCanForge = TopLevelConfig ByronBlock
-> SlotNo
-> Ticked (ChainDepState (BlockProtocol ByronBlock))
-> IsLeader (BlockProtocol ByronBlock)
-> ForgeStateInfo ByronBlock
-> Either (CannotForge ByronBlock) ()
TopLevelConfig ByronBlock
-> SlotNo
-> Ticked (PBftState PBftByronCrypto)
-> PBftIsLeader PBftByronCrypto
-> ()
-> Either (PBftCannotForge PBftByronCrypto) ()
checkCanForge (TopLevelConfig ByronBlock
 -> SlotNo
 -> Ticked (PBftState PBftByronCrypto)
 -> PBftIsLeader PBftByronCrypto
 -> ()
 -> Either (PBftCannotForge PBftByronCrypto) ())
-> (TopLevelConfig DualByronBlock -> TopLevelConfig ByronBlock)
-> TopLevelConfig DualByronBlock
-> SlotNo
-> Ticked (PBftState PBftByronCrypto)
-> PBftIsLeader PBftByronCrypto
-> ()
-> Either (PBftCannotForge PBftByronCrypto) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TopLevelConfig DualByronBlock -> TopLevelConfig ByronBlock
forall m a. TopLevelConfig (DualBlock m a) -> TopLevelConfig m
dualTopLevelConfigMain
    , forgeBlock :: TopLevelConfig DualByronBlock
-> BlockNo
-> SlotNo
-> TickedLedgerState DualByronBlock EmptyMK
-> [Validated (GenTx DualByronBlock)]
-> IsLeader (BlockProtocol DualByronBlock)
-> m DualByronBlock
forgeBlock = DualByronBlock -> m DualByronBlock
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (DualByronBlock -> m DualByronBlock)
-> (TopLevelConfig DualByronBlock
    -> BlockNo
    -> SlotNo
    -> TickedLedgerState DualByronBlock EmptyMK
    -> [Validated (GenTx DualByronBlock)]
    -> PBftIsLeader PBftByronCrypto
    -> DualByronBlock)
-> TopLevelConfig DualByronBlock
-> BlockNo
-> SlotNo
-> TickedLedgerState DualByronBlock EmptyMK
-> [Validated (GenTx DualByronBlock)]
-> PBftIsLeader PBftByronCrypto
-> m DualByronBlock
forall y z x0 x1 x2 x3 x4 x5.
(y -> z)
-> (x0 -> x1 -> x2 -> x3 -> x4 -> x5 -> y)
-> x0
-> x1
-> x2
-> x3
-> x4
-> x5
-> z
.....: TopLevelConfig DualByronBlock
-> BlockNo
-> SlotNo
-> TickedLedgerState DualByronBlock EmptyMK
-> [Validated (GenTx DualByronBlock)]
-> PBftIsLeader PBftByronCrypto
-> DualByronBlock
forall (mk :: MapKind).
HasCallStack =>
TopLevelConfig DualByronBlock
-> BlockNo
-> SlotNo
-> TickedLedgerState DualByronBlock mk
-> [Validated (GenTx DualByronBlock)]
-> PBftIsLeader PBftByronCrypto
-> DualByronBlock
forgeDualByronBlock
    }
 where
  BlockForging{Text
CanBeLeader (BlockProtocol ByronBlock)
TopLevelConfig ByronBlock
-> BlockNo
-> SlotNo
-> TickedLedgerState ByronBlock EmptyMK
-> [Validated (GenTx ByronBlock)]
-> IsLeader (BlockProtocol ByronBlock)
-> m ByronBlock
TopLevelConfig ByronBlock
-> SlotNo
-> Ticked (ChainDepState (BlockProtocol ByronBlock))
-> m (ForgeStateUpdateInfo ByronBlock)
TopLevelConfig ByronBlock
-> SlotNo
-> Ticked (ChainDepState (BlockProtocol ByronBlock))
-> IsLeader (BlockProtocol ByronBlock)
-> ForgeStateInfo ByronBlock
-> Either (CannotForge ByronBlock) ()
forgeLabel :: forall (m :: * -> *) blk. BlockForging m blk -> Text
forgeLabel :: Text
canBeLeader :: forall (m :: * -> *) blk.
BlockForging m blk -> CanBeLeader (BlockProtocol blk)
canBeLeader :: CanBeLeader (BlockProtocol ByronBlock)
updateForgeState :: forall (m :: * -> *) blk.
BlockForging m blk
-> TopLevelConfig blk
-> SlotNo
-> Ticked (ChainDepState (BlockProtocol blk))
-> m (ForgeStateUpdateInfo blk)
updateForgeState :: TopLevelConfig ByronBlock
-> SlotNo
-> Ticked (ChainDepState (BlockProtocol ByronBlock))
-> m (ForgeStateUpdateInfo ByronBlock)
checkCanForge :: forall (m :: * -> *) blk.
BlockForging m blk
-> TopLevelConfig blk
-> SlotNo
-> Ticked (ChainDepState (BlockProtocol blk))
-> IsLeader (BlockProtocol blk)
-> ForgeStateInfo blk
-> Either (CannotForge blk) ()
checkCanForge :: TopLevelConfig ByronBlock
-> SlotNo
-> Ticked (ChainDepState (BlockProtocol ByronBlock))
-> IsLeader (BlockProtocol ByronBlock)
-> ForgeStateInfo ByronBlock
-> Either (CannotForge ByronBlock) ()
forgeBlock :: forall (m :: * -> *) blk.
BlockForging m blk
-> TopLevelConfig blk
-> BlockNo
-> SlotNo
-> TickedLedgerState blk EmptyMK
-> [Validated (GenTx blk)]
-> IsLeader (BlockProtocol blk)
-> m blk
forgeBlock :: TopLevelConfig ByronBlock
-> BlockNo
-> SlotNo
-> TickedLedgerState ByronBlock EmptyMK
-> [Validated (GenTx ByronBlock)]
-> IsLeader (BlockProtocol ByronBlock)
-> m ByronBlock
..} = ByronLeaderCredentials -> BlockForging m ByronBlock
forall (m :: * -> *).
Monad m =>
ByronLeaderCredentials -> BlockForging m ByronBlock
byronBlockForging ByronLeaderCredentials
creds

{-------------------------------------------------------------------------------
  ProtocolInfo

  Partly modelled after 'applyTrace' in "Test.Cardano.Chain.Block.Model".
-------------------------------------------------------------------------------}

protocolInfoDualByron ::
  forall m.
  Monad m =>
  ByronSpecGenesis ->
  PBftParams ->
  -- | Are we a core node?
  [CoreNodeId] ->
  ( ProtocolInfo DualByronBlock
  , m [BlockForging m DualByronBlock]
  )
protocolInfoDualByron :: forall (m :: * -> *).
Monad m =>
ByronSpecGenesis
-> PBftParams
-> [CoreNodeId]
-> (ProtocolInfo DualByronBlock, m [BlockForging m DualByronBlock])
protocolInfoDualByron abstractGenesis :: ByronSpecGenesis
abstractGenesis@ByronSpecGenesis{Natural
Set VKeyGenesis
BlockCount
PParams
UTxO
byronSpecGenesisDelegators :: Set VKeyGenesis
byronSpecGenesisInitUtxo :: UTxO
byronSpecGenesisInitPParams :: PParams
byronSpecGenesisSecurityParam :: BlockCount
byronSpecGenesisSlotLength :: Natural
byronSpecGenesisSlotLength :: ByronSpecGenesis -> Natural
byronSpecGenesisSecurityParam :: ByronSpecGenesis -> BlockCount
byronSpecGenesisInitPParams :: ByronSpecGenesis -> PParams
byronSpecGenesisInitUtxo :: ByronSpecGenesis -> UTxO
byronSpecGenesisDelegators :: ByronSpecGenesis -> Set VKeyGenesis
..} PBftParams
params [CoreNodeId]
credss =
  ( ProtocolInfo
      { pInfoConfig :: TopLevelConfig DualByronBlock
pInfoConfig =
          TopLevelConfig
            { topLevelConfigProtocol :: ConsensusConfig (BlockProtocol DualByronBlock)
topLevelConfigProtocol =
                PBftConfig
                  { pbftParams :: PBftParams
pbftParams = PBftParams
params
                  }
            , topLevelConfigLedger :: LedgerConfig DualByronBlock
topLevelConfigLedger =
                DualLedgerConfig
                  { dualLedgerConfigMain :: LedgerConfig ByronBlock
dualLedgerConfigMain = Config
LedgerConfig ByronBlock
concreteGenesis
                  , dualLedgerConfigAux :: LedgerConfig ByronSpecBlock
dualLedgerConfigAux = LedgerConfig ByronSpecBlock
abstractConfig
                  }
            , topLevelConfigBlock :: BlockConfig DualByronBlock
topLevelConfigBlock =
                DualBlockConfig
                  { dualBlockConfigMain :: BlockConfig ByronBlock
dualBlockConfigMain = BlockConfig ByronBlock
concreteConfig
                  , dualBlockConfigAux :: BlockConfig ByronSpecBlock
dualBlockConfigAux = BlockConfig ByronSpecBlock
ByronSpecBlockConfig
                  }
            , topLevelConfigCodec :: CodecConfig DualByronBlock
topLevelConfigCodec =
                DualCodecConfig
                  { dualCodecConfigMain :: CodecConfig ByronBlock
dualCodecConfigMain = Config -> CodecConfig ByronBlock
mkByronCodecConfig Config
concreteGenesis
                  , dualCodecConfigAux :: CodecConfig ByronSpecBlock
dualCodecConfigAux = CodecConfig ByronSpecBlock
ByronSpecCodecConfig
                  }
            , topLevelConfigStorage :: StorageConfig DualByronBlock
topLevelConfigStorage =
                DualStorageConfig
                  { dualStorageConfigMain :: StorageConfig ByronBlock
dualStorageConfigMain = BlockConfig ByronBlock -> StorageConfig ByronBlock
ByronStorageConfig BlockConfig ByronBlock
concreteConfig
                  , dualStorageConfigAux :: StorageConfig ByronSpecBlock
dualStorageConfigAux = StorageConfig ByronSpecBlock
ByronSpecStorageConfig
                  }
            , topLevelConfigCheckpoints :: CheckpointsMap DualByronBlock
topLevelConfigCheckpoints = CheckpointsMap DualByronBlock
forall blk. CheckpointsMap blk
emptyCheckpointsMap
            }
      , pInfoInitLedger :: ExtLedgerState DualByronBlock ValuesMK
pInfoInitLedger =
          ExtLedgerState
            { ledgerState :: LedgerState DualByronBlock ValuesMK
ledgerState =
                DualLedgerState
                  { dualLedgerStateMain :: LedgerState ByronBlock ValuesMK
dualLedgerStateMain = LedgerState ByronBlock ValuesMK
initConcreteState
                  , dualLedgerStateAux :: LedgerState ByronSpecBlock ValuesMK
dualLedgerStateAux = LedgerState ByronSpecBlock ValuesMK
initAbstractState
                  , dualLedgerStateBridge :: BridgeLedger ByronBlock ByronSpecBlock
dualLedgerStateBridge = BridgeLedger ByronBlock ByronSpecBlock
initBridge
                  }
            , headerState :: HeaderState DualByronBlock
headerState = ChainDepState (BlockProtocol DualByronBlock)
-> HeaderState DualByronBlock
forall blk. ChainDepState (BlockProtocol blk) -> HeaderState blk
genesisHeaderState ChainDepState (BlockProtocol DualByronBlock)
PBftState PBftByronCrypto
forall c. PBftState c
S.empty
            }
      }
  , [BlockForging m DualByronBlock]
-> m [BlockForging m DualByronBlock]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([BlockForging m DualByronBlock]
 -> m [BlockForging m DualByronBlock])
-> [BlockForging m DualByronBlock]
-> m [BlockForging m DualByronBlock]
forall a b. (a -> b) -> a -> b
$ ByronLeaderCredentials -> BlockForging m DualByronBlock
forall (m :: * -> *).
Monad m =>
ByronLeaderCredentials -> BlockForging m DualByronBlock
dualByronBlockForging (ByronLeaderCredentials -> BlockForging m DualByronBlock)
-> (CoreNodeId -> ByronLeaderCredentials)
-> CoreNodeId
-> BlockForging m DualByronBlock
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreNodeId -> ByronLeaderCredentials
byronLeaderCredentials (CoreNodeId -> BlockForging m DualByronBlock)
-> [CoreNodeId] -> [BlockForging m DualByronBlock]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [CoreNodeId]
credss
  )
 where
  initUtxo :: Impl.UTxO
  txIdMap :: Map Spec.TxId Impl.TxId
  (UTxO
initUtxo, Map TxId TxId
txIdMap) = UTxO -> (UTxO, Map TxId TxId)
Spec.Test.elaborateInitialUTxO UTxO
byronSpecGenesisInitUtxo

  -- 'Spec.Test.abEnvToCfg' ignores the UTxO, because the Byron genesis
  -- data doesn't contain a UTxO, but only a 'UTxOConfiguration'.
  --
  -- It also ignores the slot length (the Byron spec does not talk about
  -- slot lengths at all) so we have to set this ourselves.
  concreteGenesis :: Impl.Config
  concreteGenesis :: Config
concreteGenesis =
    Config
translated
      { Impl.configGenesisData =
          configGenesisData
            { Impl.gdProtocolParameters =
                protocolParameters
                  { Impl.ppSlotDuration = byronSpecGenesisSlotLength
                  }
            }
      }
   where
    translated :: Config
translated = Environment CHAIN -> Config
Spec.Test.abEnvToCfg (Environment CHAIN -> Config) -> Environment CHAIN -> Config
forall a b. (a -> b) -> a -> b
$ ByronSpecGenesis -> Environment CHAIN
Genesis.toChainEnv ByronSpecGenesis
abstractGenesis
    configGenesisData :: GenesisData
configGenesisData = Config -> GenesisData
Impl.configGenesisData Config
translated
    protocolParameters :: ProtocolParameters
protocolParameters = GenesisData -> ProtocolParameters
Impl.gdProtocolParameters GenesisData
configGenesisData

  initAbstractState :: LedgerState ByronSpecBlock ValuesMK
  initConcreteState :: LedgerState ByronBlock ValuesMK

  initAbstractState :: LedgerState ByronSpecBlock ValuesMK
initAbstractState = ByronSpecGenesis -> LedgerState ByronSpecBlock ValuesMK
forall (mk :: MapKind).
ByronSpecGenesis -> LedgerState ByronSpecBlock mk
initByronSpecLedgerState ByronSpecGenesis
abstractGenesis
  initConcreteState :: LedgerState ByronBlock ValuesMK
initConcreteState = Config -> Maybe UTxO -> LedgerState ByronBlock ValuesMK
forall (mk :: MapKind).
Config -> Maybe UTxO -> LedgerState ByronBlock mk
initByronLedgerState Config
concreteGenesis (UTxO -> Maybe UTxO
forall a. a -> Maybe a
Just UTxO
initUtxo)

  abstractConfig :: LedgerConfig ByronSpecBlock
  concreteConfig :: BlockConfig ByronBlock

  abstractConfig :: LedgerConfig ByronSpecBlock
abstractConfig = LedgerConfig ByronSpecBlock
ByronSpecGenesis
abstractGenesis
  concreteConfig :: BlockConfig ByronBlock
concreteConfig =
    Config
-> ProtocolVersion -> SoftwareVersion -> BlockConfig ByronBlock
mkByronConfig
      Config
concreteGenesis
      ProtocolVersion
protocolVersion
      SoftwareVersion
softwareVersion
   where
    -- TODO: Take (spec) protocol version and (spec) software version
    -- as arguments instead, and then translate /those/ to Impl types.
    -- <https://github.com/IntersectMBO/ouroboros-network/issues/1495>
    protocolVersion :: Impl.ProtocolVersion
    protocolVersion :: ProtocolVersion
protocolVersion =
      State -> ProtocolVersion
Impl.adoptedProtocolVersion (State -> ProtocolVersion) -> State -> ProtocolVersion
forall a b. (a -> b) -> a -> b
$
        ChainValidationState -> State
Impl.cvsUpdateState (LedgerState ByronBlock ValuesMK -> ChainValidationState
forall (mk :: MapKind).
LedgerState ByronBlock mk -> ChainValidationState
byronLedgerState LedgerState ByronBlock ValuesMK
initConcreteState)

    -- The spec has a TODO about this; we just copy what 'elaborate' does
    -- (Test.Cardano.Chain.Elaboration.Block)
    softwareVersion :: Impl.SoftwareVersion
    softwareVersion :: SoftwareVersion
softwareVersion =
      SwVer -> SoftwareVersion
Spec.Test.elaborateSoftwareVersion (SwVer -> SoftwareVersion) -> SwVer -> SoftwareVersion
forall a b. (a -> b) -> a -> b
$
        ApName -> ApVer -> SwVer
Spec.SwVer ([Char] -> ApName
Spec.ApName [Char]
"") (Natural -> ApVer
Spec.ApVer Natural
0)

  initBridge :: DualByronBridge
  initBridge :: BridgeLedger ByronBlock ByronSpecBlock
initBridge = ByronSpecGenesis -> Map TxId TxId -> ByronSpecBridge
initByronSpecBridge ByronSpecGenesis
abstractGenesis Map TxId TxId
txIdMap

  byronLeaderCredentials :: CoreNodeId -> ByronLeaderCredentials
  byronLeaderCredentials :: CoreNodeId -> ByronLeaderCredentials
byronLeaderCredentials CoreNodeId
nid =
    ByronLeaderCredentials
-> Either ByronLeaderCredentialsError ByronLeaderCredentials
-> ByronLeaderCredentials
forall b a. b -> Either a b -> b
fromRight ([Char] -> ByronLeaderCredentials
forall a. HasCallStack => [Char] -> a
error [Char]
"byronLeaderCredentials: failed to construct credentials") (Either ByronLeaderCredentialsError ByronLeaderCredentials
 -> ByronLeaderCredentials)
-> Either ByronLeaderCredentialsError ByronLeaderCredentials
-> ByronLeaderCredentials
forall a b. (a -> b) -> a -> b
$
      Config
-> SigningKey
-> Certificate
-> Text
-> Either ByronLeaderCredentialsError ByronLeaderCredentials
mkByronLeaderCredentials
        Config
concreteGenesis
        (VKey -> SigningKey
Spec.Test.vKeyToSKey VKey
vkey)
        ( ProtocolMagicId -> DCert -> Certificate
Spec.Test.elaborateDCert
            (Config -> ProtocolMagicId
Impl.configProtocolMagicId Config
concreteGenesis)
            DCert
abstractDCert
        )
        Text
"byronLeaderCredentials"
   where
    -- PBFT constructs the core node ID by the implicit ordering of
    -- the hashes of the verification keys in the genesis config. Here
    -- we go the other way, looking up this hash, and then using our
    -- translation map to find the corresponding abstract key.
    --
    -- TODO: We should be able to use keys that are /not/ in genesis
    -- (so that we can start the node with new delegated keys that aren't
    -- present in the genesis config).
    -- <https://github.com/IntersectMBO/ouroboros-network/issues/1495>
    keyHash :: PBftVerKeyHash PBftByronCrypto
    keyHash :: PBftVerKeyHash PBftByronCrypto
keyHash =
      KeyHash -> Maybe KeyHash -> KeyHash
forall a. a -> Maybe a -> a
fromMaybe
        ([Char] -> KeyHash
forall a. HasCallStack => [Char] -> a
error ([Char] -> KeyHash) -> [Char] -> KeyHash
forall a b. (a -> b) -> a -> b
$ [Char]
"mkCredentials: invalid " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ CoreNodeId -> [Char]
forall a. Show a => a -> [Char]
show CoreNodeId
nid)
        (Config -> CoreNodeId -> Maybe KeyHash
nodeIdToGenesisKey Config
concreteGenesis CoreNodeId
nid)

    vkey :: Spec.VKey
    vkey :: VKey
vkey = BridgeLedger ByronBlock ByronSpecBlock
-> PBftVerKeyHash PBftByronCrypto -> VKey
bridgeToSpecKey BridgeLedger ByronBlock ByronSpecBlock
initBridge PBftVerKeyHash PBftByronCrypto
keyHash

    abstractDCert :: Spec.DCert
    abstractDCert :: DCert
abstractDCert =
      HasCallStack => VKey -> BlockCount -> State CHAIN -> DCert
VKey -> BlockCount -> State CHAIN -> DCert
Spec.Test.rcDCert
        VKey
vkey
        BlockCount
byronSpecGenesisSecurityParam
        (LedgerState ByronSpecBlock ValuesMK -> State CHAIN
forall (mk :: MapKind).
LedgerState ByronSpecBlock mk -> State CHAIN
byronSpecLedgerState LedgerState ByronSpecBlock ValuesMK
initAbstractState)

{-------------------------------------------------------------------------------
  NodeInitStorage instance
-------------------------------------------------------------------------------}

instance NodeInitStorage DualByronBlock where
  -- Just like Byron, we need to start with an EBB
  nodeInitChainDB :: forall (m :: * -> *).
IOLike m =>
StorageConfig DualByronBlock
-> InitChainDB m DualByronBlock -> m ()
nodeInitChainDB StorageConfig DualByronBlock
cfg InitChainDB{m (LedgerState DualByronBlock EmptyMK)
getCurrentLedger :: m (LedgerState DualByronBlock EmptyMK)
getCurrentLedger :: forall (m :: * -> *) blk.
InitChainDB m blk -> m (LedgerState blk EmptyMK)
getCurrentLedger, DualByronBlock -> m ()
addBlock :: DualByronBlock -> m ()
addBlock :: forall (m :: * -> *) blk. InitChainDB m blk -> blk -> m ()
addBlock} = do
    tip <- LedgerState DualByronBlock EmptyMK -> Point DualByronBlock
forall blk (mk :: MapKind).
UpdateLedger blk =>
LedgerState blk mk -> Point blk
ledgerTipPoint (LedgerState DualByronBlock EmptyMK -> Point DualByronBlock)
-> m (LedgerState DualByronBlock EmptyMK)
-> m (Point DualByronBlock)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (LedgerState DualByronBlock EmptyMK)
getCurrentLedger
    case tip of
      BlockPoint{} -> () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      Point DualByronBlock
GenesisPoint -> DualByronBlock -> m ()
addBlock DualByronBlock
genesisEBB
   where
    genesisEBB :: DualByronBlock
    genesisEBB :: DualByronBlock
genesisEBB =
      DualBlock
        { dualBlockMain :: ByronBlock
dualBlockMain = ByronBlock
byronEBB
        , dualBlockAux :: Maybe ByronSpecBlock
dualBlockAux = Maybe ByronSpecBlock
forall a. Maybe a
Nothing
        , dualBlockBridge :: BridgeBlock ByronBlock ByronSpecBlock
dualBlockBridge = BridgeBlock ByronBlock ByronSpecBlock
SpecToImplIds
forall a. Monoid a => a
mempty
        }

    byronEBB :: ByronBlock
    byronEBB :: ByronBlock
byronEBB =
      BlockConfig ByronBlock
-> SlotNo -> BlockNo -> ChainHash ByronBlock -> ByronBlock
forgeEBB
        (StorageConfig ByronBlock -> BlockConfig ByronBlock
getByronBlockConfig (StorageConfig DualByronBlock -> StorageConfig ByronBlock
forall m a. StorageConfig (DualBlock m a) -> StorageConfig m
dualStorageConfigMain StorageConfig DualByronBlock
cfg))
        (Word64 -> SlotNo
SlotNo Word64
0)
        (Word64 -> BlockNo
BlockNo Word64
0)
        ChainHash ByronBlock
forall {k} (b :: k). ChainHash b
GenesisHash

  -- Node config is a consensus concern, determined by the main block only
  nodeImmutableDbChunkInfo :: StorageConfig DualByronBlock -> ChunkInfo
nodeImmutableDbChunkInfo = StorageConfig ByronBlock -> ChunkInfo
forall blk. NodeInitStorage blk => StorageConfig blk -> ChunkInfo
nodeImmutableDbChunkInfo (StorageConfig ByronBlock -> ChunkInfo)
-> (StorageConfig DualByronBlock -> StorageConfig ByronBlock)
-> StorageConfig DualByronBlock
-> ChunkInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StorageConfig DualByronBlock -> StorageConfig ByronBlock
forall m a. StorageConfig (DualBlock m a) -> StorageConfig m
dualStorageConfigMain

  -- We don't really care too much about data loss or malicious behaviour for
  -- the dual ledger tests, so integrity and match checks can just use the
  -- concrete implementation
  nodeCheckIntegrity :: StorageConfig DualByronBlock -> DualByronBlock -> Bool
nodeCheckIntegrity StorageConfig DualByronBlock
cfg = StorageConfig ByronBlock -> ByronBlock -> Bool
forall blk. NodeInitStorage blk => StorageConfig blk -> blk -> Bool
nodeCheckIntegrity (StorageConfig DualByronBlock -> StorageConfig ByronBlock
forall m a. StorageConfig (DualBlock m a) -> StorageConfig m
dualStorageConfigMain StorageConfig DualByronBlock
cfg) (ByronBlock -> Bool)
-> (DualByronBlock -> ByronBlock) -> DualByronBlock -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DualByronBlock -> ByronBlock
forall m a. DualBlock m a -> m
dualBlockMain

{-------------------------------------------------------------------------------
  RunNode instance
-------------------------------------------------------------------------------}

instance BlockSupportsMetrics DualByronBlock where
  isSelfIssued :: BlockConfig DualByronBlock
-> Header DualByronBlock -> WhetherSelfIssued
isSelfIssued = BlockConfig DualByronBlock
-> Header DualByronBlock -> WhetherSelfIssued
forall blk. BlockConfig blk -> Header blk -> WhetherSelfIssued
isSelfIssuedConstUnknown

instance BlockSupportsSanityCheck DualByronBlock where
  configAllSecurityParams :: TopLevelConfig DualByronBlock -> NonEmpty SecurityParam
configAllSecurityParams = SecurityParam -> NonEmpty SecurityParam
forall a. a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SecurityParam -> NonEmpty SecurityParam)
-> (TopLevelConfig DualByronBlock -> SecurityParam)
-> TopLevelConfig DualByronBlock
-> NonEmpty SecurityParam
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TopLevelConfig DualByronBlock -> SecurityParam
forall blk.
ConsensusProtocol (BlockProtocol blk) =>
TopLevelConfig blk -> SecurityParam
configSecurityParam

deriving via
  SelectViewDiffusionPipelining DualByronBlock
  instance
    BlockSupportsDiffusionPipelining DualByronBlock

instance RunNode DualByronBlock