{-# LANGUAGE DeriveAnyClass      #-}
{-# LANGUAGE DeriveGeneric       #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE NamedFieldPuns      #-}
{-# LANGUAGE ScopedTypeVariables #-}

-- | Node kernel which does chain selection and block production.
--
module Test.Ouroboros.Network.Testnet.Node.Kernel
  ( -- * Common types
    NtNAddr
  , NtNAddr_ (..)
  , encodeNtNAddr
  , decodeNtNAddr
  , ntnAddrToRelayAccessPoint
  , NtNVersion
  , NtNVersionData (..)
  , NtCAddr
  , NtCVersion
  , NtCVersionData
    -- * Node kernel
  , BlockGeneratorArgs (..)
  , relayBlockGenerationArgs
  , randomBlockGenerationArgs
  , NodeKernel (..)
  , newNodeKernel
  , registerClientChains
  , unregisterClientChains
  , withNodeKernelThread
  , NodeKernelError (..)
  ) where

import GHC.Generics (Generic)

import Control.Applicative (Alternative)
import Control.Concurrent.Class.MonadSTM qualified as LazySTM
import Control.Concurrent.Class.MonadSTM.Strict
import Control.DeepSeq (NFData (..))
import Control.Monad (replicateM, when)
import Control.Monad.Class.MonadAsync
import Control.Monad.Class.MonadThrow
import Control.Monad.Class.MonadTime.SI
import Control.Monad.Class.MonadTimer.SI
import Data.ByteString.Char8 qualified as BSC
import Data.Hashable (Hashable)
import Data.IP (IP (..), fromIPv4w, fromIPv6w, toIPv4, toIPv4w, toIPv6, toIPv6w)
import Data.IP qualified as IP
import Data.Map.Strict (Map)
import Data.Map.Strict qualified as Map
import Data.Typeable (Typeable)
import Data.Void (Void)
import Numeric.Natural (Natural)

import System.Random (RandomGen, StdGen, randomR, split)

import Data.Monoid.Synchronisation

import Network.Socket (PortNumber)

import Ouroboros.Network.AnchoredFragment (Anchor (..))
import Ouroboros.Network.Block (HasFullHeader, SlotNo)
import Ouroboros.Network.Block qualified as Block
import Ouroboros.Network.BlockFetch
import Ouroboros.Network.NodeToNode.Version (DiffusionMode (..))
import Ouroboros.Network.Protocol.Handshake.Unversioned
import Ouroboros.Network.Snocket (TestAddress (..))

import Ouroboros.Network.Mock.Chain qualified as Chain
import Ouroboros.Network.Mock.ConcreteBlock (Block)
import Ouroboros.Network.Mock.ConcreteBlock qualified as ConcreteBlock
import Ouroboros.Network.Mock.ProducerState

import Simulation.Network.Snocket (AddressType (..), GlobalAddressScheme (..))

import Test.Ouroboros.Network.Orphans ()

import Codec.CBOR.Decoding qualified as CBOR
import Codec.CBOR.Encoding qualified as CBOR
import Ouroboros.Network.Mock.Chain (Chain (..))
import Ouroboros.Network.NodeToNode ()
import Ouroboros.Network.PeerSelection.Governor (PublicPeerSelectionState,
           makePublicPeerSelectionStateVar)
import Ouroboros.Network.PeerSelection.PeerSharing (PeerSharing)
import Ouroboros.Network.PeerSelection.RelayAccessPoint (RelayAccessPoint (..))
import Ouroboros.Network.PeerSharing (PeerSharingAPI, PeerSharingRegistry (..),
           newPeerSharingAPI, newPeerSharingRegistry,
           ps_POLICY_PEER_SHARE_MAX_PEERS, ps_POLICY_PEER_SHARE_STICKY_TIME)
import Test.Ouroboros.Network.Testnet.Node.ChainDB (ChainDB (..))
import Test.Ouroboros.Network.Testnet.Node.ChainDB qualified as ChainDB
import Test.QuickCheck (Arbitrary (..), choose, chooseInt, frequency, oneof)


-- | Node-to-node address type.
--
data NtNAddr_
  = EphemeralIPv4Addr Natural
  | EphemeralIPv6Addr Natural
  | IPAddr IP.IP PortNumber
  deriving (NtNAddr_ -> NtNAddr_ -> Bool
(NtNAddr_ -> NtNAddr_ -> Bool)
-> (NtNAddr_ -> NtNAddr_ -> Bool) -> Eq NtNAddr_
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: NtNAddr_ -> NtNAddr_ -> Bool
== :: NtNAddr_ -> NtNAddr_ -> Bool
$c/= :: NtNAddr_ -> NtNAddr_ -> Bool
/= :: NtNAddr_ -> NtNAddr_ -> Bool
Eq, Eq NtNAddr_
Eq NtNAddr_ =>
(NtNAddr_ -> NtNAddr_ -> Ordering)
-> (NtNAddr_ -> NtNAddr_ -> Bool)
-> (NtNAddr_ -> NtNAddr_ -> Bool)
-> (NtNAddr_ -> NtNAddr_ -> Bool)
-> (NtNAddr_ -> NtNAddr_ -> Bool)
-> (NtNAddr_ -> NtNAddr_ -> NtNAddr_)
-> (NtNAddr_ -> NtNAddr_ -> NtNAddr_)
-> Ord NtNAddr_
NtNAddr_ -> NtNAddr_ -> Bool
NtNAddr_ -> NtNAddr_ -> Ordering
NtNAddr_ -> NtNAddr_ -> NtNAddr_
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: NtNAddr_ -> NtNAddr_ -> Ordering
compare :: NtNAddr_ -> NtNAddr_ -> Ordering
$c< :: NtNAddr_ -> NtNAddr_ -> Bool
< :: NtNAddr_ -> NtNAddr_ -> Bool
$c<= :: NtNAddr_ -> NtNAddr_ -> Bool
<= :: NtNAddr_ -> NtNAddr_ -> Bool
$c> :: NtNAddr_ -> NtNAddr_ -> Bool
> :: NtNAddr_ -> NtNAddr_ -> Bool
$c>= :: NtNAddr_ -> NtNAddr_ -> Bool
>= :: NtNAddr_ -> NtNAddr_ -> Bool
$cmax :: NtNAddr_ -> NtNAddr_ -> NtNAddr_
max :: NtNAddr_ -> NtNAddr_ -> NtNAddr_
$cmin :: NtNAddr_ -> NtNAddr_ -> NtNAddr_
min :: NtNAddr_ -> NtNAddr_ -> NtNAddr_
Ord, (forall x. NtNAddr_ -> Rep NtNAddr_ x)
-> (forall x. Rep NtNAddr_ x -> NtNAddr_) -> Generic NtNAddr_
forall x. Rep NtNAddr_ x -> NtNAddr_
forall x. NtNAddr_ -> Rep NtNAddr_ x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. NtNAddr_ -> Rep NtNAddr_ x
from :: forall x. NtNAddr_ -> Rep NtNAddr_ x
$cto :: forall x. Rep NtNAddr_ x -> NtNAddr_
to :: forall x. Rep NtNAddr_ x -> NtNAddr_
Generic)

-- we need to work around the lack of the `NFData IP` instance
instance NFData NtNAddr_ where
    rnf :: NtNAddr_ -> ()
rnf (EphemeralIPv4Addr Natural
p)      = Natural
p Natural -> () -> ()
forall a b. a -> b -> b
`seq` ()
    rnf (EphemeralIPv6Addr Natural
p)      = Natural
p Natural -> () -> ()
forall a b. a -> b -> b
`seq` ()
    rnf (IPAddr (IP.IPv4 IPv4
ip) PortNumber
port) = IPv4
ip IPv4 -> () -> ()
forall a b. a -> b -> b
`seq` PortNumber
port PortNumber -> () -> ()
forall a b. a -> b -> b
`seq` ()
    rnf (IPAddr (IP.IPv6 IPv6
ip) PortNumber
port) = (Word32, Word32, Word32, Word32) -> ()
forall a. NFData a => a -> ()
rnf (IPv6 -> (Word32, Word32, Word32, Word32)
IP.fromIPv6w IPv6
ip) () -> () -> ()
forall a b. a -> b -> b
`seq` PortNumber
port PortNumber -> () -> ()
forall a b. a -> b -> b
`seq` ()

instance Arbitrary NtNAddr_ where
  arbitrary :: Gen NtNAddr_
arbitrary = do
    -- TODO: Move this IP generator to ouroboros-network-testing
    a <- [Gen IP] -> Gen IP
forall a. [Gen a] -> Gen a
oneof [ IPv6 -> IP
IPv6 (IPv6 -> IP) -> ([Int] -> IPv6) -> [Int] -> IP
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Int] -> IPv6
toIPv6 ([Int] -> IP) -> Gen [Int] -> Gen IP
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Gen Int -> Gen [Int]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
8 ((Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
0,Int
0xffff))
               , IPv4 -> IP
IPv4 (IPv4 -> IP) -> ([Int] -> IPv4) -> [Int] -> IP
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Int] -> IPv4
toIPv4 ([Int] -> IP) -> Gen [Int] -> Gen IP
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Gen Int -> Gen [Int]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
4 ((Int, Int) -> Gen Int
forall a. Random a => (a, a) -> Gen a
choose (Int
0,Int
255))
               ]
    frequency
      [ (1 , EphemeralIPv4Addr <$> (fromInteger <$> arbitrary))
      , (1 , EphemeralIPv6Addr <$> (fromInteger <$> arbitrary))
      , (3 , IPAddr a          <$> (read . show <$> chooseInt (0, 9999)))
      ]

instance Show NtNAddr_ where
    show :: NtNAddr_ -> String
show (EphemeralIPv4Addr Natural
n) = String
"EphemeralIPv4Addr " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Natural -> String
forall a. Show a => a -> String
show Natural
n
    show (EphemeralIPv6Addr Natural
n) = String
"EphemeralIPv6Addr " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Natural -> String
forall a. Show a => a -> String
show Natural
n
    show (IPAddr IP
ip PortNumber
port)      = String
"IPAddr (read \"" String -> ShowS
forall a. [a] -> [a] -> [a]
++ IP -> String
forall a. Show a => a -> String
show IP
ip String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\") " String -> ShowS
forall a. [a] -> [a] -> [a]
++ PortNumber -> String
forall a. Show a => a -> String
show PortNumber
port

instance GlobalAddressScheme NtNAddr_ where
    getAddressType :: TestAddress NtNAddr_ -> AddressType
getAddressType (TestAddress NtNAddr_
addr) =
      case NtNAddr_
addr of
        EphemeralIPv4Addr Natural
_   -> AddressType
IPv4Address
        EphemeralIPv6Addr Natural
_   -> AddressType
IPv6Address
        IPAddr (IP.IPv4 {}) PortNumber
_ -> AddressType
IPv4Address
        IPAddr (IP.IPv6 {}) PortNumber
_ -> AddressType
IPv6Address
    ephemeralAddress :: AddressType -> Natural -> TestAddress NtNAddr_
ephemeralAddress AddressType
IPv4Address = NtNAddr_ -> TestAddress NtNAddr_
forall addr. addr -> TestAddress addr
TestAddress (NtNAddr_ -> TestAddress NtNAddr_)
-> (Natural -> NtNAddr_) -> Natural -> TestAddress NtNAddr_
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Natural -> NtNAddr_
EphemeralIPv4Addr
    ephemeralAddress AddressType
IPv6Address = NtNAddr_ -> TestAddress NtNAddr_
forall addr. addr -> TestAddress addr
TestAddress (NtNAddr_ -> TestAddress NtNAddr_)
-> (Natural -> NtNAddr_) -> Natural -> TestAddress NtNAddr_
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Natural -> NtNAddr_
EphemeralIPv6Addr

instance Hashable NtNAddr_

type NtNAddr        = TestAddress NtNAddr_
type NtNVersion     = UnversionedProtocol
data NtNVersionData = NtNVersionData
  { NtNVersionData -> DiffusionMode
ntnDiffusionMode :: DiffusionMode
  , NtNVersionData -> PeerSharing
ntnPeerSharing   :: PeerSharing
  }
  deriving Int -> NtNVersionData -> ShowS
[NtNVersionData] -> ShowS
NtNVersionData -> String
(Int -> NtNVersionData -> ShowS)
-> (NtNVersionData -> String)
-> ([NtNVersionData] -> ShowS)
-> Show NtNVersionData
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> NtNVersionData -> ShowS
showsPrec :: Int -> NtNVersionData -> ShowS
$cshow :: NtNVersionData -> String
show :: NtNVersionData -> String
$cshowList :: [NtNVersionData] -> ShowS
showList :: [NtNVersionData] -> ShowS
Show
type NtCAddr        = TestAddress Int
type NtCVersion     = UnversionedProtocol
type NtCVersionData = UnversionedProtocolData

ntnAddrToRelayAccessPoint :: NtNAddr -> Maybe RelayAccessPoint
ntnAddrToRelayAccessPoint :: TestAddress NtNAddr_ -> Maybe RelayAccessPoint
ntnAddrToRelayAccessPoint (TestAddress (IPAddr IP
ip PortNumber
port)) =
    RelayAccessPoint -> Maybe RelayAccessPoint
forall a. a -> Maybe a
Just (IP -> PortNumber -> RelayAccessPoint
RelayAccessAddress IP
ip PortNumber
port)
ntnAddrToRelayAccessPoint TestAddress NtNAddr_
_ = Maybe RelayAccessPoint
forall a. Maybe a
Nothing

encodeNtNAddr :: NtNAddr -> CBOR.Encoding
encodeNtNAddr :: TestAddress NtNAddr_ -> Encoding
encodeNtNAddr (TestAddress (EphemeralIPv4Addr Natural
nat)) = Word -> Encoding
CBOR.encodeListLen Word
2
                                                   Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word -> Encoding
CBOR.encodeWord Word
0
                                                   Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word -> Encoding
CBOR.encodeWord (Natural -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
nat)
encodeNtNAddr (TestAddress (EphemeralIPv6Addr Natural
nat)) = Word -> Encoding
CBOR.encodeListLen Word
2
                                                   Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word -> Encoding
CBOR.encodeWord Word
1
                                                   Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word -> Encoding
CBOR.encodeWord (Natural -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
nat)
encodeNtNAddr (TestAddress (IPAddr IP
ip PortNumber
pn)) = Word -> Encoding
CBOR.encodeListLen Word
3
                                          Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word -> Encoding
CBOR.encodeWord Word
2
                                          Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> IP -> Encoding
encodeIP IP
ip
                                          Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> PortNumber -> Encoding
encodePortNumber PortNumber
pn

decodeNtNAddr :: CBOR.Decoder s NtNAddr
decodeNtNAddr :: forall s. Decoder s (TestAddress NtNAddr_)
decodeNtNAddr = do
  _ <- Decoder s Int
forall s. Decoder s Int
CBOR.decodeListLen
  tok <- CBOR.decodeWord
  case tok of
    Word
0 -> (NtNAddr_ -> TestAddress NtNAddr_
forall addr. addr -> TestAddress addr
TestAddress (NtNAddr_ -> TestAddress NtNAddr_)
-> (Word -> NtNAddr_) -> Word -> TestAddress NtNAddr_
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Natural -> NtNAddr_
EphemeralIPv4Addr (Natural -> NtNAddr_) -> (Word -> Natural) -> Word -> NtNAddr_
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral) (Word -> TestAddress NtNAddr_)
-> Decoder s Word -> Decoder s (TestAddress NtNAddr_)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s Word
forall s. Decoder s Word
CBOR.decodeWord
    Word
1 -> (NtNAddr_ -> TestAddress NtNAddr_
forall addr. addr -> TestAddress addr
TestAddress (NtNAddr_ -> TestAddress NtNAddr_)
-> (Word -> NtNAddr_) -> Word -> TestAddress NtNAddr_
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Natural -> NtNAddr_
EphemeralIPv6Addr (Natural -> NtNAddr_) -> (Word -> Natural) -> Word -> NtNAddr_
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral) (Word -> TestAddress NtNAddr_)
-> Decoder s Word -> Decoder s (TestAddress NtNAddr_)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s Word
forall s. Decoder s Word
CBOR.decodeWord
    Word
2 -> NtNAddr_ -> TestAddress NtNAddr_
forall addr. addr -> TestAddress addr
TestAddress (NtNAddr_ -> TestAddress NtNAddr_)
-> Decoder s NtNAddr_ -> Decoder s (TestAddress NtNAddr_)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (IP -> PortNumber -> NtNAddr_
IPAddr (IP -> PortNumber -> NtNAddr_)
-> Decoder s IP -> Decoder s (PortNumber -> NtNAddr_)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s IP
forall s. Decoder s IP
decodeIP Decoder s (PortNumber -> NtNAddr_)
-> Decoder s PortNumber -> Decoder s NtNAddr_
forall a b. Decoder s (a -> b) -> Decoder s a -> Decoder s b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Decoder s PortNumber
forall s. Decoder s PortNumber
decodePortNumber)
    Word
_ -> String -> Decoder s (TestAddress NtNAddr_)
forall a. String -> Decoder s a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"decodeNtNAddr: unknown tok:" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Word -> String
forall a. Show a => a -> String
show Word
tok)

