{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
{-# 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.SupportsMempool (txForgetValidated)
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 =
    ProtocolInfo {
        pInfoConfig :: TopLevelConfig MockPBftBlock
pInfoConfig = TopLevelConfig {
            topLevelConfigProtocol :: ConsensusConfig (BlockProtocol MockPBftBlock)
topLevelConfigProtocol = PBftConfig {
                pbftParams :: PBftParams
pbftParams = PBftParams
params
              }
          , topLevelConfigLedger :: LedgerConfig MockPBftBlock
topLevelConfigLedger      = 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
          , 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
pInfoInitLedger = LedgerState MockPBftBlock
-> HeaderState MockPBftBlock -> ExtLedgerState MockPBftBlock
forall blk.
LedgerState blk -> HeaderState blk -> ExtLedgerState blk
ExtLedgerState (AddrDist -> LedgerState MockPBftBlock
forall c ext. AddrDist -> LedgerState (SimpleBlock c ext)
genesisSimpleLedgerState AddrDist
addrDist)
                                         (ChainDepState (BlockProtocol MockPBftBlock)
-> HeaderState MockPBftBlock
forall blk. ChainDepState (BlockProtocol blk) -> HeaderState blk
genesisHeaderState ChainDepState (BlockProtocol MockPBftBlock)
PBftState PBftMockCrypto
forall c. PBftState c
S.empty)
      }
  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
$ [(PBftMockVerKeyHash, PBftMockVerKeyHash)]
-> Bimap PBftMockVerKeyHash PBftMockVerKeyHash
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 :: TopLevelConfig (SimpleBlock c (SimplePBftExt c c'))
-> BlockNo
-> SlotNo
-> TickedLedgerState (SimpleBlock c (SimplePBftExt c c'))
-> [Validated (GenTx (SimpleBlock c (SimplePBftExt c c')))]
-> IsLeader (BlockProtocol (SimpleBlock c (SimplePBftExt c c')))
-> m (SimpleBlock c (SimplePBftExt c c'))
forgeBlock       = \TopLevelConfig (SimpleBlock c (SimplePBftExt c c'))
cfg BlockNo
slot SlotNo
bno TickedLedgerState (SimpleBlock c (SimplePBftExt c c'))
lst [Validated (GenTx (SimpleBlock c (SimplePBftExt c c')))]
txs IsLeader (BlockProtocol (SimpleBlock c (SimplePBftExt c c')))
proof ->
        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')))
-> SimpleBlock c (SimplePBftExt c c')
-> m (SimpleBlock c (SimplePBftExt c c'))
forall a b. (a -> b) -> a -> b
$ ForgeExt c (SimplePBftExt c c')
-> TopLevelConfig (SimpleBlock c (SimplePBftExt c c'))
-> BlockNo
-> SlotNo
-> TickedLedgerState (SimpleBlock c (SimplePBftExt c c'))
-> [GenTx (SimpleBlock c (SimplePBftExt c c'))]
-> IsLeader (BlockProtocol (SimpleBlock c (SimplePBftExt c c')))
-> SimpleBlock c (SimplePBftExt c c')
forall c ext.
SimpleCrypto c =>
ForgeExt c ext
-> TopLevelConfig (SimpleBlock c ext)
-> BlockNo
-> SlotNo
-> TickedLedgerState (SimpleBlock c ext)
-> [GenTx (SimpleBlock c ext)]
-> IsLeader (BlockProtocol (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
              TopLevelConfig (SimpleBlock c (SimplePBftExt c c'))
cfg
              BlockNo
slot
              SlotNo
bno
              TickedLedgerState (SimpleBlock c (SimplePBftExt c c'))
lst
              ((Validated (GenTx (SimpleBlock c (SimplePBftExt c c')))
 -> GenTx (SimpleBlock c (SimplePBftExt c c')))
-> [Validated (GenTx (SimpleBlock c (SimplePBftExt c c')))]
-> [GenTx (SimpleBlock c (SimplePBftExt c c'))]
forall a b. (a -> b) -> [a] -> [b]
map Validated (GenTx (SimpleBlock c (SimplePBftExt c c')))
-> GenTx (SimpleBlock c (SimplePBftExt c c'))
forall blk.
LedgerSupportsMempool blk =>
Validated (GenTx blk) -> GenTx blk
txForgetValidated [Validated (GenTx (SimpleBlock c (SimplePBftExt c c')))]
txs)
              IsLeader (BlockProtocol (SimpleBlock c (SimplePBftExt c c')))
proof
    }