{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Ouroboros.Consensus.Mock.Node.Praos
  ( MockPraosBlock
  , blockForgingPraos
  , protocolInfoPraos
  ) where

import Cardano.Crypto.KES
import Cardano.Crypto.VRF
import Data.Bifunctor (second)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Numeric.Natural (Natural)
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.Mock.Protocol.Praos
import Ouroboros.Consensus.Node.ProtocolInfo
import Ouroboros.Consensus.NodeId (CoreNodeId (..))
import Ouroboros.Consensus.Util.IOLike

type MockPraosBlock = SimplePraosBlock SimpleMockCrypto PraosMockCrypto

protocolInfoPraos ::
  NumCoreNodes ->
  CoreNodeId ->
  PraosParams ->
  HardFork.EraParams ->
  Natural ->
  PraosEvolvingStake ->
  ProtocolInfo MockPraosBlock
protocolInfoPraos :: NumCoreNodes
-> CoreNodeId
-> PraosParams
-> EraParams
-> Natural
-> PraosEvolvingStake
-> ProtocolInfo MockPraosBlock
protocolInfoPraos NumCoreNodes
numCoreNodes CoreNodeId
nid PraosParams
params EraParams
eraParams Natural
eta0 PraosEvolvingStake
evolvingStakeDist =
  ProtocolInfo
    { pInfoConfig :: TopLevelConfig MockPraosBlock
pInfoConfig =
        TopLevelConfig
          { topLevelConfigProtocol :: ConsensusConfig (BlockProtocol MockPraosBlock)
topLevelConfigProtocol =
              PraosConfig
                { praosParams :: PraosParams
praosParams = PraosParams
params
                , praosSignKeyVRF :: SignKeyVRF (PraosVRF PraosMockCrypto)
praosSignKeyVRF = CoreNodeId -> SignKeyVRF MockVRF
signKeyVRF CoreNodeId
nid
                , praosInitialEta :: Natural
praosInitialEta = Natural
eta0
                , praosInitialStake :: StakeDist
praosInitialStake = AddrDist -> StakeDist
genesisStakeDist AddrDist
addrDist
                , praosEvolvingStake :: PraosEvolvingStake
praosEvolvingStake = PraosEvolvingStake
evolvingStakeDist
                , praosVerKeys :: Map
  CoreNodeId
  (VerKeyKES (PraosKES PraosMockCrypto),
   VerKeyVRF (PraosVRF PraosMockCrypto))
praosVerKeys = Map CoreNodeId (VerKeyKES (MockKES 10000), VerKeyVRF MockVRF)
Map
  CoreNodeId
  (VerKeyKES (PraosKES PraosMockCrypto),
   VerKeyVRF (PraosVRF PraosMockCrypto))
forall (t :: Natural).
Map CoreNodeId (VerKeyKES (MockKES t), VerKeyVRF MockVRF)
verKeys
                }
          , topLevelConfigLedger :: LedgerConfig MockPraosBlock
topLevelConfigLedger = MockLedgerConfig
  SimpleMockCrypto (SimplePraosExt SimpleMockCrypto PraosMockCrypto)
-> EraParams
-> MockConfig
-> SimpleLedgerConfig
     SimpleMockCrypto (SimplePraosExt SimpleMockCrypto PraosMockCrypto)
forall c ext.
MockLedgerConfig c ext
-> EraParams -> MockConfig -> SimpleLedgerConfig c ext
SimpleLedgerConfig AddrDist
MockLedgerConfig
  SimpleMockCrypto (SimplePraosExt SimpleMockCrypto PraosMockCrypto)
addrDist EraParams
eraParams MockConfig
defaultMockConfig
          , topLevelConfigBlock :: BlockConfig MockPraosBlock
topLevelConfigBlock = BlockConfig MockPraosBlock
forall c ext. BlockConfig (SimpleBlock c ext)
SimpleBlockConfig
          , topLevelConfigCodec :: CodecConfig MockPraosBlock
topLevelConfigCodec = CodecConfig MockPraosBlock
forall c ext. CodecConfig (SimpleBlock c ext)
SimpleCodecConfig
          , topLevelConfigStorage :: StorageConfig MockPraosBlock
topLevelConfigStorage = SecurityParam -> StorageConfig MockPraosBlock
forall c ext. SecurityParam -> StorageConfig (SimpleBlock c ext)
SimpleStorageConfig (PraosParams -> SecurityParam
praosSecurityParam PraosParams
params)
          , topLevelConfigCheckpoints :: CheckpointsMap MockPraosBlock
topLevelConfigCheckpoints = CheckpointsMap MockPraosBlock
forall blk. CheckpointsMap blk
emptyCheckpointsMap
          }
    , pInfoInitLedger :: ExtLedgerState MockPraosBlock ValuesMK
pInfoInitLedger =
        ExtLedgerState
          { ledgerState :: LedgerState MockPraosBlock ValuesMK
ledgerState = AddrDist -> LedgerState MockPraosBlock ValuesMK
forall c ext. AddrDist -> LedgerState (SimpleBlock c ext) ValuesMK
genesisSimpleLedgerState AddrDist
addrDist
          , headerState :: HeaderState MockPraosBlock
headerState = ChainDepState (BlockProtocol MockPraosBlock)
-> HeaderState MockPraosBlock
forall blk. ChainDepState (BlockProtocol blk) -> HeaderState blk
genesisHeaderState ([BlockInfo PraosMockCrypto] -> PraosChainDepState PraosMockCrypto
forall c. [BlockInfo c] -> PraosChainDepState c
PraosChainDepState [])
          }
    }
 where
  signKeyVRF :: CoreNodeId -> SignKeyVRF MockVRF
  signKeyVRF :: CoreNodeId -> SignKeyVRF MockVRF
signKeyVRF (CoreNodeId Word64
n) = Word64 -> SignKeyVRF MockVRF
SignKeyMockVRF Word64
n

  verKeyVRF :: CoreNodeId -> VerKeyVRF MockVRF
  verKeyVRF :: CoreNodeId -> VerKeyVRF MockVRF
verKeyVRF (CoreNodeId Word64
n) = Word64 -> VerKeyVRF MockVRF
VerKeyMockVRF Word64
n

  verKeyKES :: CoreNodeId -> VerKeyKES (MockKES t)
  verKeyKES :: forall (t :: Natural). CoreNodeId -> VerKeyKES (MockKES t)
verKeyKES (CoreNodeId Word64
n) = Word64 -> VerKeyKES (MockKES t)
forall (t :: Natural). Word64 -> VerKeyKES (MockKES t)
VerKeyMockKES Word64
n

  addrDist :: AddrDist
  addrDist :: AddrDist
addrDist = NumCoreNodes -> AddrDist
mkAddrDist NumCoreNodes
numCoreNodes

  verKeys :: Map CoreNodeId (VerKeyKES (MockKES t), VerKeyVRF MockVRF)
  verKeys :: forall (t :: Natural).
Map CoreNodeId (VerKeyKES (MockKES t), VerKeyVRF MockVRF)
verKeys =
    [(CoreNodeId, (VerKeyKES (MockKES t), VerKeyVRF MockVRF))]
-> Map CoreNodeId (VerKeyKES (MockKES t), VerKeyVRF MockVRF)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
      [ (CoreNodeId
nid', (VerKeyKES (MockKES t)
forall {t :: Natural}. VerKeyKES (MockKES t)
kesKey, VerKeyVRF MockVRF
vrfKey))
      | CoreNodeId
nid' <- NumCoreNodes -> [CoreNodeId]
enumCoreNodes NumCoreNodes
numCoreNodes
      , let !kesKey :: VerKeyKES (MockKES t)
kesKey = CoreNodeId -> VerKeyKES (MockKES t)
forall (t :: Natural). CoreNodeId -> VerKeyKES (MockKES t)
verKeyKES CoreNodeId
nid'
            !vrfKey :: VerKeyVRF MockVRF
vrfKey = CoreNodeId -> VerKeyVRF MockVRF
verKeyVRF CoreNodeId
nid'
      ]