encodeIP :: IP -> CBOR.Encoding
encodeIP :: IP -> Encoding
encodeIP (IPv4 IPv4
ip) = Word -> Encoding
CBOR.encodeListLen Word
2
                  Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word -> Encoding
CBOR.encodeWord Word
0
                  Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word32 -> Encoding
CBOR.encodeWord32 (IPv4 -> Word32
fromIPv4w IPv4
ip)
encodeIP (IPv6 IPv6
ip) = case IPv6 -> (Word32, Word32, Word32, Word32)
fromIPv6w IPv6
ip of
  (Word32
w1, Word32
w2, Word32
w3, Word32
w4) -> Word -> Encoding
CBOR.encodeListLen Word
5
                   Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word -> Encoding
CBOR.encodeWord Word
1
                   Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word32 -> Encoding
CBOR.encodeWord32 Word32
w1
                   Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word32 -> Encoding
CBOR.encodeWord32 Word32
w2
                   Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word32 -> Encoding
CBOR.encodeWord32 Word32
w3
                   Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word32 -> Encoding
CBOR.encodeWord32 Word32
w4

decodeIP :: CBOR.Decoder s IP
decodeIP :: forall s. Decoder s IP
decodeIP = do
  _ <- Decoder s Int
forall s. Decoder s Int
CBOR.decodeListLen
  tok <- CBOR.decodeWord
  case tok of
    Word
