{-# LANGUAGE CPP                 #-}
{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE GADTs               #-}
{-# LANGUAGE NamedFieldPuns      #-}
{-# LANGUAGE RankNTypes          #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections       #-}

#if __GLASGOW_HASKELL__ >= 908
{-# OPTIONS_GHC -Wno-x-partial   #-}
#endif

module Test.Ouroboros.Network.MockNode where

import Control.Monad (filterM, forM, forM_, replicateM, unless)
import Control.Monad.State (execStateT, lift, modify')
import Data.Array
import Data.Fixed (Micro)
import Data.Functor (void)
import Data.Graph
import Data.List as List (foldl')
import Data.Map.Strict (Map)
import Data.Map.Strict qualified as Map
import Data.Maybe (isNothing, listToMaybe)
import Data.Tuple (swap)

import Test.QuickCheck
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.QuickCheck (testProperty)

import Control.Concurrent.Class.MonadSTM.Strict
import Control.Monad.Class.MonadFork
import Control.Monad.Class.MonadSay
import Control.Monad.Class.MonadThrow
import Control.Monad.Class.MonadTime.SI
import Control.Monad.Class.MonadTimer.SI
import Control.Monad.IOSim qualified as Sim

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

import Ouroboros.Network.MockNode

import Test.ChainGenerators (TestBlockChain (..))


tests :: TestTree
tests :: TestTree
tests =
  TestName -> [TestTree] -> TestTree
testGroup TestName
"MockNode"
  [ TestName -> [TestTree] -> TestTree
testGroup TestName
"fixed graph topology"
    [ TestName -> (TestNodeSim -> Property) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"core -> relay" TestNodeSim -> Property
prop_coreToRelay
    , TestName -> (TestNodeSim -> Property) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"core -> relay -> relay" TestNodeSim -> Property
prop_coreToRelay2
    ]
  , TestName -> Property -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"arbtirary node graph" (Vertex -> (NetworkTest -> Property) -> Property
forall prop. Testable prop => Vertex -> prop -> Property
withMaxSuccess Vertex
50 NetworkTest -> Property
prop_networkGraph)
  , TestName
-> (TestBlockChain -> Positive Micro -> Property) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"blockGenerator invariant IOSim" TestBlockChain -> Positive Micro -> Property
prop_blockGenerator_ST
  , TestName
-> (TestBlockChain -> Positive Vertex -> Property) -> TestTree
forall a. Testable a => TestName -> a -> TestTree
testProperty TestName
"blockGenerator invariant IO" TestBlockChain -> Positive Vertex -> Property
prop_blockGenerator_IO
  ]


-- NOTE: it reverses the order of probes
partitionProbe :: [(NodeId, a)] -> Map NodeId [a]
partitionProbe :: forall a. [(NodeId, a)] -> Map NodeId [a]
partitionProbe
  = ([a] -> [a] -> [a]) -> [(NodeId, [a])] -> Map NodeId [a]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
(++) ([(NodeId, [a])] -> Map NodeId [a])
-> ([(NodeId, a)] -> [(NodeId, [a])])
-> [(NodeId, a)]
-> Map NodeId [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((NodeId, a) -> (NodeId, [a])) -> [(NodeId, a)] -> [(NodeId, [a])]
forall a b. (a -> b) -> [a] -> [b]
map (\(NodeId
nid, a
a) -> (NodeId
nid, [a
a]))

-- | Block generator should generate blocks in the correct slot time.
--
test_blockGenerator
  :: forall m.
     ( MonadDelay m
     , MonadFork m
     , MonadTime m
     , MonadTimer m
     )
  => Chain Block
  -> DiffTime
  -> m Property
test_blockGenerator :: forall (m :: * -> *).
(MonadDelay m, MonadFork m, MonadTime m, MonadTimer m) =>
Chain Block -> DiffTime -> m Property
test_blockGenerator Chain Block
chain DiffTime
slotDuration = do
    startTime <- m Time
forall (m :: * -> *). MonadMonotonicTime m => m Time
getMonotonicTime
    isValid startTime <$> withProbe (experiment slotDuration)
  where
    isValid :: Time -> [(Time, Block)] -> Property
    isValid :: Time -> [(Time, Block)] -> Property
isValid Time
startTime = (Property -> (Time, Block) -> Property)
-> Property -> [(Time, Block)] -> Property
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl'
      (\Property
r (Time
t, Block
b) -> Property
r Property -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.&&. TestName -> Bool -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample (Time -> TestName
forall a. Show a => a -> TestName
show Time
t
                                           TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ TestName
" ≱ "
                                           TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ Time -> TestName
forall a. Show a => a -> TestName
show (SlotNo -> Time
slotTime (Block -> SlotNo
forall b. HasHeader b => b -> SlotNo
blockSlot Block
b)))
                                           (Time
t Time -> Time -> Bool
forall a. Ord a => a -> a -> Bool
>= SlotNo -> Time
slotTime (Block -> SlotNo
forall b. HasHeader b => b -> SlotNo
blockSlot Block
b))
                      Property -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.&&. TestName -> Bool -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample (Time -> TestName
forall a. Show a => a -> TestName
show Time
t
                                           TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ TestName
" ≮ "
                                           TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ Time -> TestName
forall a. Show a => a -> TestName
show (SlotNo -> Time
slotTime (SlotNo -> SlotNo
forall a. Enum a => a -> a
succ (SlotNo -> SlotNo) -> SlotNo -> SlotNo
forall a b. (a -> b) -> a -> b
$ Block -> SlotNo
forall b. HasHeader b => b -> SlotNo
blockSlot Block
b)))
                                           (Time
t Time -> Time -> Bool
forall a. Ord a => a -> a -> Bool
<  (SlotNo -> Time
slotTime (SlotNo -> SlotNo
forall a. Enum a => a -> a
succ (SlotNo -> SlotNo) -> SlotNo -> SlotNo
forall a b. (a -> b) -> a -> b
$ Block -> SlotNo
forall b. HasHeader b => b -> SlotNo
blockSlot Block
b))))
        (Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
True)
      where
        slotTime :: SlotNo -> Time
        slotTime :: SlotNo -> Time
slotTime SlotNo
s = (Word64 -> DiffTime
forall a b. (Real a, Fractional b) => a -> b
realToFrac (SlotNo -> Word64
unSlotNo SlotNo
s) DiffTime -> DiffTime -> DiffTime
forall a. Num a => a -> a -> a
* DiffTime
slotDuration) DiffTime -> Time -> Time
`addTime` Time
startTime

    experiment
      :: DiffTime
      -> Probe m (Time, Block)
      -> m ()
    experiment :: DiffTime -> Probe m (Time, Block) -> m ()
experiment DiffTime
slotDur Probe m (Time, Block)
p = do
      getBlock <- DiffTime -> [Block] -> m (STM m (Maybe Block))
forall block (m :: * -> *).
(HasHeader block, MonadDelay m, MonadSTM m, MonadFork m) =>
DiffTime -> [block] -> m (STM m (Maybe block))
blockGenerator DiffTime
slotDur (Chain Block -> [Block]
forall block. Chain block -> [block]
Chain.toOldestFirst Chain Block
chain)
      void $ forkIO $ go getBlock
     where
      go :: STM m (Maybe Block) -> m ()
go STM m (Maybe Block)
getBlock = do
        mb <- STM m (Maybe Block) -> m (Maybe Block)
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (Maybe Block) -> m (Maybe Block))
-> STM m (Maybe Block) -> m (Maybe Block)
forall a b. (a -> b) -> a -> b
$ STM m (Maybe Block)
getBlock
        case mb of
          Just Block
b  -> do t <- m Time
forall (m :: * -> *). MonadMonotonicTime m => m Time
getMonotonicTime
                        probeOutput p (t, b)
                        go getBlock
          Maybe Block
Nothing -> () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

prop_blockGenerator_ST :: TestBlockChain -> Positive Micro -> Property
prop_blockGenerator_ST :: TestBlockChain -> Positive Micro -> Property
prop_blockGenerator_ST (TestBlockChain Chain Block
chain) (Positive Micro
slotDuration) =
    (forall s. IOSim s Property) -> Property
forall a. (forall s. IOSim s a) -> a
Sim.runSimOrThrow ((forall s. IOSim s Property) -> Property)
-> (forall s. IOSim s Property) -> Property
forall a b. (a -> b) -> a -> b
$
      Chain Block -> DiffTime -> IOSim s Property
forall (m :: * -> *).
(MonadDelay m, MonadFork m, MonadTime m, MonadTimer m) =>
Chain Block -> DiffTime -> m Property
test_blockGenerator Chain Block
chain (Micro -> DiffTime
forall a b. (Real a, Fractional b) => a -> b
realToFrac Micro
slotDuration)

prop_blockGenerator_IO :: TestBlockChain -> Positive Int -> Property
prop_blockGenerator_IO :: TestBlockChain -> Positive Vertex -> Property
prop_blockGenerator_IO (TestBlockChain Chain Block
chain) (Positive Vertex
slotDuration) =
    IO Property -> Property
forall prop. Testable prop => IO prop -> Property
ioProperty (IO Property -> Property) -> IO Property -> Property
forall a b. (a -> b) -> a -> b
$
      Chain Block -> DiffTime -> IO Property
forall (m :: * -> *).
(MonadDelay m, MonadFork m, MonadTime m, MonadTimer m) =>
Chain Block -> DiffTime -> m Property
test_blockGenerator Chain Block
chain DiffTime
slotDuration'
  where
    slotDuration' :: DiffTime
    slotDuration' :: DiffTime
slotDuration' = Vertex -> DiffTime
forall a b. (Integral a, Num b) => a -> b
fromIntegral Vertex
slotDuration

coreToRelaySim :: ( MonadDelay m
                  , MonadFork m
                  , MonadLabelledSTM m
                  , MonadSay m
                  , MonadThrow m
                  , MonadTimer m
                  )
               => Bool              -- ^ two way subscription
               -> Chain Block
               -> DiffTime          -- ^ slot duration
               -> DiffTime          -- ^ core transport delay
               -> DiffTime          -- ^ relay transport delay
               -> Probe m (NodeId, Chain Block)
               -> m ()
coreToRelaySim :: forall (m :: * -> *).
(MonadDelay m, MonadFork m, MonadLabelledSTM m, MonadSay m,
 MonadThrow m, MonadTimer m) =>
Bool
-> Chain Block
-> DiffTime
-> DiffTime
-> DiffTime
-> Probe m (NodeId, Chain Block)
-> m ()
coreToRelaySim Bool
duplex Chain Block
chain DiffTime
slotDuration DiffTime
coreTrDelay DiffTime
relayTrDelay Probe m (NodeId, Chain Block)
probe = do
  donevar <- Bool -> m (StrictTVar m Bool)
forall (m :: * -> *) a. MonadSTM m => a -> m (StrictTVar m a)
newTVarIO Bool
False
  (coreChans, relayChans) <- if duplex
    then createTwoWaySubscriptionChannels relayTrDelay coreTrDelay
    else createOneWaySubscriptionChannels coreTrDelay relayTrDelay

  void $ forkIO $ do
    cps <- coreNode (CoreId 0) slotDuration (Chain.toOldestFirst chain) coreChans
    void $ forkIO $ observeChainProducerState (CoreId 0) probe cps
  void $ forkIO $ void $ do
    cps <- relayNode (RelayId 0) Genesis relayChans
    void $ forkIO $ observeChainProducerState (RelayId 0) probe cps
    atomically $ do
      chain' <- chainState <$> readTVar cps
      unless (chain == chain') retry
      writeTVar donevar True

  atomically $ do
    done <- readTVar donevar
    unless done retry


data TestNodeSim = TestNodeSim
  { TestNodeSim -> Chain Block
testChain               :: Chain Block
  , TestNodeSim -> DiffTime
testSlotDuration        :: DiffTime
  , TestNodeSim -> DiffTime
testCoreTransportDelay  :: DiffTime
  , TestNodeSim -> DiffTime
testRelayTransportDelay :: DiffTime
  }
  deriving (Vertex -> TestNodeSim -> TestName -> TestName
[TestNodeSim] -> TestName -> TestName
TestNodeSim -> TestName
(Vertex -> TestNodeSim -> TestName -> TestName)
-> (TestNodeSim -> TestName)
-> ([TestNodeSim] -> TestName -> TestName)
-> Show TestNodeSim
forall a.
(Vertex -> a -> TestName -> TestName)
-> (a -> TestName) -> ([a] -> TestName -> TestName) -> Show a
$cshowsPrec :: Vertex -> TestNodeSim -> TestName -> TestName
showsPrec :: Vertex -> TestNodeSim -> TestName -> TestName
$cshow :: TestNodeSim -> TestName
show :: TestNodeSim -> TestName
$cshowList :: [TestNodeSim] -> TestName -> TestName
showList :: [TestNodeSim] -> TestName -> TestName
Show, TestNodeSim -> TestNodeSim -> Bool
(TestNodeSim -> TestNodeSim -> Bool)
-> (TestNodeSim -> TestNodeSim -> Bool) -> Eq TestNodeSim
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TestNodeSim -> TestNodeSim -> Bool
== :: TestNodeSim -> TestNodeSim -> Bool
$c/= :: TestNodeSim -> TestNodeSim -> Bool
/= :: TestNodeSim -> TestNodeSim -> Bool
Eq)

instance Arbitrary TestNodeSim where
  arbitrary :: Gen TestNodeSim
arbitrary = do
      TestBlockChain testChain <- Gen TestBlockChain
forall a. Arbitrary a => Gen a
arbitrary
      -- at least twice as much as testCoreDelay
      Positive testSlotDuration <- fmap secondsToDiffTime <$> arbitrary
      Positive testCoreTransportDelay <- fmap secondsToDiffTime <$> arbitrary
      Positive testRelayTransportDelay <- fmap secondsToDiffTime <$> arbitrary
      return $ TestNodeSim { testChain,
                             testSlotDuration,
                             testCoreTransportDelay,
                             testRelayTransportDelay }
    where
       secondsToDiffTime :: Micro -> DiffTime
       secondsToDiffTime :: Micro -> DiffTime
secondsToDiffTime = Micro -> DiffTime
forall a b. (Real a, Fractional b) => a -> b
realToFrac

  -- TODO: shrink

-- this test relies on the property that when there is a single core node,
-- it will never have to use @'fixupBlock'@ function (which mangles blocks
-- picked up from the generator).  This is because all the nodes start with
-- @'Genesis'@ chain, hence the core node is a single source of truth.
prop_coreToRelay :: TestNodeSim -> Property
prop_coreToRelay :: TestNodeSim -> Property
prop_coreToRelay (TestNodeSim Chain Block
chain DiffTime
slotDuration DiffTime
coreTrDelay DiffTime
relayTrDelay) =
  let probes :: [(NodeId, Chain Block)]
probes  = (forall s. IOSim s [(NodeId, Chain Block)])
-> [(NodeId, Chain Block)]
forall a. (forall s. IOSim s a) -> a
Sim.runSimOrThrow ((forall s. IOSim s [(NodeId, Chain Block)])
 -> [(NodeId, Chain Block)])
-> (forall s. IOSim s [(NodeId, Chain Block)])
-> [(NodeId, Chain Block)]
forall a b. (a -> b) -> a -> b
$ (Probe (IOSim s) (NodeId, Chain Block) -> IOSim s ())
-> IOSim s [(NodeId, Chain Block)]
forall (m :: * -> *) x. MonadSTM m => (Probe m x -> m ()) -> m [x]
withProbe ((Probe (IOSim s) (NodeId, Chain Block) -> IOSim s ())
 -> IOSim s [(NodeId, Chain Block)])
-> (Probe (IOSim s) (NodeId, Chain Block) -> IOSim s ())
-> IOSim s [(NodeId, Chain Block)]
forall a b. (a -> b) -> a -> b
$
                  Bool
-> Chain Block
-> DiffTime
-> DiffTime
-> DiffTime
-> Probe (IOSim s) (NodeId, Chain Block)
-> IOSim s ()
forall (m :: * -> *).
(MonadDelay m, MonadFork m, MonadLabelledSTM m, MonadSay m,
 MonadThrow m, MonadTimer m) =>
Bool
-> Chain Block
-> DiffTime
-> DiffTime
-> DiffTime
-> Probe m (NodeId, Chain Block)
-> m ()
coreToRelaySim Bool
False Chain Block
chain
                                 DiffTime
slotDuration DiffTime
coreTrDelay DiffTime
relayTrDelay
      dict    :: Map NodeId [Chain Block]
      dict :: Map NodeId [Chain Block]
dict    = [(NodeId, Chain Block)] -> Map NodeId [Chain Block]
forall a. [(NodeId, a)] -> Map NodeId [a]
partitionProbe [(NodeId, Chain Block)]
probes
      mchain1 :: Maybe (Chain Block)
      mchain1 :: Maybe (Chain Block)
mchain1 = Vertex -> NodeId
RelayId Vertex
0 NodeId -> Map NodeId [Chain Block] -> Maybe [Chain Block]
forall k a. Ord k => k -> Map k a -> Maybe a
`Map.lookup` Map NodeId [Chain Block]
dict Maybe [Chain Block]
-> ([Chain Block] -> Maybe (Chain Block)) -> Maybe (Chain Block)
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Chain Block] -> Maybe (Chain Block)
forall a. [a] -> Maybe a
listToMaybe
  in TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample (Maybe (Chain Block) -> TestName
forall a. Show a => a -> TestName
show Maybe (Chain Block)
mchain1) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
    if Chain Block -> Bool
forall block. Chain block -> Bool
Chain.null Chain Block
chain
        -- when a chain is null, the relay observer will never be triggered,
        -- since its chain never is never updated
      then Bool -> Property
forall prop. Testable prop => prop -> Property
property (Bool -> Property) -> Bool -> Property
forall a b. (a -> b) -> a -> b
$ Maybe (Chain Block) -> Bool
forall a. Maybe a -> Bool
isNothing Maybe (Chain Block)
mchain1
      else Maybe (Chain Block)
mchain1 Maybe (Chain Block) -> Maybe (Chain Block) -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== Chain Block -> Maybe (Chain Block)
forall a. a -> Maybe a
Just Chain Block
chain

-- Node graph: c → r → r
coreToRelaySim2 :: ( MonadDelay m
                   , MonadLabelledSTM m
                   , MonadFork m
                   , MonadThrow m
                   , MonadSay m
                   , MonadTimer m
                   )
                => Chain Block
                -> DiffTime
                -- ^ slot length
                -> DiffTime
                -- ^ core transport delay
                -> DiffTime
                -- ^ relay transport delay
                -> Probe m (NodeId, Chain Block)
                -> m ()
coreToRelaySim2 :: forall (m :: * -> *).
(MonadDelay m, MonadLabelledSTM m, MonadFork m, MonadThrow m,
 MonadSay m, MonadTimer m) =>
Chain Block
-> DiffTime
-> DiffTime
-> DiffTime
-> Probe m (NodeId, Chain Block)
-> m ()
coreToRelaySim2 Chain Block
chain DiffTime
slotDuration DiffTime
coreTrDelay DiffTime
relayTrDelay Probe m (NodeId, Chain Block)
probe = do
  donevar <- Bool -> m (StrictTVar m Bool)
forall (m :: * -> *) a. MonadSTM m => a -> m (StrictTVar m a)
newTVarIO Bool
False
  (cr1, r1c) <- createOneWaySubscriptionChannels coreTrDelay relayTrDelay
  (r1r2, r2r1) <- createOneWaySubscriptionChannels relayTrDelay relayTrDelay

  void $ forkIO $ void $ do
    cps <- coreNode (CoreId 0) slotDuration (Chain.toOldestFirst chain) cr1
    void $ forkIO $ observeChainProducerState (CoreId 0) probe cps
  void $ forkIO $ void $ do
    cps <- relayNode (RelayId 1) Genesis(r1c <> r1r2)
    void $ forkIO $ observeChainProducerState (RelayId 1) probe cps
  void $ forkIO $ void $ do
    cps <- relayNode (RelayId 2) Genesis r2r1
    void $ forkIO $ observeChainProducerState (RelayId 2) probe cps

    atomically $ do
      chain' <- chainState <$> readTVar cps
      unless (chain == chain') retry
      writeTVar donevar True

  atomically $ do
    done <- readTVar donevar
    unless done retry


prop_coreToRelay2 :: TestNodeSim -> Property
prop_coreToRelay2 :: TestNodeSim -> Property
prop_coreToRelay2 (TestNodeSim Chain Block
chain DiffTime
slotDuration DiffTime
coreTrDelay DiffTime
relayTrDelay) =
  let probes :: [(NodeId, Chain Block)]
probes  = (forall s. IOSim s [(NodeId, Chain Block)])
-> [(NodeId, Chain Block)]
forall a. (forall s. IOSim s a) -> a
Sim.runSimOrThrow ((forall s. IOSim s [(NodeId, Chain Block)])
 -> [(NodeId, Chain Block)])
-> (forall s. IOSim s [(NodeId, Chain Block)])
-> [(NodeId, Chain Block)]
forall a b. (a -> b) -> a -> b
$ (Probe (IOSim s) (NodeId, Chain Block) -> IOSim s ())
-> IOSim s [(NodeId, Chain Block)]
forall (m :: * -> *) x. MonadSTM m => (Probe m x -> m ()) -> m [x]
withProbe ((Probe (IOSim s) (NodeId, Chain Block) -> IOSim s ())
 -> IOSim s [(NodeId, Chain Block)])
-> (Probe (IOSim s) (NodeId, Chain Block) -> IOSim s ())
-> IOSim s [(NodeId, Chain Block)]
forall a b. (a -> b) -> a -> b
$
                  Chain Block
-> DiffTime
-> DiffTime
-> DiffTime
-> Probe (IOSim s) (NodeId, Chain Block)
-> IOSim s ()
forall (m :: * -> *).
(MonadDelay m, MonadLabelledSTM m, MonadFork m, MonadThrow m,
 MonadSay m, MonadTimer m) =>
Chain Block
-> DiffTime
-> DiffTime
-> DiffTime
-> Probe m (NodeId, Chain Block)
-> m ()
coreToRelaySim2 Chain Block
chain DiffTime
slotDuration DiffTime
coreTrDelay DiffTime
relayTrDelay
      dict :: Map NodeId [Chain Block]
dict    = [(NodeId, Chain Block)] -> Map NodeId [Chain Block]
forall a. [(NodeId, a)] -> Map NodeId [a]
partitionProbe [(NodeId, Chain Block)]
probes
      mchain1 :: Maybe (Chain Block)
mchain1 = Vertex -> NodeId
RelayId Vertex
1 NodeId -> Map NodeId [Chain Block] -> Maybe [Chain Block]
forall k a. Ord k => k -> Map k a -> Maybe a
`Map.lookup` Map NodeId [Chain Block]
dict Maybe [Chain Block]
-> ([Chain Block] -> Maybe (Chain Block)) -> Maybe (Chain Block)
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Chain Block] -> Maybe (Chain Block)
forall a. [a] -> Maybe a
listToMaybe
      mchain2 :: Maybe (Chain Block)
mchain2 = Vertex -> NodeId
RelayId Vertex
2 NodeId -> Map NodeId [Chain Block] -> Maybe [Chain Block]
forall k a. Ord k => k -> Map k a -> Maybe a
`Map.lookup` Map NodeId [Chain Block]
dict Maybe [Chain Block]
-> ([Chain Block] -> Maybe (Chain Block)) -> Maybe (Chain Block)
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Chain Block] -> Maybe (Chain Block)
forall a. [a] -> Maybe a
listToMaybe
  in TestName -> Property -> Property
forall prop. Testable prop => TestName -> prop -> Property
counterexample (Maybe (Chain Block) -> TestName
forall a. Show a => a -> TestName
show Maybe (Chain Block)
mchain1) (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$
    if Chain Block -> Bool
forall block. Chain block -> Bool
Chain.null Chain Block
chain
        -- when a chain is null, the relay observer will never be triggered,
        -- since its chain never is never updated
      then Maybe (Chain Block) -> Bool
forall a. Maybe a -> Bool
isNothing Maybe (Chain Block)
mchain1 Bool -> Bool -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.&&. Maybe (Chain Block) -> Bool
forall a. Maybe a -> Bool
isNothing Maybe (Chain Block)
mchain2
      else
            Maybe (Chain Block)
mchain1 Maybe (Chain Block) -> Maybe (Chain Block) -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== Chain Block -> Maybe (Chain Block)
forall a. a -> Maybe a
Just Chain Block
chain
        Property -> Property -> Property
forall prop1 prop2.
(Testable prop1, Testable prop2) =>
prop1 -> prop2 -> Property
.&&.
            Maybe (Chain Block)
mchain2 Maybe (Chain Block) -> Maybe (Chain Block) -> Property
forall a. (Eq a, Show a) => a -> a -> Property
=== Chain Block -> Maybe (Chain Block)
forall a. a -> Maybe a
Just Chain Block
chain


data TestNetworkGraph = TestNetworkGraph Graph [(Int, Chain Block)]
    deriving Vertex -> TestNetworkGraph -> TestName -> TestName
[TestNetworkGraph] -> TestName -> TestName
TestNetworkGraph -> TestName
(Vertex -> TestNetworkGraph -> TestName -> TestName)
-> (TestNetworkGraph -> TestName)
-> ([TestNetworkGraph] -> TestName -> TestName)
-> Show TestNetworkGraph
forall a.
(Vertex -> a -> TestName -> TestName)
-> (a -> TestName) -> ([a] -> TestName -> TestName) -> Show a
$cshowsPrec :: Vertex -> TestNetworkGraph -> TestName -> TestName
showsPrec :: Vertex -> TestNetworkGraph -> TestName -> TestName
$cshow :: TestNetworkGraph -> TestName
show :: TestNetworkGraph -> TestName
$cshowList :: [TestNetworkGraph] -> TestName -> TestName
showList :: [TestNetworkGraph] -> TestName -> TestName
Show

-- Connect disconnected graph components; randomly chose nodes through which
-- connect them.
connectGraphG :: Graph -> Gen Graph
connectGraphG :: Graph -> Gen Graph
connectGraphG Graph
g = do
    let ts :: [Tree Vertex]
ts  = Graph -> [Tree Vertex]
scc Graph
g
    vs <- (Tree Vertex -> Gen Vertex) -> [Tree Vertex] -> Gen [Vertex]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse ([Gen Vertex] -> Gen Vertex
forall a. [Gen a] -> Gen a
oneof ([Gen Vertex] -> Gen Vertex)
-> (Tree Vertex -> [Gen Vertex]) -> Tree Vertex -> Gen Vertex
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Vertex -> Gen Vertex) -> [Vertex] -> [Gen Vertex]
forall a b. (a -> b) -> [a] -> [b]
map Vertex -> Gen Vertex
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Vertex] -> [Gen Vertex])
-> (Tree Vertex -> [Vertex]) -> Tree Vertex -> [Gen Vertex]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tree Vertex -> [Vertex]
treeVertices) [Tree Vertex]
ts
    return $ accum (flip (:)) g [(i, j) | i <- vs, j <- vs]
    where
    treeVertices :: Tree Vertex -> [Vertex]
    treeVertices :: Tree Vertex -> [Vertex]
treeVertices (Node Vertex
i [Tree Vertex]
ns) = Vertex
i Vertex -> [Vertex] -> [Vertex]
forall a. a -> [a] -> [a]
: (Tree Vertex -> [Vertex]) -> [Tree Vertex] -> [Vertex]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Tree Vertex -> [Vertex]
treeVertices [Tree Vertex]
ns

instance Arbitrary TestNetworkGraph where
    arbitrary :: Gen TestNetworkGraph
arbitrary = Vertex -> Gen TestNetworkGraph -> Gen TestNetworkGraph
forall a. Vertex -> Gen a -> Gen a
resize Vertex
20 (Gen TestNetworkGraph -> Gen TestNetworkGraph)
-> Gen TestNetworkGraph -> Gen TestNetworkGraph
forall a b. (a -> b) -> a -> b
$ do
        g <- Gen Graph
arbitraryAcyclicGraphSmall
        let g' = ([Vertex] -> [Vertex] -> [Vertex])
-> Graph -> [(Vertex, [Vertex])] -> Graph
forall i e a.
Ix i =>
(e -> a -> e) -> Array i e -> [(i, a)] -> Array i e
accum [Vertex] -> [Vertex] -> [Vertex]
forall a. [a] -> [a] -> [a]
(++) Graph
g (Graph -> [(Vertex, [Vertex])]
forall i e. Ix i => Array i e -> [(i, e)]
assocs (Graph -> [(Vertex, [Vertex])]) -> Graph -> [(Vertex, [Vertex])]
forall a b. (a -> b) -> a -> b
$ Graph -> Graph
transposeG Graph
g)
            vs = (Graph -> [Vertex]
vertices Graph
g)
        cs  <- genCoreNodes vs
        c   <- oneof (map return vs)
        let cs' = if [Vertex] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Vertex]
cs then [Vertex
c] else [Vertex]
cs
        g'' <- connectGraphG g'
        chains <- map getTestBlockChain <$> replicateM (length cs') arbitrary
        return $ TestNetworkGraph g'' (zip cs' chains)
     where
        genCoreNodes :: [Int] -> Gen [Int]
        genCoreNodes :: [Vertex] -> Gen [Vertex]
genCoreNodes []       = [Vertex] -> Gen [Vertex]
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return []
        genCoreNodes (Vertex
x : [Vertex]
xs) = do
            t <- [(Vertex, Gen Bool)] -> Gen Bool
forall a. [(Vertex, Gen a)] -> Gen a
frequency [(Vertex
2, Bool -> Gen Bool
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True), (Vertex
1, Bool -> Gen Bool
forall a. a -> Gen a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False)]
            if t
                then (x:) <$> genCoreNodes xs
                else genCoreNodes xs

    shrink :: TestNetworkGraph -> [TestNetworkGraph]
shrink (TestNetworkGraph Graph
g [(Vertex, Chain Block)]
cs) =
        [ Graph -> [(Vertex, Chain Block)] -> TestNetworkGraph
TestNetworkGraph Graph
g [(Vertex, Chain Block)]
cs' | [(Vertex, Chain Block)]
cs' <- ((Vertex, Chain Block) -> [(Vertex, Chain Block)])
-> [(Vertex, Chain Block)] -> [[(Vertex, Chain Block)]]
forall a. (a -> [a]) -> [a] -> [[a]]
shrinkList ((Vertex, Chain Block)
-> [(Vertex, Chain Block)] -> [(Vertex, Chain Block)]
forall a. a -> [a] -> [a]
:[]) [(Vertex, Chain Block)]
cs, Bool -> Bool
not ([(Vertex, Chain Block)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Vertex, Chain Block)]
cs') ]

networkGraphSim :: forall m.
                  ( MonadDelay m
                  , MonadLabelledSTM m
                  , MonadFork m
                  , MonadThrow m
                  , MonadSay m
                  , MonadTimer m
                  )
                => TestNetworkGraph
                -> DiffTime          -- ^ slot duration
                -> DiffTime          -- ^ core transport delay
                -> DiffTime          -- ^ relay transport delay
                -> Probe m (NodeId, Chain Block)
                -> m ()
networkGraphSim :: forall (m :: * -> *).
(MonadDelay m, MonadLabelledSTM m, MonadFork m, MonadThrow m,
 MonadSay m, MonadTimer m) =>
TestNetworkGraph
-> DiffTime
-> DiffTime
-> DiffTime
-> Probe m (NodeId, Chain Block)
-> m ()
networkGraphSim (TestNetworkGraph Graph
g [(Vertex, Chain Block)]
cs) DiffTime
slotDuration DiffTime
coreTrDelay DiffTime
relayTrDelay Probe m (NodeId, Chain Block)
probe = do
  let vs :: [Vertex]
vs = Graph -> [Vertex]
vertices Graph
g
      channs :: Map Vertex (NodeChannels m Block (Tip Block))
channs = [(Vertex, NodeChannels m Block (Tip Block))]
-> Map Vertex (NodeChannels m Block (Tip Block))
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ((Vertex -> (Vertex, NodeChannels m Block (Tip Block)))
-> [Vertex] -> [(Vertex, NodeChannels m Block (Tip Block))]
forall a b. (a -> b) -> [a] -> [b]
map (,NodeChannels m Block (Tip Block)
forall a. Monoid a => a
mempty) [Vertex]
vs)

  -- construct communication channels based on the graph
  channs' <- (StateT (Map Vertex (NodeChannels m Block (Tip Block))) m [[()]]
 -> Map Vertex (NodeChannels m Block (Tip Block))
 -> m (Map Vertex (NodeChannels m Block (Tip Block))))
-> Map Vertex (NodeChannels m Block (Tip Block))
-> StateT (Map Vertex (NodeChannels m Block (Tip Block))) m [[()]]
-> m (Map Vertex (NodeChannels m Block (Tip Block)))
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT (Map Vertex (NodeChannels m Block (Tip Block))) m [[()]]
-> Map Vertex (NodeChannels m Block (Tip Block))
-> m (Map Vertex (NodeChannels m Block (Tip Block)))
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
execStateT Map Vertex (NodeChannels m Block (Tip Block))
channs (StateT (Map Vertex (NodeChannels m Block (Tip Block))) m [[()]]
 -> m (Map Vertex (NodeChannels m Block (Tip Block))))
-> StateT (Map Vertex (NodeChannels m Block (Tip Block))) m [[()]]
-> m (Map Vertex (NodeChannels m Block (Tip Block)))
forall a b. (a -> b) -> a -> b
$ [(Vertex, [Vertex])]
-> ((Vertex, [Vertex])
    -> StateT (Map Vertex (NodeChannels m Block (Tip Block))) m [()])
-> StateT (Map Vertex (NodeChannels m Block (Tip Block))) m [[()]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (Graph -> [(Vertex, [Vertex])]
forall i e. Ix i => Array i e -> [(i, e)]
assocs Graph
g) (((Vertex, [Vertex])
  -> StateT (Map Vertex (NodeChannels m Block (Tip Block))) m [()])
 -> StateT (Map Vertex (NodeChannels m Block (Tip Block))) m [[()]])
-> ((Vertex, [Vertex])
    -> StateT (Map Vertex (NodeChannels m Block (Tip Block))) m [()])
-> StateT (Map Vertex (NodeChannels m Block (Tip Block))) m [[()]]
forall a b. (a -> b) -> a -> b
$ \(Vertex
i, [Vertex]
peers) -> do
    let isCore :: Bool
isCore = Vertex
i Vertex -> [Vertex] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ((Vertex, Chain Block) -> Vertex)
-> [(Vertex, Chain Block)] -> [Vertex]
forall a b. (a -> b) -> [a] -> [b]
map (Vertex, Chain Block) -> Vertex
forall a b. (a, b) -> a
fst [(Vertex, Chain Block)]
cs
        delay :: DiffTime
delay  = if Bool
isCore then DiffTime
coreTrDelay else DiffTime
relayTrDelay
    [Vertex]
-> (Vertex
    -> StateT (Map Vertex (NodeChannels m Block (Tip Block))) m ())
-> StateT (Map Vertex (NodeChannels m Block (Tip Block))) m [()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Vertex]
peers ((Vertex
  -> StateT (Map Vertex (NodeChannels m Block (Tip Block))) m ())
 -> StateT (Map Vertex (NodeChannels m Block (Tip Block))) m [()])
-> (Vertex
    -> StateT (Map Vertex (NodeChannels m Block (Tip Block))) m ())
-> StateT (Map Vertex (NodeChannels m Block (Tip Block))) m [()]
forall a b. (a -> b) -> a -> b
$ \Vertex
j -> do
      let isCore' :: Bool
isCore' = Vertex
j Vertex -> [Vertex] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ((Vertex, Chain Block) -> Vertex)
-> [(Vertex, Chain Block)] -> [Vertex]
forall a b. (a -> b) -> [a] -> [b]
map (Vertex, Chain Block) -> Vertex
forall a b. (a, b) -> a
fst [(Vertex, Chain Block)]
cs
          delay' :: DiffTime
delay'  = if Bool
isCore' then DiffTime
coreTrDelay else DiffTime
relayTrDelay
      (cij, cji) <- m (NodeChannels m Block (Tip Block),
   NodeChannels m Block (Tip Block))
-> StateT
     (Map Vertex (NodeChannels m Block (Tip Block)))
     m
     (NodeChannels m Block (Tip Block),
      NodeChannels m Block (Tip Block))
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (Map Vertex (NodeChannels m Block (Tip Block))) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (NodeChannels m Block (Tip Block),
    NodeChannels m Block (Tip Block))
 -> StateT
      (Map Vertex (NodeChannels m Block (Tip Block)))
      m
      (NodeChannels m Block (Tip Block),
       NodeChannels m Block (Tip Block)))
-> m (NodeChannels m Block (Tip Block),
      NodeChannels m Block (Tip Block))
-> StateT
     (Map Vertex (NodeChannels m Block (Tip Block)))
     m
     (NodeChannels m Block (Tip Block),
      NodeChannels m Block (Tip Block))
forall a b. (a -> b) -> a -> b
$ DiffTime
-> DiffTime
-> m (NodeChannels m Block (Tip Block),
      NodeChannels m Block (Tip Block))
forall {k} {k2} (block :: k) (tip :: k2) (m :: * -> *).
(MonadSTM m, MonadDelay m) =>
DiffTime
-> DiffTime
-> m (NodeChannels m block tip, NodeChannels m block tip)
createOneWaySubscriptionChannels DiffTime
delay DiffTime
delay'
      modify' (Map.adjust (<> cij) i . Map.adjust (<> cji) j)

  -- run each node
  forM_ vs $ \Vertex
i ->
    m () -> m (ThreadId m)
forall (m :: * -> *). MonadFork m => m () -> m (ThreadId m)
forkIO (m () -> m (ThreadId m)) -> m () -> m (ThreadId m)
forall a b. (a -> b) -> a -> b
$ m () -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
      case Vertex
i Vertex -> [(Vertex, Chain Block)] -> Maybe (Chain Block)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
`lookup` [(Vertex, Chain Block)]
cs of
        Just Chain Block
chain ->
          NodeId
-> DiffTime
-> [Block]
-> NodeChannels m Block (Tip Block)
-> m (StrictTVar m (ChainProducerState Block))
forall (m :: * -> *).
(MonadDelay m, MonadLabelledSTM m, MonadFork m, MonadThrow m,
 MonadTimer m, MonadSay m) =>
NodeId
-> DiffTime
-> [Block]
-> NodeChannels m Block (Tip Block)
-> m (StrictTVar m (ChainProducerState Block))
coreNode  (Vertex -> NodeId
CoreId Vertex
i) DiffTime
slotDuration (Chain Block -> [Block]
forall block. Chain block -> [block]
Chain.toOldestFirst Chain Block
chain) (Map Vertex (NodeChannels m Block (Tip Block))
channs' Map Vertex (NodeChannels m Block (Tip Block))
-> Vertex -> NodeChannels m Block (Tip Block)
forall k a. Ord k => Map k a -> k -> a
Map.! Vertex
i)
          m (StrictTVar m (ChainProducerState Block))
-> (StrictTVar m (ChainProducerState Block) -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= NodeId
-> Probe m (NodeId, Chain Block)
-> StrictTVar m (ChainProducerState Block)
-> m ()
forall (m :: * -> *) block.
(HasHeader block, MonadSTM m) =>
NodeId
-> StrictTVar m [(NodeId, Chain block)]
-> StrictTVar m (ChainProducerState block)
-> m ()
observeChainProducerState (Vertex -> NodeId
CoreId Vertex
i) Probe m (NodeId, Chain Block)
probe
        Maybe (Chain Block)
Nothing ->
          NodeId
-> Chain Block
-> NodeChannels m Block (Tip Block)
-> m (StrictTVar m (ChainProducerState Block))
forall (m :: * -> *) block.
(MonadFork m, MonadTimer m, MonadThrow m, MonadSay m,
 HasFullHeader block, Show block, ShowProxy block) =>
NodeId
-> Chain block
-> NodeChannels m block (Tip block)
-> m (StrictTVar m (ChainProducerState block))
relayNode (Vertex -> NodeId
RelayId Vertex
i) Chain Block
forall block. Chain block
Genesis (Map Vertex (NodeChannels m Block (Tip Block))
channs' Map Vertex (NodeChannels m Block (Tip Block))
-> Vertex -> NodeChannels m Block (Tip Block)
forall k a. Ord k => Map k a -> k -> a
Map.! Vertex
i)
          m (StrictTVar m (ChainProducerState Block))
-> (StrictTVar m (ChainProducerState Block) -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= NodeId
-> Probe m (NodeId, Chain Block)
-> StrictTVar m (ChainProducerState Block)
-> m ()
forall (m :: * -> *) block.
(HasHeader block, MonadSTM m) =>
NodeId
-> StrictTVar m [(NodeId, Chain block)]
-> StrictTVar m (ChainProducerState block)
-> m ()
observeChainProducerState (Vertex -> NodeId
RelayId Vertex
i) Probe m (NodeId, Chain Block)
probe

  --FIXME: we have to wait for these nodes to finish!
  -- As written, this is going to termiate immediately

data NetworkTest = NetworkTest
  { NetworkTest -> TestNetworkGraph
networkTestGraph        :: TestNetworkGraph
  , NetworkTest -> DiffTime
networkTestSlotDuration :: DiffTime
  , NetworkTest -> DiffTime
networkTestCoreTrDelay  :: DiffTime
  , NetworkTest -> DiffTime
networkTestRelayTrDelay :: DiffTime
  }

instance Arbitrary NetworkTest where
  arbitrary :: Gen NetworkTest
arbitrary = TestNetworkGraph -> DiffTime -> DiffTime -> DiffTime -> NetworkTest
NetworkTest (TestNetworkGraph
 -> DiffTime -> DiffTime -> DiffTime -> NetworkTest)
-> Gen TestNetworkGraph
-> Gen (DiffTime -> DiffTime -> DiffTime -> NetworkTest)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen TestNetworkGraph
forall a. Arbitrary a => Gen a
arbitrary Gen (DiffTime -> DiffTime -> DiffTime -> NetworkTest)
-> Gen DiffTime -> Gen (DiffTime -> DiffTime -> NetworkTest)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen DiffTime
duration Gen (DiffTime -> DiffTime -> NetworkTest)
-> Gen DiffTime -> Gen (DiffTime -> NetworkTest)
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen DiffTime
duration Gen (DiffTime -> NetworkTest) -> Gen DiffTime -> Gen NetworkTest
forall a b. Gen (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen DiffTime
duration
    where
      duration :: Gen DiffTime
duration = (Micro -> DiffTime
forall a b. (Real a, Fractional b) => a -> b
realToFrac :: Micro -> DiffTime)
               (Micro -> DiffTime)
-> (Positive Micro -> Micro) -> Positive Micro -> DiffTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Positive Micro -> Micro
forall a. Positive a -> a
getPositive (Positive Micro -> DiffTime)
-> Gen (Positive Micro) -> Gen DiffTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (Positive Micro)
forall a. Arbitrary a => Gen a
arbitrary

instance Show NetworkTest where
  show :: NetworkTest -> TestName
show (NetworkTest TestNetworkGraph
g DiffTime
slotDuration DiffTime
coreDelay DiffTime
relayDelay) =
      TestName
"NetworkTest { networkTestGraph=" TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ TestNetworkGraph -> TestName
forall a. Show a => a -> TestName
show TestNetworkGraph
g
      TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ TestName
", networkTestSlotDuration=" TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ DiffTime -> TestName
forall a. Show a => a -> TestName
show DiffTime
slotDuration
      TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ TestName
", networkTestCoreTrDelay=" TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ DiffTime -> TestName
forall a. Show a => a -> TestName
show DiffTime
coreDelay
      TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ TestName
", networkTestRelayTrDealy=" TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ DiffTime -> TestName
forall a. Show a => a -> TestName
show DiffTime
relayDelay TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ TestName
"}"

prop_networkGraph :: NetworkTest -> Property
prop_networkGraph :: NetworkTest -> Property
prop_networkGraph (NetworkTest g :: TestNetworkGraph
g@(TestNetworkGraph Graph
graph [(Vertex, Chain Block)]
cs) DiffTime
slotDuration DiffTime
coreTrDelay DiffTime
relayTrDelay) =
  let vs :: [Vertex]
vs = Graph -> [Vertex]
vertices Graph
graph
      es :: [Edge]
es = Graph -> [Edge]
edges Graph
graph
      gs :: [Graph]
gs = (Vertex -> Graph) -> [Vertex] -> [Graph]
forall a b. (a -> b) -> [a] -> [b]
map (\Vertex
i -> Edge -> Edge -> [Edge] -> Graph
removeEdge ([Vertex] -> Vertex
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum [Vertex]
vs, [Vertex] -> Vertex
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [Vertex]
vs) ([Edge]
es [Edge] -> Vertex -> Edge
forall a. HasCallStack => [a] -> Vertex -> a
!! Vertex
i) [Edge]
es) [Vertex
0..[Edge] -> Vertex
forall a. [a] -> Vertex
forall (t :: * -> *) a. Foldable t => t a -> Vertex
length [Edge]
es Vertex -> Vertex -> Vertex
forall a. Num a => a -> a -> a
- Vertex
1]
      (Vertex
cc :: Int) = (Vertex -> Graph -> Vertex) -> Vertex -> [Graph] -> Vertex
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' (\Vertex
x Graph
y -> if Graph -> Bool
isDisconnected Graph
y then Vertex
x Vertex -> Vertex -> Vertex
forall a. Num a => a -> a -> a
+ Vertex
1 else Vertex
x) Vertex
0 [Graph]
gs

      probes :: [(NodeId, Chain Block)]
probes = (forall s. IOSim s [(NodeId, Chain Block)])
-> [(NodeId, Chain Block)]
forall a. (forall s. IOSim s a) -> a
Sim.runSimOrThrow ((forall s. IOSim s [(NodeId, Chain Block)])
 -> [(NodeId, Chain Block)])
-> (forall s. IOSim s [(NodeId, Chain Block)])
-> [(NodeId, Chain Block)]
forall a b. (a -> b) -> a -> b
$ (Probe (IOSim s) (NodeId, Chain Block) -> IOSim s ())
-> IOSim s [(NodeId, Chain Block)]
forall (m :: * -> *) x. MonadSTM m => (Probe m x -> m ()) -> m [x]
withProbe ((Probe (IOSim s) (NodeId, Chain Block) -> IOSim s ())
 -> IOSim s [(NodeId, Chain Block)])
-> (Probe (IOSim s) (NodeId, Chain Block) -> IOSim s ())
-> IOSim s [(NodeId, Chain Block)]
forall a b. (a -> b) -> a -> b
$
                 TestNetworkGraph
-> DiffTime
-> DiffTime
-> DiffTime
-> Probe (IOSim s) (NodeId, Chain Block)
-> IOSim s ()
forall (m :: * -> *).
(MonadDelay m, MonadLabelledSTM m, MonadFork m, MonadThrow m,
 MonadSay m, MonadTimer m) =>
TestNetworkGraph
-> DiffTime
-> DiffTime
-> DiffTime
-> Probe m (NodeId, Chain Block)
-> m ()
networkGraphSim TestNetworkGraph
g DiffTime
slotDuration DiffTime
coreTrDelay DiffTime
relayTrDelay
      dict :: Map NodeId (Chain Block)
      dict :: Map NodeId (Chain Block)
dict = ([Chain Block] -> Maybe (Chain Block))
-> Map NodeId [Chain Block] -> Map NodeId (Chain Block)
forall a b k. (a -> Maybe b) -> Map k a -> Map k b
Map.mapMaybe [Chain Block] -> Maybe (Chain Block)
forall a. [a] -> Maybe a
listToMaybe ([(NodeId, Chain Block)] -> Map NodeId [Chain Block]
forall a. [(NodeId, a)] -> Map NodeId [a]
partitionProbe [(NodeId, Chain Block)]
probes)
      chains :: [Chain Block]
chains = Map NodeId (Chain Block) -> [Chain Block]
forall k a. Map k a -> [a]
Map.elems Map NodeId (Chain Block)
dict
  in  Double -> Bool -> TestName -> Property -> Property
forall prop.
Testable prop =>
Double -> Bool -> TestName -> prop -> Property
cover Double
50 ([Vertex] -> Vertex
forall a. [a] -> Vertex
forall (t :: * -> *) a. Foldable t => t a -> Vertex
length [Vertex]
vs Vertex -> Vertex -> Bool
forall a. Ord a => a -> a -> Bool
> Vertex
10) TestName
"more than 10 vertices"
    (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ Double -> Bool -> TestName -> Property -> Property
forall prop.
Testable prop =>
Double -> Bool -> TestName -> prop -> Property
cover Double
75 (Vertex
100 Vertex -> Vertex -> Vertex
forall a. Num a => a -> a -> a
* [(Vertex, Chain Block)] -> Vertex
forall a. [a] -> Vertex
forall (t :: * -> *) a. Foldable t => t a -> Vertex
length [(Vertex, Chain Block)]
cs Vertex -> Vertex -> Vertex
forall a. Integral a => a -> a -> a
`div` [Vertex] -> Vertex
forall a. [a] -> Vertex
forall (t :: * -> *) a. Foldable t => t a -> Vertex
length [Vertex]
vs Vertex -> Vertex -> Bool
forall a. Ord a => a -> a -> Bool
> Vertex
50) TestName
"more than 50% of core nodes"
    -- Let call a bidirectional connection (two edges `e` and `swap e`) critical
    -- iff when removed the graph becomes disconnected. The distribution looks
    -- not that bad:
    -- 28% 4
    -- 21% 0
    -- 13% 6
    -- 11% 10
    -- 11% 2
    -- 10% 8
    --  3% 14
    --  2% 16
    --  1% 20
    (Property -> Property) -> Property -> Property
forall a b. (a -> b) -> a -> b
$ Double -> Bool -> TestName -> Bool -> Property
forall prop.
Testable prop =>
Double -> Bool -> TestName -> prop -> Property
cover Double
50 (Vertex
cc Vertex -> Vertex -> Bool
forall a. Ord a => a -> a -> Bool
> Vertex
0) TestName
"has more than one critical connection (when removed the network graph becomes disconnected)"
    -- TODO: It might be good to check [closness
    -- centrality](https://en.wikipedia.org/wiki/Closeness_centrality) of
    -- generated graphs; we'd like to have some nodes that are on average very far
    -- from other nodes.
    (Bool -> Property) -> Bool -> Property
forall a b. (a -> b) -> a -> b
$ (Bool -> Chain Block -> Bool)
-> Bool -> Map NodeId (Chain Block) -> Bool
forall a b k. (a -> b -> a) -> a -> Map k b -> a
Map.foldl' (\Bool
v Chain Block
c -> (Chain Block -> Chain Block -> Chain Block)
-> Chain Block -> [Chain Block] -> Chain Block
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' Chain Block -> Chain Block -> Chain Block
forall block.
HasHeader block =>
Chain block -> Chain block -> Chain block
Chain.selectChain Chain Block
c [Chain Block]
chains Chain Block -> Chain Block -> Bool
forall a. Eq a => a -> a -> Bool
== Chain Block
c Bool -> Bool -> Bool
&& Bool
v) Bool
True Map NodeId (Chain Block)
dict
  where
  -- remove two edges: `a -> b` and `b -> a`
  removeEdge :: Bounds -> Edge -> [Edge] -> Graph
  removeEdge :: Edge -> Edge -> [Edge] -> Graph
removeEdge Edge
bs Edge
e [Edge]
es =
    let es' :: [Edge]
es' = (Edge -> Bool) -> [Edge] -> [Edge]
forall a. (a -> Bool) -> [a] -> [a]
filter (\Edge
e' -> Edge
e Edge -> Edge -> Bool
forall a. Eq a => a -> a -> Bool
/= Edge
e' Bool -> Bool -> Bool
&& Edge -> Edge
forall a b. (a, b) -> (b, a)
swap Edge
e Edge -> Edge -> Bool
forall a. Eq a => a -> a -> Bool
/= Edge
e') [Edge]
es
    in Edge -> [Edge] -> Graph
buildG Edge
bs [Edge]
es'

-- graph is disconnected if it has strictly more than one component
isDisconnected :: Graph -> Bool
isDisconnected :: Graph -> Bool
isDisconnected Graph
gr = case Graph -> [Tree Vertex]
components Graph
gr of
  []       -> Bool
False
  (Tree Vertex
_ : []) -> Bool
False
  [Tree Vertex]
_        -> Bool
True

arbitraryAcyclicGraph :: Gen Int -> Gen Int -> Float -> Gen Graph
arbitraryAcyclicGraph :: Gen Vertex -> Gen Vertex -> Float -> Gen Graph
arbitraryAcyclicGraph Gen Vertex
genNRanks Gen Vertex
genNPerRank Float
edgeChance = do
    nranks    <- Gen Vertex
genNRanks
    rankSizes <- replicateM nranks genNPerRank
    let rankStarts = (Vertex -> Vertex -> Vertex) -> Vertex -> [Vertex] -> [Vertex]
forall b a. (b -> a -> b) -> b -> [a] -> [b]
scanl Vertex -> Vertex -> Vertex
forall a. Num a => a -> a -> a
(+) Vertex
0 [Vertex]
rankSizes
        rankRanges = Vertex -> [Edge] -> [Edge]
forall a. Vertex -> [a] -> [a]
drop Vertex
1 ([Vertex] -> [Vertex] -> [Edge]
forall a b. [a] -> [b] -> [(a, b)]
zip [Vertex]
rankStarts ([Vertex] -> [Vertex]
forall a. HasCallStack => [a] -> [a]
tail [Vertex]
rankStarts))
        totalRange = [Vertex] -> Vertex
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Vertex]
rankSizes
    rankEdges <- mapM (uncurry genRank) rankRanges
    return $ buildG (0, totalRange-1) (concat rankEdges)
  where
    genRank :: Vertex -> Vertex -> Gen [Edge]
    genRank :: Vertex -> Vertex -> Gen [Edge]
genRank Vertex
rankStart Vertex
rankEnd =
      (Edge -> Gen Bool) -> [Edge] -> Gen [Edge]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM (Gen Bool -> Edge -> Gen Bool
forall a b. a -> b -> a
const (Float -> Gen Bool
pick Float
edgeChance))
        [ (Vertex
i,Vertex
j)
        | Vertex
i <- [Vertex
0..Vertex
rankStartVertex -> Vertex -> Vertex
forall a. Num a => a -> a -> a
-Vertex
1]
        , Vertex
j <- [Vertex
rankStart..Vertex
rankEndVertex -> Vertex -> Vertex
forall a. Num a => a -> a -> a
-Vertex
1]
        ]

    pick :: Float -> Gen Bool
    pick :: Float -> Gen Bool
pick Float
chance = (Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
< Float
chance) (Float -> Bool) -> Gen Float -> Gen Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Float, Float) -> Gen Float
forall a. Random a => (a, a) -> Gen a
choose (Float
0,Float
1)


arbitraryAcyclicGraphSmall :: Gen Graph
arbitraryAcyclicGraphSmall :: Gen Graph
arbitraryAcyclicGraphSmall =
    (Vertex -> Gen Graph) -> Gen Graph
forall a. (Vertex -> Gen a) -> Gen a
sized ((Vertex -> Gen Graph) -> Gen Graph)
-> (Vertex -> Gen Graph) -> Gen Graph
forall a b. (a -> b) -> a -> b
$ \Vertex
sz ->
    Gen Vertex -> Gen Vertex -> Float -> Gen Graph
arbitraryAcyclicGraph (Edge -> Gen Vertex
forall a. Random a => (a, a) -> Gen a
choose (Vertex
2, Vertex
8 Vertex -> Vertex -> Vertex
forall a. Ord a => a -> a -> a
`min` (Vertex
sz Vertex -> Vertex -> Vertex
forall a. Integral a => a -> a -> a
`div` Vertex
3)))
                          (Edge -> Gen Vertex
forall a. Random a => (a, a) -> Gen a
choose (Vertex
1, Vertex
8 Vertex -> Vertex -> Vertex
forall a. Ord a => a -> a -> a
`min` (Vertex
sz Vertex -> Vertex -> Vertex
forall a. Integral a => a -> a -> a
`div` Vertex
3)))
                          Float
0.3

genConnectedBidirectionalGraph :: Gen Graph
genConnectedBidirectionalGraph :: Gen Graph
genConnectedBidirectionalGraph = do
  g <- Gen Graph
arbitraryAcyclicGraphSmall
  let g' = ([Vertex] -> [Vertex] -> [Vertex])
-> Graph -> [(Vertex, [Vertex])] -> Graph
forall i e a.
Ix i =>
(e -> a -> e) -> Array i e -> [(i, a)] -> Array i e
accum [Vertex] -> [Vertex] -> [Vertex]
forall a. [a] -> [a] -> [a]
(++) Graph
g (Graph -> [(Vertex, [Vertex])]
forall i e. Ix i => Array i e -> [(i, e)]
assocs (Graph -> [(Vertex, [Vertex])]) -> Graph -> [(Vertex, [Vertex])]
forall a b. (a -> b) -> a -> b
$ Graph -> Graph
transposeG Graph
g)
  connectGraphG g'


--
-- Probe mini-abstraction
--

-- | Where returning results directly is not convenient, we can build up
-- a trace of events we want to observe, and can do probe output from
-- multiple threads.
--
type Probe m x = StrictTVar m [x]

withProbe :: MonadSTM m => (Probe m x -> m ()) -> m [x]
withProbe :: forall (m :: * -> *) x. MonadSTM m => (Probe m x -> m ()) -> m [x]
withProbe Probe m x -> m ()
action = do
    probe <- [x] -> m (Probe m x)
forall (m :: * -> *) a. MonadSTM m => a -> m (StrictTVar m a)
newTVarIO []
    action probe
    reverse <$> atomically (readTVar probe)

probeOutput :: MonadSTM m => Probe m x -> x -> m ()
probeOutput :: forall (m :: * -> *) x. MonadSTM m => Probe m x -> x -> m ()
probeOutput Probe m x
probe x
x = STM m () -> m ()
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (Probe m x -> ([x] -> [x]) -> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> (a -> a) -> STM m ()
modifyTVar Probe m x
probe (x
xx -> [x] -> [x]
forall a. a -> [a] -> [a]
:))