{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Ouroboros.Consensus.Mock.Node.PBFT
  ( MockPBftBlock
  , blockForgingMockPBFT
  , protocolInfoMockPBFT
  ) where

import Cardano.Crypto.DSIGN
import qualified Data.Bimap as Bimap
import Ouroboros.Consensus.Block
import Ouroboros.Consensus.Config
import qualified Ouroboros.Consensus.HardFork.History as HardFork
import Ouroboros.Consensus.HeaderValidation
import Ouroboros.Consensus.Ledger.Extended
import Ouroboros.Consensus.Ledger.Peras (initPerasState)
import Ouroboros.Consensus.Mock.Ledger
import Ouroboros.Consensus.Node.ProtocolInfo
import Ouroboros.Consensus.NodeId (CoreNodeId (..))
import Ouroboros.Consensus.Protocol.PBFT
import qualified Ouroboros.Consensus.Protocol.PBFT.State as S

type MockPBftBlock = SimplePBftBlock SimpleMockCrypto PBftMockCrypto

protocolInfoMockPBFT ::
  PBftParams ->
  HardFork.EraParams ->
  ProtocolInfo MockPBftBlock
protocolInfoMockPBFT :: PBftParams -> EraParams -> ProtocolInfo MockPBftBlock
protocolInfoMockPBFT PBftParams
params EraParams
eraParams =
  let ledgerConfig :: SimpleLedgerConfig
  SimpleMockCrypto (SimplePBftExt SimpleMockCrypto PBftMockCrypto)
ledgerConfig = MockLedgerConfig
  SimpleMockCrypto (SimplePBftExt SimpleMockCrypto PBftMockCrypto)
-> EraParams
-> MockConfig
-> SimpleLedgerConfig
     SimpleMockCrypto (SimplePBftExt SimpleMockCrypto PBftMockCrypto)
forall c ext.
MockLedgerConfig c ext
-> EraParams -> MockConfig -> SimpleLedgerConfig c ext
SimpleLedgerConfig PBftLedgerView PBftMockCrypto
MockLedgerConfig
  SimpleMockCrypto (SimplePBftExt SimpleMockCrypto PBftMockCrypto)
ledgerView EraParams
eraParams MockConfig
defaultMockConfig
   in ProtocolInfo
        { pInfoConfig :: TopLevelConfig MockPBftBlock
pInfoConfig =
            TopLevelConfig
              { topLevelConfigProtocol :: ConsensusConfig (BlockProtocol MockPBftBlock)
topLevelConfigProtocol =
                  PBftConfig
                    { pbftParams :: PBftParams
pbftParams = PBftParams
params
                    }
              , topLevelConfigLedger :: LedgerConfig MockPBftBlock
topLevelConfigLedger = LedgerConfig MockPBftBlock
SimpleLedgerConfig
  SimpleMockCrypto (SimplePBftExt SimpleMockCrypto PBftMockCrypto)
ledgerConfig
              , topLevelConfigBlock :: BlockConfig MockPBftBlock
topLevelConfigBlock = BlockConfig MockPBftBlock
forall c ext. BlockConfig (SimpleBlock c ext)
SimpleBlockConfig
              , topLevelConfigCodec :: CodecConfig MockPBftBlock
topLevelConfigCodec = CodecConfig MockPBftBlock
forall c ext. CodecConfig (SimpleBlock c ext)
SimpleCodecConfig
              , topLevelConfigStorage :: StorageConfig MockPBftBlock
topLevelConfigStorage = SecurityParam -> StorageConfig MockPBftBlock
forall c ext. SecurityParam -> StorageConfig (SimpleBlock c ext)
SimpleStorageConfig (PBftParams -> SecurityParam
pbftSecurityParam PBftParams
params)
              , topLevelConfigCheckpoints :: CheckpointsMap MockPBftBlock
topLevelConfigCheckpoints = CheckpointsMap MockPBftBlock
forall blk. CheckpointsMap blk
emptyCheckpointsMap
              }
        , pInfoInitLedger :: ExtLedgerState MockPBftBlock ValuesMK
pInfoInitLedger =
            let ledgerState :: LedgerState (SimpleBlock c ext) ValuesMK
ledgerState = AddrDist -> LedgerState (SimpleBlock c ext) ValuesMK
forall c ext. AddrDist -> LedgerState (SimpleBlock c ext) ValuesMK
genesisSimpleLedgerState AddrDist
addrDist
                headerState :: HeaderState MockPBftBlock
headerState = ChainDepState (BlockProtocol MockPBftBlock)
-> HeaderState MockPBftBlock
forall blk. ChainDepState (BlockProtocol blk) -> HeaderState blk
genesisHeaderState ChainDepState (BlockProtocol MockPBftBlock)
PBftState PBftMockCrypto
forall c. PBftState c
S.empty
                perasState :: PerasState MockPBftBlock
perasState = LedgerConfig MockPBftBlock
-> LedgerState MockPBftBlock ValuesMK
-> HeaderState MockPBftBlock
-> PerasState MockPBftBlock
forall blk (mk :: * -> * -> *).
(All Top (HardForkIndices blk), StateSupportsPerasEpochContext blk,
 HasLedgerTables LedgerState blk) =>
LedgerCfg LedgerState blk
-> LedgerState blk mk -> HeaderState blk -> PerasState blk
initPerasState LedgerConfig MockPBftBlock
SimpleLedgerConfig
  SimpleMockCrypto (SimplePBftExt SimpleMockCrypto PBftMockCrypto)
ledgerConfig LedgerState MockPBftBlock ValuesMK
forall {c} {ext}. LedgerState (SimpleBlock c ext) ValuesMK
ledgerState HeaderState MockPBftBlock
headerState
             in ExtLedgerState
                  { LedgerState MockPBftBlock ValuesMK
forall {c} {ext}. LedgerState (SimpleBlock c ext) ValuesMK
ledgerState :: forall {c} {ext}. LedgerState (SimpleBlock c ext) ValuesMK
ledgerState :: LedgerState MockPBftBlock ValuesMK
ledgerState
                  , HeaderState MockPBftBlock
headerState :: HeaderState MockPBftBlock
headerState :: HeaderState MockPBftBlock
headerState
                  , PerasState MockPBftBlock
perasState :: PerasState MockPBftBlock
perasState :: PerasState MockPBftBlock
perasState
                  }
        }
 where
  ledgerView :: PBftLedgerView PBftMockCrypto
  ledgerView :: PBftLedgerView PBftMockCrypto
ledgerView =
    Bimap
  (PBftVerKeyHash PBftMockCrypto) (PBftVerKeyHash PBftMockCrypto)
-> PBftLedgerView PBftMockCrypto
forall c.
Bimap (PBftVerKeyHash c) (PBftVerKeyHash c) -> PBftLedgerView c
PBftLedgerView (Bimap
   (PBftVerKeyHash PBftMockCrypto) (PBftVerKeyHash PBftMockCrypto)
 -> PBftLedgerView PBftMockCrypto)
-> Bimap
     (PBftVerKeyHash PBftMockCrypto) (PBftVerKeyHash PBftMockCrypto)
-> PBftLedgerView PBftMockCrypto
forall a b. (a -> b) -> a -> b
$
      [(PBftVerKeyHash PBftMockCrypto, PBftVerKeyHash PBftMockCrypto)]
-> Bimap
     (PBftVerKeyHash PBftMockCrypto) (PBftVerKeyHash PBftMockCrypto)
forall a b. (Ord a, Ord b) => [(a, b)] -> Bimap a b
Bimap.fromList
        [ (VerKeyDSIGN MockDSIGN -> PBftMockVerKeyHash
PBftMockVerKeyHash (CoreNodeId -> VerKeyDSIGN MockDSIGN
verKey CoreNodeId
n), VerKeyDSIGN MockDSIGN -> PBftMockVerKeyHash
PBftMockVerKeyHash (CoreNodeId -> VerKeyDSIGN MockDSIGN
verKey CoreNodeId
n))
        | CoreNodeId
n <- NumCoreNodes -> [CoreNodeId]
enumCoreNodes (PBftParams -> NumCoreNodes
pbftNumNodes PBftParams
params)
        ]

  verKey :: CoreNodeId -> VerKeyDSIGN MockDSIGN
  verKey :: CoreNodeId -> VerKeyDSIGN MockDSIGN
verKey (CoreNodeId Word64
n) = Word64 -> VerKeyDSIGN MockDSIGN
VerKeyMockDSIGN Word64
n

  addrDist :: AddrDist
  addrDist :: AddrDist
addrDist = NumCoreNodes -> AddrDist
mkAddrDist (PBftParams -> NumCoreNodes
pbftNumNodes PBftParams
params)

{-------------------------------------------------------------------------------
  BlockForging
-------------------------------------------------------------------------------}
--
blockForgingMockPBFT :: Monad m => CoreNodeId -> [BlockForging m MockPBftBlock]
blockForgingMockPBFT :: forall (m :: * -> *).
Monad m =>
CoreNodeId -> [BlockForging m MockPBftBlock]
blockForgingMockPBFT CoreNodeId
nid = [PBftCanBeLeader PBftMockCrypto -> BlockForging m MockPBftBlock
forall c c' (m :: * -> *).
(SimpleCrypto c, PBftCrypto c',
 Signable (PBftDSIGN c') (SignedSimplePBft c c'),
 ContextDSIGN (PBftDSIGN c') ~ (), Monad m) =>
PBftCanBeLeader c' -> BlockForging m (SimplePBftBlock c c')
pbftBlockForging PBftCanBeLeader PBftMockCrypto
canBeLeader]
 where
  canBeLeader :: PBftCanBeLeader PBftMockCrypto
  canBeLeader :: PBftCanBeLeader PBftMockCrypto
canBeLeader =
    PBftCanBeLeader
      { pbftCanBeLeaderCoreNodeId :: CoreNodeId
pbftCanBeLeaderCoreNodeId = CoreNodeId
nid
      , pbftCanBeLeaderSignKey :: SignKeyDSIGN (PBftDSIGN PBftMockCrypto)
pbftCanBeLeaderSignKey = CoreNodeId -> SignKeyDSIGN MockDSIGN
signKey CoreNodeId
nid
      , -- For Mock PBFT, we use our key as the genesis key.
        pbftCanBeLeaderDlgCert :: PBftDelegationCert PBftMockCrypto
pbftCanBeLeaderDlgCert = (CoreNodeId -> VerKeyDSIGN MockDSIGN
verKey CoreNodeId
nid, CoreNodeId -> VerKeyDSIGN MockDSIGN
verKey CoreNodeId
nid)
      }

  signKey :: CoreNodeId -> SignKeyDSIGN MockDSIGN
  signKey :: CoreNodeId -> SignKeyDSIGN MockDSIGN
signKey (CoreNodeId Word64
n) = Word64 -> SignKeyDSIGN MockDSIGN
SignKeyMockDSIGN Word64
n

  verKey :: CoreNodeId -> VerKeyDSIGN MockDSIGN
  verKey :: CoreNodeId -> VerKeyDSIGN MockDSIGN
verKey (CoreNodeId Word64
n) = Word64 -> VerKeyDSIGN MockDSIGN
VerKeyMockDSIGN Word64
n

pbftBlockForging ::
  ( SimpleCrypto c
  , PBftCrypto c'
  , Signable (PBftDSIGN c') (SignedSimplePBft c c')
  , ContextDSIGN (PBftDSIGN c') ~ ()
  , Monad m
  ) =>
  PBftCanBeLeader c' ->
  BlockForging m (SimplePBftBlock c c')
pbftBlockForging :: forall c c' (m :: * -> *).
(SimpleCrypto c, PBftCrypto c',
 Signable (PBftDSIGN c') (SignedSimplePBft c c'),
 ContextDSIGN (PBftDSIGN c') ~ (), Monad m) =>
PBftCanBeLeader c' -> BlockForging m (SimplePBftBlock c c')
pbftBlockForging PBftCanBeLeader c'
canBeLeader =
  BlockForging
    { forgeLabel :: Text
forgeLabel = Text
"pbftBlockForging"
    , CanBeLeader (BlockProtocol (SimpleBlock c (SimplePBftExt c c')))
PBftCanBeLeader c'
canBeLeader :: PBftCanBeLeader c'
canBeLeader :: CanBeLeader (BlockProtocol (SimpleBlock c (SimplePBftExt c c')))
canBeLeader
    , updateForgeState :: TopLevelConfig (SimpleBlock c (SimplePBftExt c c'))
-> SlotNo
-> Ticked
     (ChainDepState
        (BlockProtocol (SimpleBlock c (SimplePBftExt c c'))))
-> m (ForgeStateUpdateInfo (SimpleBlock c (SimplePBftExt c c')))
updateForgeState = \TopLevelConfig (SimpleBlock c (SimplePBftExt c c'))
_ SlotNo
_ Ticked
  (ChainDepState
     (BlockProtocol (SimpleBlock c (SimplePBftExt c c'))))
_ -> ForgeStateUpdateInfo (SimpleBlock c (SimplePBftExt c c'))
-> m (ForgeStateUpdateInfo (SimpleBlock c (SimplePBftExt c c')))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (ForgeStateUpdateInfo (SimpleBlock c (SimplePBftExt c c'))
 -> m (ForgeStateUpdateInfo (SimpleBlock c (SimplePBftExt c c'))))
-> ForgeStateUpdateInfo (SimpleBlock c (SimplePBftExt c c'))
-> m (ForgeStateUpdateInfo (SimpleBlock c (SimplePBftExt c c')))
forall a b. (a -> b) -> a -> b
$ ForgeStateInfo (SimpleBlock c (SimplePBftExt c c'))
-> ForgeStateUpdateInfo (SimpleBlock c (SimplePBftExt c c'))
forall blk. ForgeStateInfo blk -> ForgeStateUpdateInfo blk
ForgeStateUpdated ()
    , checkCanForge :: TopLevelConfig (SimpleBlock c (SimplePBftExt c c'))
-> SlotNo
-> Ticked
     (ChainDepState
        (BlockProtocol (SimpleBlock c (SimplePBftExt c c'))))
-> IsLeader (BlockProtocol (SimpleBlock c (SimplePBftExt c c')))
-> ForgeStateInfo (SimpleBlock c (SimplePBftExt c c'))
-> Either (CannotForge (SimpleBlock c (SimplePBftExt c c'))) ()
checkCanForge = \TopLevelConfig (SimpleBlock c (SimplePBftExt c c'))
cfg SlotNo
slot Ticked
  (ChainDepState
     (BlockProtocol (SimpleBlock c (SimplePBftExt c c'))))
tickedPBftState IsLeader (BlockProtocol (SimpleBlock c (SimplePBftExt c c')))
_isLeader ->
        Either (CannotForge (SimpleBlock c (SimplePBftExt c c'))) ()
-> ForgeStateInfo (SimpleBlock c (SimplePBftExt c c'))
-> Either (CannotForge (SimpleBlock c (SimplePBftExt c c'))) ()
forall a.
a -> ForgeStateInfo (SimpleBlock c (SimplePBftExt c c')) -> a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (CannotForge (SimpleBlock c (SimplePBftExt c c'))) ()
 -> ForgeStateInfo (SimpleBlock c (SimplePBftExt c c'))
 -> Either (CannotForge (SimpleBlock c (SimplePBftExt c c'))) ())
-> Either (CannotForge (SimpleBlock c (SimplePBftExt c c'))) ()
-> ForgeStateInfo (SimpleBlock c (SimplePBftExt c c'))
-> Either (CannotForge (SimpleBlock c (SimplePBftExt c c'))) ()
forall a b. (a -> b) -> a -> b
$
          ConsensusConfig (PBft c')
-> PBftCanBeLeader c'
-> SlotNo
-> Ticked (PBftState c')
-> Either (PBftCannotForge c') ()
forall c.
PBftCrypto c =>
ConsensusConfig (PBft c)
-> PBftCanBeLeader c
-> SlotNo
-> Ticked (PBftState c)
-> Either (PBftCannotForge c) ()
pbftCheckCanForge
            (TopLevelConfig (SimpleBlock c (SimplePBftExt c c'))
-> ConsensusConfig
     (BlockProtocol (SimpleBlock c (SimplePBftExt c c')))
forall blk.
TopLevelConfig blk -> ConsensusConfig (BlockProtocol blk)
configConsensus TopLevelConfig (SimpleBlock c (SimplePBftExt c c'))
cfg)
            PBftCanBeLeader c'
canBeLeader
            SlotNo
slot
            Ticked
  (ChainDepState
     (BlockProtocol (SimpleBlock c (SimplePBftExt c c'))))
Ticked (PBftState c')
tickedPBftState
    , forgeBlock :: ForgeBlockArgs (SimpleBlock c (SimplePBftExt c c'))
-> m (SimpleBlock c (SimplePBftExt c c'))
forgeBlock = SimpleBlock c (SimplePBftExt c c')
-> m (SimpleBlock c (SimplePBftExt c c'))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (SimpleBlock c (SimplePBftExt c c')
 -> m (SimpleBlock c (SimplePBftExt c c')))
-> (ForgeBlockArgs (SimpleBlock c (SimplePBftExt c c'))
    -> SimpleBlock c (SimplePBftExt c c'))
-> ForgeBlockArgs (SimpleBlock c (SimplePBftExt c c'))
-> m (SimpleBlock c (SimplePBftExt c c'))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ForgeExt c (SimplePBftExt c c')
-> ForgeBlockArgs (SimpleBlock c (SimplePBftExt c c'))
-> SimpleBlock c (SimplePBftExt c c')
forall c ext.
MockProtocolSpecific c ext =>
ForgeExt c ext
-> ForgeBlockArgs (SimpleBlock c ext) -> SimpleBlock c ext
forgeSimple ForgeExt c (SimplePBftExt c c')
forall c c'.
(SimpleCrypto c, PBftCrypto c',
 Signable (PBftDSIGN c') (SignedSimplePBft c c'),
 ContextDSIGN (PBftDSIGN c') ~ ()) =>
ForgeExt c (SimplePBftExt c c')
forgePBftExt
    , finalize :: m ()
finalize = () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    }