0 -> (IPv4 -> IP
IPv4 (IPv4 -> IP) -> (Word32 -> IPv4) -> Word32 -> IP
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> IPv4
toIPv4w) (Word32 -> IP) -> Decoder s Word32 -> Decoder s IP
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s Word32
forall s. Decoder s Word32
CBOR.decodeWord32
    Word
1 -> do
      w1 <- Decoder s Word32
forall s. Decoder s Word32
CBOR.decodeWord32
      w2 <- CBOR.decodeWord32
      w3 <- CBOR.decodeWord32
      w4 <- CBOR.decodeWord32
      return (IPv6 (toIPv6w (w1, w2, w3, w4)))

    Word
_ -> String -> Decoder s IP
forall a. String -> Decoder s a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"decodeIP: unknown tok:" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Word -> String
forall a. Show a => a -> String
show Word
tok)

encodePortNumber :: PortNumber -> CBOR.Encoding
encodePortNumber :: PortNumber -> Encoding
encodePortNumber = Word16 -> Encoding
CBOR.encodeWord16 (Word16 -> Encoding)
-> (PortNumber -> Word16) -> PortNumber -> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PortNumber -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral

decodePortNumber :: CBOR.Decoder s PortNumber
decodePortNumber :: forall s. Decoder s PortNumber
decodePortNumber = Word16 -> PortNumber
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word16 -> PortNumber) -> Decoder s Word16 -> Decoder s PortNumber
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s Word16
forall s. Decoder s Word16
CBOR.decodeWord16