blockForgingPraos ::
  IOLike m =>
  NumCoreNodes ->
  CoreNodeId ->
  m [BlockForging m MockPraosBlock]
blockForgingPraos :: forall (m :: * -> *).
IOLike m =>
NumCoreNodes -> CoreNodeId -> m [BlockForging m MockPraosBlock]
blockForgingPraos NumCoreNodes
numCoreNodes CoreNodeId
nid = [m (BlockForging m MockPraosBlock)]
-> m [BlockForging m MockPraosBlock]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [CoreNodeId
-> HotKey PraosMockCrypto -> m (BlockForging m MockPraosBlock)
forall (m :: * -> *).
IOLike m =>
CoreNodeId
-> HotKey PraosMockCrypto -> m (BlockForging m MockPraosBlock)
praosBlockForging CoreNodeId
nid HotKey PraosMockCrypto
initHotKey]
 where
  verKeyVRF :: CoreNodeId -> VerKeyVRF MockVRF
  verKeyVRF :: CoreNodeId -> VerKeyVRF MockVRF
verKeyVRF (CoreNodeId Word64
n) = Word64 -> VerKeyVRF MockVRF
VerKeyMockVRF Word64
n

  verKeyKES :: CoreNodeId -> VerKeyKES (MockKES t)
  verKeyKES :: forall (t :: Natural). CoreNodeId -> VerKeyKES (MockKES t)
