{-# 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
      }