data BlockGeneratorArgs block s = BlockGeneratorArgs
  { forall block s. BlockGeneratorArgs block s -> DiffTime
bgaSlotDuration   :: DiffTime
    -- ^ slot duration

  , forall block s.
BlockGeneratorArgs block s
-> s -> Anchor block -> SlotNo -> (Maybe block, s)
bgaBlockGenerator :: s -> Anchor block -> SlotNo -> (Maybe block, s)
    -- ^ block generator

  , forall block s. BlockGeneratorArgs block s -> s
bgaSeed           :: s
  }

-- | Do not generate blocks.
--
relayBlockGenerationArgs :: DiffTime -> seed -> BlockGeneratorArgs block seed
relayBlockGenerationArgs :: forall seed block.
DiffTime -> seed -> BlockGeneratorArgs block seed
relayBlockGenerationArgs DiffTime
bgaSlotDuration seed
bgaSeed =
  BlockGeneratorArgs
    { DiffTime
bgaSlotDuration :: DiffTime
bgaSlotDuration :: DiffTime
bgaSlotDuration
    , bgaBlockGenerator :: seed -> Anchor block -> SlotNo -> (Maybe block, seed)
bgaBlockGenerator = \seed
seed Anchor block
_ SlotNo
_ -> (Maybe block
forall a. Maybe a
Nothing, seed
seed)
    , seed
bgaSeed :: seed
bgaSeed :: seed
bgaSeed
    }