verKeyKES (CoreNodeId Word64
n) = Word64 -> VerKeyKES (MockKES t)
forall (t :: Natural). Word64 -> VerKeyKES (MockKES t)
VerKeyMockKES Word64
n

  verKeys :: Map CoreNodeId (VerKeyKES (MockKES t), VerKeyVRF MockVRF)
  verKeys :: forall (t :: Natural).
Map CoreNodeId (VerKeyKES (MockKES t), VerKeyVRF MockVRF)
verKeys =
    [(CoreNodeId, (VerKeyKES (MockKES t), VerKeyVRF MockVRF))]
-> Map CoreNodeId (VerKeyKES (MockKES t), VerKeyVRF MockVRF)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
      [ (CoreNodeId
nid', (VerKeyKES (MockKES t)
forall {t :: Natural}. VerKeyKES (MockKES t)
kesKey, VerKeyVRF MockVRF
vrfKey))
      | CoreNodeId
nid' <- NumCoreNodes -> [CoreNodeId]
enumCoreNodes NumCoreNodes
numCoreNodes
      , let !kesKey :: VerKeyKES (MockKES t)
kesKey = CoreNodeId -> VerKeyKES (MockKES t)
forall (t :: Natural). CoreNodeId -> VerKeyKES (MockKES t)
verKeyKES CoreNodeId
nid'
            !vrfKey :: VerKeyVRF MockVRF
vrfKey = CoreNodeId -> VerKeyVRF MockVRF
verKeyVRF CoreNodeId
nid'
      ]

  initHotKey :: HotKey PraosMockCrypto
  initHotKey :: HotKey PraosMockCrypto
initHotKey =
    Period
-> UnsoundPureSignKeyKES (PraosKES PraosMockCrypto)
-> HotKey PraosMockCrypto
forall c. Period -> UnsoundPureSignKeyKES (PraosKES c) -> HotKey c
HotKey
      Period
0
      ( VerKeyKES (MockKES 10000)
-> Period -> UnsoundPureSignKeyKES (MockKES 10000)
forall (t :: Natural).
VerKeyKES (MockKES t)
-> Period -> UnsoundPureSignKeyKES (MockKES t)
UnsoundPureSignKeyMockKES
          -- key ID
          ((VerKeyKES (MockKES 10000), VerKeyVRF MockVRF)
-> VerKeyKES (MockKES 10000)
forall a b. (a, b) -> a
fst ((VerKeyKES (MockKES 10000), VerKeyVRF MockVRF)
 -> VerKeyKES (MockKES 10000))
-> (VerKeyKES (MockKES 10000), VerKeyVRF MockVRF)
-> VerKeyKES (MockKES 10000)
forall a b. (a -> b) -> a -> b
$ Map CoreNodeId (VerKeyKES (MockKES 10000), VerKeyVRF MockVRF)
forall (t :: Natural).
Map CoreNodeId (VerKeyKES (MockKES t), VerKeyVRF MockVRF)
verKeys Map CoreNodeId (VerKeyKES (MockKES 10000), VerKeyVRF MockVRF)
-> CoreNodeId -> (VerKeyKES (MockKES 10000), VerKeyVRF MockVRF)
forall k a. Ord k => Map k a -> k -> a
Map.! CoreNodeId
nid)
          -- KES initial slot
          Period
0
      )

praosBlockForging ::
  IOLike m =>
  CoreNodeId ->
  HotKey PraosMockCrypto ->
  m (BlockForging m MockPraosBlock)
praosBlockForging :: forall (m :: * -> *).
IOLike m =>
CoreNodeId
-> HotKey PraosMockCrypto -> m (BlockForging m MockPraosBlock)
praosBlockForging CoreNodeId
cid HotKey PraosMockCrypto
initHotKey = do
  varHotKey <- HotKey PraosMockCrypto -> m (StrictMVar m (HotKey PraosMockCrypto))