-- | Generate a block according to given probability.
--
randomBlockGenerationArgs :: DiffTime
                          -> StdGen
                          -> Int -- between 0 and 100
                          -> BlockGeneratorArgs Block StdGen
randomBlockGenerationArgs :: DiffTime -> StdGen -> Int -> BlockGeneratorArgs Block StdGen
randomBlockGenerationArgs DiffTime
bgaSlotDuration StdGen
bgaSeed Int
quota =
  BlockGeneratorArgs
    { DiffTime
bgaSlotDuration :: DiffTime
bgaSlotDuration :: DiffTime
bgaSlotDuration
    , bgaBlockGenerator :: StdGen -> Anchor Block -> SlotNo -> (Maybe Block, StdGen)
bgaBlockGenerator = \StdGen
seed Anchor Block
anchor SlotNo
slot ->
                            let block :: Block
block = Anchor Block -> Block -> Block
forall block.
(HeaderHash block ~ HeaderHash BlockHeader) =>
Anchor block -> Block -> Block
ConcreteBlock.fixupBlock Anchor Block
anchor
                                      (Block -> Block) -> (BlockBody -> Block) -> BlockBody -> Block
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SlotNo -> BlockBody -> Block
ConcreteBlock.mkPartialBlock SlotNo
slot
                                      -- TODO:
                                      --  * use ByteString, not String;
                                      --  * cycle through some bodies
                                      --
                                      (BlockBody -> Block) -> BlockBody -> Block
forall a b. (a -> b) -> a -> b
$ ByteString -> BlockBody
ConcreteBlock.BlockBody (String -> ByteString
BSC.pack String
"")
                            in case (Int, Int) -> StdGen -> (Int, StdGen)
forall g. RandomGen g => (Int, Int) -> g -> (Int, g)
forall a g. (Random a, RandomGen g) => (a, a) -> g -> (a, g)
randomR (Int
0, Int
100) StdGen
seed of
                                (Int
r, StdGen
seed') | Int
r Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
quota ->
                                             (Block -> Maybe Block
forall a. a -> Maybe a
Just Block
block, StdGen
seed')
                                           | Bool
otherwise  ->
                                             (Maybe Block
forall a. Maybe a
Nothing, StdGen
seed')
    , StdGen
bgaSeed :: StdGen
bgaSeed :: StdGen
bgaSeed
    }

data NodeKernel header block s m = NodeKernel {
      -- | upstream chains
      forall header block s (m :: * -> *).
NodeKernel header block s m
-> StrictTVar
     m (Map (TestAddress NtNAddr_) (StrictTVar m (Chain header)))
nkClientChains
        :: StrictTVar m (Map NtNAddr (StrictTVar m (Chain header))),

      -- | chain producer state
      forall header block s (m :: * -> *).
NodeKernel header block s m
-> StrictTVar m (ChainProducerState block)
nkChainProducerState
        :: StrictTVar m (ChainProducerState block),

      forall header block s (m :: * -> *).
NodeKernel header block s m
-> FetchClientRegistry (TestAddress NtNAddr_) header block m
nkFetchClientRegistry :: FetchClientRegistry NtNAddr header block m,

      forall header block s (m :: * -> *).
NodeKernel header block s m
-> PeerSharingRegistry (TestAddress NtNAddr_) m
nkPeerSharingRegistry :: PeerSharingRegistry NtNAddr m,

      forall header block s (m :: * -> *).
NodeKernel header block s m -> ChainDB block m
nkChainDB :: ChainDB block m,

      forall header block s (m :: * -> *).
NodeKernel header block s m
-> PeerSharingAPI (TestAddress NtNAddr_) s m
nkPeerSharingAPI :: PeerSharingAPI NtNAddr s m,

      forall header block s (m :: * -> *).
NodeKernel header block s m
-> StrictTVar m (PublicPeerSelectionState (TestAddress NtNAddr_))
nkPublicPeerSelectionVar :: StrictTVar m (PublicPeerSelectionState NtNAddr)
    }

newNodeKernel :: MonadSTM m
              => s -> m (NodeKernel header block s m)
newNodeKernel :: forall (m :: * -> *) s header block.
MonadSTM m =>
s -> m (NodeKernel header block s m)
newNodeKernel s
rng = do
    publicStateVar <- m (StrictTVar m (PublicPeerSelectionState (TestAddress NtNAddr_)))
forall (m :: * -> *) peeraddr.
(MonadSTM m, Ord peeraddr) =>
m (StrictTVar m (PublicPeerSelectionState peeraddr))
makePublicPeerSelectionStateVar
    NodeKernel
      <$> newTVarIO Map.empty
      <*> newTVarIO (ChainProducerState Chain.Genesis Map.empty 0)
      <*> newFetchClientRegistry
      <*> newPeerSharingRegistry
      <*> ChainDB.newChainDB
      <*> newPeerSharingAPI publicStateVar rng
                            ps_POLICY_PEER_SHARE_STICKY_TIME
                            ps_POLICY_PEER_SHARE_MAX_PEERS
      <*> pure publicStateVar

-- | Register a new upstream chain-sync client.
--
registerClientChains :: MonadSTM m
                     => NodeKernel header block s m
                     -> NtNAddr
                     -> m (StrictTVar m (Chain header))
registerClientChains :: forall (m :: * -> *) header block s.
MonadSTM m =>
NodeKernel header block s m
-> TestAddress NtNAddr_ -> m (StrictTVar m (Chain header))
registerClientChains NodeKernel { StrictTVar
  m (Map (TestAddress NtNAddr_) (StrictTVar m (Chain header)))
nkClientChains :: forall header block s (m :: * -> *).
NodeKernel header block s m
-> StrictTVar
     m (Map (TestAddress NtNAddr_) (StrictTVar m (Chain header)))
nkClientChains :: StrictTVar
  m (Map (TestAddress NtNAddr_) (StrictTVar m (Chain header)))
nkClientChains } TestAddress NtNAddr_
peerAddr = STM m (StrictTVar m (Chain header))
-> m (StrictTVar m (Chain header))
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (StrictTVar m (Chain header))
 -> m (StrictTVar m (Chain header)))
-> STM m (StrictTVar m (Chain header))
-> m (StrictTVar m (Chain header))
forall a b. (a -> b) -> a -> b
$ do
    chainVar <- Chain header -> STM m (StrictTVar m (Chain header))
forall (m :: * -> *) a. MonadSTM m => a -> STM m (StrictTVar m a)
newTVar Chain header
forall block. Chain block
Genesis
    modifyTVar nkClientChains (Map.insert peerAddr chainVar)
    return chainVar


-- | Unregister an upstream chain-sync client.
--
unregisterClientChains :: MonadSTM m
                       => NodeKernel header block s m
                       -> NtNAddr
                       -> m ()
unregisterClientChains :: forall (m :: * -> *) header block s.
MonadSTM m =>
NodeKernel header block s m -> TestAddress NtNAddr_ -> m ()
unregisterClientChains NodeKernel { StrictTVar
  m (Map (TestAddress NtNAddr_) (StrictTVar m (Chain header)))
nkClientChains :: forall header block s (m :: * -> *).
NodeKernel header block s m
-> StrictTVar
     m (Map (TestAddress NtNAddr_) (StrictTVar m (Chain header)))
nkClientChains :: StrictTVar
  m (Map (TestAddress NtNAddr_) (StrictTVar m (Chain header)))
nkClientChains } TestAddress NtNAddr_
peerAddr = STM m () -> m ()
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m () -> m ()) -> STM m () -> m ()
forall a b. (a -> b) -> a -> b
$
    StrictTVar
  m (Map (TestAddress NtNAddr_) (StrictTVar m (Chain header)))
-> (Map (TestAddress NtNAddr_) (StrictTVar m (Chain header))
    -> Map (TestAddress NtNAddr_) (StrictTVar m (Chain header)))
-> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> (a -> a) -> STM m ()
modifyTVar StrictTVar
  m (Map (TestAddress NtNAddr_) (StrictTVar m (Chain header)))
nkClientChains (TestAddress NtNAddr_
-> Map (TestAddress NtNAddr_) (StrictTVar m (Chain header))
-> Map (TestAddress NtNAddr_) (StrictTVar m (Chain header))
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete TestAddress NtNAddr_
peerAddr)

withSlotTime :: forall m a.
                ( MonadAsync         m
                , MonadDelay         m
                )
             => DiffTime
             -> ((SlotNo -> STM m SlotNo) -> m a)
             -- ^ continuation which receives a callback allowing to block until
             -- the given slot passes.  The stm action returns the slot current
             -- slot number.
             -> m a
withSlotTime :: forall (m :: * -> *) a.
(MonadAsync m, MonadDelay m) =>
DiffTime -> ((SlotNo -> STM m SlotNo) -> m a) -> m a
withSlotTime DiffTime
slotDuration (SlotNo -> STM m SlotNo) -> m a
k = do
    let start :: SlotNo
start = Word64 -> SlotNo
Block.SlotNo Word64
0
    slotVar <- SlotNo -> m (StrictTVar m SlotNo)
forall (m :: * -> *) a. MonadSTM m => a -> m (StrictTVar m a)
newTVarIO SlotNo
start
    let waitForSlot :: SlotNo -> STM m SlotNo
        waitForSlot SlotNo
slot = do
          current <- StrictTVar m SlotNo -> STM m SlotNo
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m SlotNo
slotVar
          check (current >= slot)
          return current
    withAsync (loop slotVar (succ start)) $ \Async m Void
_async -> (SlotNo -> STM m SlotNo) -> m a
k SlotNo -> STM m SlotNo
waitForSlot
  where
    loop :: StrictTVar m SlotNo
         -> SlotNo
         -> m Void
    loop :: StrictTVar m SlotNo -> SlotNo -> m Void
loop StrictTVar m SlotNo
slotVar = SlotNo -> m Void
go
      where
        go :: SlotNo -> m Void
        go :: SlotNo -> m Void
go SlotNo
next = do
          t <- m Time
forall (m :: * -> *). MonadMonotonicTime m => m Time
getMonotonicTime
          let delay = DiffTime -> DiffTime
forall a. Num a => a -> a
abs
                    (DiffTime -> DiffTime) -> DiffTime -> DiffTime
forall a b. (a -> b) -> a -> b
$ DiffTime -> Time
Time (DiffTime
slotDuration DiffTime -> DiffTime -> DiffTime
forall a. Num a => a -> a -> a
* Word64 -> DiffTime
forall a b. (Integral a, Num b) => a -> b
fromIntegral (SlotNo -> Word64
Block.unSlotNo SlotNo
next))
                      Time -> Time -> DiffTime
`diffTime` Time
t
          threadDelay delay
          atomically $ writeTVar slotVar next
          go (succ next)

-- | Node kernel erros.
--
data NodeKernelError = UnexpectedSlot !SlotNo !SlotNo
  deriving (Typeable, Int -> NodeKernelError -> ShowS
[NodeKernelError] -> ShowS
NodeKernelError -> String
(Int -> NodeKernelError -> ShowS)
-> (NodeKernelError -> String)
-> ([NodeKernelError] -> ShowS)
-> Show NodeKernelError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> NodeKernelError -> ShowS
showsPrec :: Int -> NodeKernelError -> ShowS
$cshow :: NodeKernelError -> String
show :: NodeKernelError -> String
$cshowList :: [NodeKernelError] -> ShowS
showList :: [NodeKernelError] -> ShowS
Show)

instance Exception NodeKernelError where


-- | Run chain selection \/ block production thread.
--
withNodeKernelThread
  :: forall block header m seed a.
     ( Alternative (STM m)
     , MonadAsync         m
     , MonadDelay         m
     , MonadThrow         m
     , MonadThrow    (STM m)
     , HasFullHeader block
     , RandomGen seed
     )
  => BlockGeneratorArgs block seed
  -> (NodeKernel header block seed m -> Async m Void -> m a)
  -- ^ The continuation which has a handle to the chain selection \/ block
  -- production thread.  The thread might throw an exception.
  -> m a
withNodeKernelThread :: forall block header (m :: * -> *) seed a.
(Alternative (STM m), MonadAsync m, MonadDelay m, MonadThrow m,
 MonadThrow (STM m), HasFullHeader block, RandomGen seed) =>
BlockGeneratorArgs block seed
-> (NodeKernel header block seed m -> Async m Void -> m a) -> m a
withNodeKernelThread BlockGeneratorArgs { DiffTime
bgaSlotDuration :: forall block s. BlockGeneratorArgs block s -> DiffTime
bgaSlotDuration :: DiffTime
bgaSlotDuration, seed -> Anchor block -> SlotNo -> (Maybe block, seed)
bgaBlockGenerator :: forall block s.
BlockGeneratorArgs block s
-> s -> Anchor block -> SlotNo -> (Maybe block, s)
bgaBlockGenerator :: seed -> Anchor block -> SlotNo -> (Maybe block, seed)
bgaBlockGenerator, seed
bgaSeed :: forall block s. BlockGeneratorArgs block s -> s
bgaSeed :: seed
bgaSeed }
                     NodeKernel header block seed m -> Async m Void -> m a
k = do
    kernel <- seed -> m (NodeKernel header block seed m)
forall (m :: * -> *) s header block.
MonadSTM m =>
s -> m (NodeKernel header block s m)
newNodeKernel seed
psSeed
    withSlotTime bgaSlotDuration $ \SlotNo -> STM m SlotNo
waitForSlot ->
      m Void -> (Async m Void -> m a) -> m a
forall a b. m a -> (Async m a -> m b) -> m b
forall (m :: * -> *) a b.
MonadAsync m =>
m a -> (Async m a -> m b) -> m b
withAsync (NodeKernel header block seed m
-> (SlotNo -> STM m SlotNo) -> m Void
blockProducerThread NodeKernel header block seed m
kernel SlotNo -> STM m SlotNo
waitForSlot) (NodeKernel header block seed m -> Async m Void -> m a
k NodeKernel header block seed m
kernel)
  where
    (seed
bpSeed, seed
psSeed) = seed -> (seed, seed)
forall g. RandomGen g => g -> (g, g)
split seed
bgaSeed

    blockProducerThread :: NodeKernel header block seed m
                        -> (SlotNo -> STM m SlotNo)
                        -> m Void
    blockProducerThread :: NodeKernel header block seed m
-> (SlotNo -> STM m SlotNo) -> m Void
blockProducerThread NodeKernel { StrictTVar m (ChainProducerState block)
nkChainProducerState :: forall header block s (m :: * -> *).
NodeKernel header block s m
-> StrictTVar m (ChainProducerState block)
nkChainProducerState :: StrictTVar m (ChainProducerState block)
nkChainProducerState, ChainDB block m
nkChainDB :: forall header block s (m :: * -> *).
NodeKernel header block s m -> ChainDB block m
nkChainDB :: ChainDB block m
nkChainDB }
                        SlotNo -> STM m SlotNo
waitForSlot
                      = SlotNo -> seed -> m Void
loop (Word64 -> SlotNo
Block.SlotNo Word64
1) seed
bpSeed
      where
        loop :: SlotNo -> seed -> m Void
        loop :: SlotNo -> seed -> m Void
loop SlotNo
nextSlot seed
seed = do
          -- update 'ChainProducerState' whatever happens first:
          -- - generate a new block for the next slot
          -- - a longer candidate chain is available
          (nextSlot', seed') <- STM m (SlotNo, seed) -> m (SlotNo, seed)
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (SlotNo, seed) -> m (SlotNo, seed))
-> STM m (SlotNo, seed) -> m (SlotNo, seed)
forall a b. (a -> b) -> a -> b
$ FirstToFinish (STM m) (SlotNo, seed) -> STM m (SlotNo, seed)
forall (m :: * -> *) a. FirstToFinish m a -> m a
runFirstToFinish (FirstToFinish (STM m) (SlotNo, seed) -> STM m (SlotNo, seed))
-> FirstToFinish (STM m) (SlotNo, seed) -> STM m (SlotNo, seed)
forall a b. (a -> b) -> a -> b
$

               --
               -- block production
               --
               STM m (SlotNo, seed) -> FirstToFinish (STM m) (SlotNo, seed)
forall (m :: * -> *) a. m a -> FirstToFinish m a
FirstToFinish
                 ( do currentSlot <- SlotNo -> STM m SlotNo
waitForSlot SlotNo
nextSlot
                      -- we are not supposed to block, apart from the above
                      -- blocking call to 'waitForSlot'.
                      when (currentSlot /= nextSlot)
                         $ throwIO (UnexpectedSlot currentSlot nextSlot)
                      cps@ChainProducerState { chainState } <-
                        readTVar nkChainProducerState
                      let anchor :: Anchor block
                          anchor = Chain block -> Anchor block
forall block. HasHeader block => Chain block -> Anchor block
Chain.headAnchor Chain block
chainState
                      -- generate a new block, which fits on top of the 'anchor'
                      case bgaBlockGenerator seed anchor currentSlot of
                        (Just block
block, seed
seed')
                          |    block -> Point block
forall block. HasHeader block => block -> Point block
Block.blockPoint block
block
                            Point block -> Point block -> Bool
forall a. Ord a => a -> a -> Bool
>= Chain block -> Point block
forall block. HasHeader block => Chain block -> Point block
Chain.headPoint Chain block
chainState
                          -> do
                             -- Forged a block add it to our ChainDB this will
                             -- make the new block available for computing
                             -- longestChain
                             block -> ChainDB block m -> STM m ()
forall (m :: * -> *) block.
(MonadSTM m, HasFullHeader block) =>
block -> ChainDB block m -> STM m ()
ChainDB.addBlock block
block ChainDB block m
nkChainDB

                             -- Get possibly new longest chain
                             longestChain <-
                               TVar m (Chain block) -> STM m (Chain block)
forall a. TVar m a -> STM m a
forall (m :: * -> *) a. MonadSTM m => TVar m a -> STM m a
LazySTM.readTVar (ChainDB block m -> TVar m (Chain block)
forall block (m :: * -> *). ChainDB block m -> TVar m (Chain block)
cdbLongestChainVar ChainDB block m
nkChainDB)

                             -- Switch to it and update our current state so we
                             -- can serve other nodes through block fetch.
                             let cps' = Chain block -> ChainProducerState block -> ChainProducerState block
forall block.
HasHeader block =>
Chain block -> ChainProducerState block -> ChainProducerState block
switchFork Chain block
longestChain ChainProducerState block
cps
                             writeTVar nkChainProducerState
                                       cps' { chainState = longestChain }
                          STM m () -> STM m (SlotNo, seed) -> STM m (SlotNo, seed)
forall a b. STM m a -> STM m b -> STM m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (SlotNo, seed) -> STM m (SlotNo, seed)
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return (SlotNo -> SlotNo
forall a. Enum a => a -> a
succ SlotNo
nextSlot, seed
seed')
                        (Maybe block
_, seed
seed')
                          -> (SlotNo, seed) -> STM m (SlotNo, seed)
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return (SlotNo -> SlotNo
forall a. Enum a => a -> a
succ SlotNo
nextSlot, seed
seed')
                 )

               --
               -- chain selection
               --
            FirstToFinish (STM m) (SlotNo, seed)
-> FirstToFinish (STM m) (SlotNo, seed)
-> FirstToFinish (STM m) (SlotNo, seed)
forall a. Semigroup a => a -> a -> a
<> STM m (SlotNo, seed) -> FirstToFinish (STM m) (SlotNo, seed)
forall (m :: * -> *) a. m a -> FirstToFinish m a
FirstToFinish
                 ( do
                      -- Get our current chain
                      cps@ChainProducerState { chainState } <-
                        StrictTVar m (ChainProducerState block)
-> STM m (ChainProducerState block)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (ChainProducerState block)
nkChainProducerState
                      -- Get what ChainDB sees as the longest chain
                      longestChain <-
                        LazySTM.readTVar (cdbLongestChainVar nkChainDB)

                      -- Only update the chain if it's different than our current
                      -- one, else retry
                      check $ Chain.headPoint chainState
                           /= Chain.headPoint longestChain

                      -- If it's different, switch to it and update our current
                      -- state so we can serve other nodes through block fetch.
                      let cps' = Chain block -> ChainProducerState block -> ChainProducerState block
forall block.
HasHeader block =>
Chain block -> ChainProducerState block -> ChainProducerState block
switchFork Chain block
longestChain ChainProducerState block
cps
                      writeTVar nkChainProducerState
                                cps' { chainState = longestChain }
                      writeTVar nkChainProducerState cps'
                      -- do not update 'nextSlot'; This stm branch might run
                      -- multiple times within the current slot.
                      return (nextSlot, seed)
                 )
          loop nextSlot' seed'