forall (m :: * -> *) a.
(HasCallStack, MonadMVar m, NoThunks a) =>
a -> m (StrictMVar m a)
newMVar HotKey PraosMockCrypto
initHotKey
  return $
    BlockForging
      { forgeLabel = "praosBlockForging"
      , canBeLeader = cid
      , updateForgeState = \TopLevelConfig MockPraosBlock
_ SlotNo
sno Ticked (ChainDepState (BlockProtocol MockPraosBlock))
_ ->
          StrictMVar m (HotKey PraosMockCrypto)
-> (HotKey PraosMockCrypto
    -> m (HotKey PraosMockCrypto, ForgeStateUpdateInfo MockPraosBlock))
-> m (ForgeStateUpdateInfo MockPraosBlock)
forall (m :: * -> *) a b.
(HasCallStack, MonadMVar m) =>
StrictMVar m a -> (a -> m (a, b)) -> m b
modifyMVar StrictMVar m (HotKey PraosMockCrypto)
varHotKey ((HotKey PraosMockCrypto
  -> m (HotKey PraosMockCrypto, ForgeStateUpdateInfo MockPraosBlock))
 -> m (ForgeStateUpdateInfo MockPraosBlock))
-> (HotKey PraosMockCrypto
    -> m (HotKey PraosMockCrypto, ForgeStateUpdateInfo MockPraosBlock))
-> m (ForgeStateUpdateInfo MockPraosBlock)
forall a b. (a -> b) -> a -> b
$
            (HotKey PraosMockCrypto, ForgeStateUpdateInfo MockPraosBlock)
-> m (HotKey PraosMockCrypto, ForgeStateUpdateInfo MockPraosBlock)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
              ((HotKey PraosMockCrypto, ForgeStateUpdateInfo MockPraosBlock)
 -> m (HotKey PraosMockCrypto, ForgeStateUpdateInfo MockPraosBlock))
-> (HotKey PraosMockCrypto
    -> (HotKey PraosMockCrypto, ForgeStateUpdateInfo MockPraosBlock))
-> HotKey PraosMockCrypto
-> m (HotKey PraosMockCrypto, ForgeStateUpdateInfo MockPraosBlock)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UpdateInfo (HotKey PraosMockCrypto) HotKeyEvolutionError
 -> ForgeStateUpdateInfo MockPraosBlock)
-> (HotKey PraosMockCrypto,
    UpdateInfo (HotKey PraosMockCrypto) HotKeyEvolutionError)
-> (HotKey PraosMockCrypto, ForgeStateUpdateInfo MockPraosBlock)
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second UpdateInfo
  (ForgeStateInfo MockPraosBlock)
  (ForgeStateUpdateError MockPraosBlock)
-> ForgeStateUpdateInfo MockPraosBlock
UpdateInfo (HotKey PraosMockCrypto) HotKeyEvolutionError
-> ForgeStateUpdateInfo MockPraosBlock
forall blk.
UpdateInfo (ForgeStateInfo blk) (ForgeStateUpdateError blk)
-> ForgeStateUpdateInfo blk
forgeStateUpdateInfoFromUpdateInfo
              ((HotKey PraosMockCrypto,
  UpdateInfo (HotKey PraosMockCrypto) HotKeyEvolutionError)
 -> (HotKey PraosMockCrypto, ForgeStateUpdateInfo MockPraosBlock))
-> (HotKey PraosMockCrypto
    -> (HotKey PraosMockCrypto,
        UpdateInfo (HotKey PraosMockCrypto) HotKeyEvolutionError))
-> HotKey PraosMockCrypto
-> (HotKey PraosMockCrypto, ForgeStateUpdateInfo MockPraosBlock)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SlotNo
-> HotKey PraosMockCrypto
-> (HotKey PraosMockCrypto,
    UpdateInfo (HotKey PraosMockCrypto) HotKeyEvolutionError)
forall c.
PraosCrypto c =>
SlotNo
-> HotKey c
-> (HotKey c, UpdateInfo (HotKey c) HotKeyEvolutionError)
evolveKey SlotNo
sno
      , checkCanForge = \TopLevelConfig MockPraosBlock
_ SlotNo
_ Ticked (ChainDepState (BlockProtocol MockPraosBlock))
_ IsLeader (BlockProtocol MockPraosBlock)
_ ForgeStateInfo MockPraosBlock
_ -> () -> Either Void ()
forall a. a -> Either Void a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      , forgeBlock = \TopLevelConfig MockPraosBlock
cfg BlockNo
bno SlotNo
sno TickedLedgerState MockPraosBlock EmptyMK
tickedLedgerSt [Validated (GenTx MockPraosBlock)]
txs IsLeader (BlockProtocol MockPraosBlock)
isLeader -> do
          hotKey <- StrictMVar m (HotKey PraosMockCrypto) -> m (HotKey PraosMockCrypto)
forall (m :: * -> *) a. MonadMVar m => StrictMVar m a -> m a
readMVar StrictMVar m (HotKey PraosMockCrypto)
varHotKey
          return $
            forgeSimple
              (forgePraosExt hotKey)
              cfg
              bno
              sno
              tickedLedgerSt
              (map txForgetValidated txs)
              isLeader
      }