{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Test.ThreadNet.Util.NodeTopology (
    -- * Node Topology
    NodeTopology (..)
  , coreNodeIdNeighbors
  , edgesNodeTopology
  , genNodeTopology
  , mapNodeTopology
  , meshNodeTopology
  , minimumDegreeNodeTopology
  , shrinkNodeTopology
  , unionNodeTopology
  ) where

import           Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import           Data.Set (Set)
import qualified Data.Set as Set
import           GHC.Generics (Generic)
import           GHC.Stack (HasCallStack)
import           Ouroboros.Consensus.Node.ProtocolInfo
import           Ouroboros.Consensus.NodeId
import           Ouroboros.Consensus.Util.Condense
import           Ouroboros.Consensus.Util.Orphans ()
import           Quiet (Quiet (..))
import           Test.QuickCheck

{-------------------------------------------------------------------------------
  Node Topologies
-------------------------------------------------------------------------------}

-- | Which /lesser/ nodes each node connects to
--
-- INVARIANT: for each mapping @n -> ms@, @n > m@ for each @m@ in @ms@
--
-- INVARIANT: only the mapping for @n = CoreNodeId 0@ is empty
--
-- INVARIANT: there is a mapping for each @CoreNodeId@ in the test, @0 .. n -
-- 1@
--
-- Note that every node is connected to every other but not necessarily
-- directly. In other words, the topology is always a single network of nodes,
-- which is realistic. With other test configuration components, such as
-- network partitions, the network may split (temporarily or not) into separate
-- connected components during the execution, but the base topology is
-- connected.
--
newtype NodeTopology =
    NodeTopology {NodeTopology -> Map CoreNodeId (Set CoreNodeId)
unNodeTopology :: Map CoreNodeId (Set CoreNodeId)}
  deriving (NodeTopology -> NodeTopology -> Bool
(NodeTopology -> NodeTopology -> Bool)
-> (NodeTopology -> NodeTopology -> Bool) -> Eq NodeTopology
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: NodeTopology -> NodeTopology -> Bool
== :: NodeTopology -> NodeTopology -> Bool
$c/= :: NodeTopology -> NodeTopology -> Bool
/= :: NodeTopology -> NodeTopology -> Bool
Eq, (forall x. NodeTopology -> Rep NodeTopology x)
-> (forall x. Rep NodeTopology x -> NodeTopology)
-> Generic NodeTopology
forall x. Rep NodeTopology x -> NodeTopology
forall x. NodeTopology -> Rep NodeTopology x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. NodeTopology -> Rep NodeTopology x
from :: forall x. NodeTopology -> Rep NodeTopology x
$cto :: forall x. Rep NodeTopology x -> NodeTopology
to :: forall x. Rep NodeTopology x -> NodeTopology
Generic)
  deriving (Int -> NodeTopology -> ShowS
[NodeTopology] -> ShowS
NodeTopology -> String
(Int -> NodeTopology -> ShowS)
-> (NodeTopology -> String)
-> ([NodeTopology] -> ShowS)
-> Show NodeTopology
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> NodeTopology -> ShowS
showsPrec :: Int -> NodeTopology -> ShowS
$cshow :: NodeTopology -> String
show :: NodeTopology -> String
$cshowList :: [NodeTopology] -> ShowS
showList :: [NodeTopology] -> ShowS
Show) via Quiet NodeTopology

instance Condense NodeTopology where
  condense :: NodeTopology -> String
condense top :: NodeTopology
top@(NodeTopology Map CoreNodeId (Set CoreNodeId)
m)
    | NodeTopology
top NodeTopology -> NodeTopology -> Bool
forall a. Eq a => a -> a -> Bool
== NodeTopology
mesh = String
"meshNodeTopology (NumCoreNodes " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (Map CoreNodeId (Set CoreNodeId) -> Int
forall k a. Map k a -> Int
Map.size Map CoreNodeId (Set CoreNodeId)
m) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"
    | Bool
otherwise = [(NodeId, Set NodeId)] -> String
forall a. Condense a => a -> String
condense
      [ (CoreNodeId -> NodeId
fromCoreNodeId CoreNodeId
nid, (CoreNodeId -> NodeId) -> Set CoreNodeId -> Set NodeId
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map CoreNodeId -> NodeId
fromCoreNodeId Set CoreNodeId
nids)
      | (CoreNodeId
nid, Set CoreNodeId
nids) <- Map CoreNodeId (Set CoreNodeId) -> [(CoreNodeId, Set CoreNodeId)]
forall k a. Map k a -> [(k, a)]
Map.toAscList Map CoreNodeId (Set CoreNodeId)
m ]
    where
      mesh :: NodeTopology
mesh = NumCoreNodes -> NodeTopology
meshNodeTopology (Word64 -> NumCoreNodes
NumCoreNodes (Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Map CoreNodeId (Set CoreNodeId) -> Int
forall k a. Map k a -> Int
Map.size Map CoreNodeId (Set CoreNodeId)
m)))

-- | Connect every pair of nodes
--
meshNodeTopology ::
     NumCoreNodes
     -- ^ PRECONDITION: non-negative
  -> NodeTopology
meshNodeTopology :: NumCoreNodes -> NodeTopology
meshNodeTopology NumCoreNodes
numCoreNodes =
    Map CoreNodeId (Set CoreNodeId) -> NodeTopology
NodeTopology (Map CoreNodeId (Set CoreNodeId) -> NodeTopology)
-> Map CoreNodeId (Set CoreNodeId) -> NodeTopology
forall a b. (a -> b) -> a -> b
$
    [(CoreNodeId, Set CoreNodeId)] -> Map CoreNodeId (Set CoreNodeId)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(CoreNodeId, Set CoreNodeId)] -> Map CoreNodeId (Set CoreNodeId))
-> [(CoreNodeId, Set CoreNodeId)]
-> Map CoreNodeId (Set CoreNodeId)
forall a b. (a -> b) -> a -> b
$
    [ (CoreNodeId
nid, [CoreNodeId] -> Set CoreNodeId
forall a. Ord a => [a] -> Set a
Set.fromList ([CoreNodeId] -> Set CoreNodeId) -> [CoreNodeId] -> Set CoreNodeId
forall a b. (a -> b) -> a -> b
$ NumCoreNodes -> [CoreNodeId]
enumCoreNodes (Word64 -> NumCoreNodes
NumCoreNodes Word64
i))
    | nid :: CoreNodeId
nid@(CoreNodeId Word64
i) <- NumCoreNodes -> [CoreNodeId]
enumCoreNodes NumCoreNodes
numCoreNodes ]

-- | Generate a 'NodeTopology' consistent with the given properties
--
genNodeTopology ::
     HasCallStack
  => NumCoreNodes
     -- ^ PRECONDITION: non-negative
  -> Gen NodeTopology
genNodeTopology :: HasCallStack => NumCoreNodes -> Gen NodeTopology
genNodeTopology numCoreNodes :: NumCoreNodes
numCoreNodes@(NumCoreNodes Word64
n)
  | Word64
n Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
< Word64
0 = String -> Gen NodeTopology
forall a. HasCallStack => String -> a
error (String -> Gen NodeTopology) -> String -> Gen NodeTopology
forall a b. (a -> b) -> a -> b
$ String
"Unsatisfiable parameters: "
    String -> ShowS
forall a. [a] -> [a] -> [a]
++ NumCoreNodes -> String
forall a. Show a => a -> String
show NumCoreNodes
numCoreNodes

  | Bool
otherwise = do
    let genNeighbors :: CoreNodeId -> Gen (CoreNodeId, Set CoreNodeId)
genNeighbors me :: CoreNodeId
me@(CoreNodeId Word64
i) = case Word64
i of
          Word64
0 -> (CoreNodeId, Set CoreNodeId) -> Gen (CoreNodeId, Set CoreNodeId)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CoreNodeId
me, Set CoreNodeId
forall a. Set a
Set.empty)
          Word64
_ ->
            ([CoreNodeId] -> (CoreNodeId, Set CoreNodeId))
-> Gen [CoreNodeId] -> Gen (CoreNodeId, Set CoreNodeId)
forall a b. (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((,) CoreNodeId
me (Set CoreNodeId -> (CoreNodeId, Set CoreNodeId))
-> ([CoreNodeId] -> Set CoreNodeId)
-> [CoreNodeId]
-> (CoreNodeId, Set CoreNodeId)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [CoreNodeId] -> Set CoreNodeId
forall a. Ord a => [a] -> Set a
Set.fromList) (Gen [CoreNodeId] -> Gen (CoreNodeId, Set CoreNodeId))
-> Gen [CoreNodeId] -> Gen (CoreNodeId, Set CoreNodeId)
forall a b. (a -> b) -> a -> b
$
            (Gen [CoreNodeId] -> ([CoreNodeId] -> Bool) -> Gen [CoreNodeId])
-> ([CoreNodeId] -> Bool) -> Gen [CoreNodeId] -> Gen [CoreNodeId]
forall a b c. (a -> b -> c) -> b -> a -> c
flip Gen [CoreNodeId] -> ([CoreNodeId] -> Bool) -> Gen [CoreNodeId]
forall a. Gen a -> (a -> Bool) -> Gen a
suchThat (Bool -> Bool
not (Bool -> Bool) -> ([CoreNodeId] -> Bool) -> [CoreNodeId] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [CoreNodeId] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) (Gen [CoreNodeId] -> Gen [CoreNodeId])
-> Gen [CoreNodeId] -> Gen [CoreNodeId]
forall a b. (a -> b) -> a -> b
$
            [CoreNodeId] -> Gen [CoreNodeId]
forall a. [a] -> Gen [a]
sublistOf (NumCoreNodes -> [CoreNodeId]
enumCoreNodes (Word64 -> NumCoreNodes
NumCoreNodes Word64
i))

    ([(CoreNodeId, Set CoreNodeId)] -> NodeTopology)
-> Gen [(CoreNodeId, Set CoreNodeId)] -> Gen NodeTopology
forall a b. (a -> b) -> Gen a -> Gen b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Map CoreNodeId (Set CoreNodeId) -> NodeTopology
NodeTopology (Map CoreNodeId (Set CoreNodeId) -> NodeTopology)
-> ([(CoreNodeId, Set CoreNodeId)]
    -> Map CoreNodeId (Set CoreNodeId))
-> [(CoreNodeId, Set CoreNodeId)]
-> NodeTopology
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(CoreNodeId, Set CoreNodeId)] -> Map CoreNodeId (Set CoreNodeId)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList) (Gen [(CoreNodeId, Set CoreNodeId)] -> Gen NodeTopology)
-> Gen [(CoreNodeId, Set CoreNodeId)] -> Gen NodeTopology
forall a b. (a -> b) -> a -> b
$
      (CoreNodeId -> Gen (CoreNodeId, Set CoreNodeId))
-> [CoreNodeId] -> Gen [(CoreNodeId, Set CoreNodeId)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM CoreNodeId -> Gen (CoreNodeId, Set CoreNodeId)
genNeighbors (NumCoreNodes -> [CoreNodeId]
enumCoreNodes NumCoreNodes
numCoreNodes)

-- | Shrink a node topology
--
-- The new topologies must be usable with the same number of nodes and slots as
-- the old topology
--
shrinkNodeTopology :: NodeTopology -> [NodeTopology]
shrinkNodeTopology :: NodeTopology -> [NodeTopology]
shrinkNodeTopology top :: NodeTopology
top@(NodeTopology Map CoreNodeId (Set CoreNodeId)
m)
    | NodeTopology
top NodeTopology -> NodeTopology -> Bool
forall a. Eq a => a -> a -> Bool
== NodeTopology
mesh = []
    | Bool
otherwise = [NodeTopology
mesh]
  where
    mesh :: NodeTopology
mesh = NumCoreNodes -> NodeTopology
meshNodeTopology (Word64 -> NumCoreNodes
NumCoreNodes (Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Map CoreNodeId (Set CoreNodeId) -> Int
forall k a. Map k a -> Int
Map.size Map CoreNodeId (Set CoreNodeId)
m)))
    -- TODO more sophisticated shrinks. I anticipate that they'll need to use
    -- 'Test.QuickCheck.Shrinking' or else risk very slow responses

-- | The neighbors of this node
--
coreNodeIdNeighbors ::
     HasCallStack
  => NodeTopology -> CoreNodeId -> [CoreNodeId]
coreNodeIdNeighbors :: HasCallStack => NodeTopology -> CoreNodeId -> [CoreNodeId]
coreNodeIdNeighbors (NodeTopology Map CoreNodeId (Set CoreNodeId)
m) CoreNodeId
nid =
    case Maybe (Set CoreNodeId)
hit of
      Maybe (Set CoreNodeId)
Nothing      ->
          String -> [CoreNodeId]
forall a. HasCallStack => String -> a
error (String -> [CoreNodeId]) -> String -> [CoreNodeId]
forall a b. (a -> b) -> a -> b
$
          String
"invariant violated: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<>
          String
"could not find " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> (CoreNodeId, [(CoreNodeId, Set CoreNodeId)]) -> String
forall a. Condense a => a -> String
condense (CoreNodeId
nid, Map CoreNodeId (Set CoreNodeId) -> [(CoreNodeId, Set CoreNodeId)]
forall k a. Map k a -> [(k, a)]
Map.toList Map CoreNodeId (Set CoreNodeId)
m)
      Just Set CoreNodeId
lessers -> Set CoreNodeId -> [CoreNodeId]
forall a. Set a -> [a]
Set.toList Set CoreNodeId
lessers [CoreNodeId] -> [CoreNodeId] -> [CoreNodeId]
forall a. [a] -> [a] -> [a]
++ [CoreNodeId]
greaters
  where
    (Map CoreNodeId (Set CoreNodeId)
_, Maybe (Set CoreNodeId)
hit, Map CoreNodeId (Set CoreNodeId)
greaters0) = CoreNodeId
-> Map CoreNodeId (Set CoreNodeId)
-> (Map CoreNodeId (Set CoreNodeId), Maybe (Set CoreNodeId),
    Map CoreNodeId (Set CoreNodeId))
forall k a. Ord k => k -> Map k a -> (Map k a, Maybe a, Map k a)
Map.splitLookup CoreNodeId
nid Map CoreNodeId (Set CoreNodeId)
m
    greaters :: [CoreNodeId]
greaters = Map CoreNodeId (Set CoreNodeId) -> [CoreNodeId]
forall k a. Map k a -> [k]
Map.keys ((Set CoreNodeId -> Bool)
-> Map CoreNodeId (Set CoreNodeId)
-> Map CoreNodeId (Set CoreNodeId)
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter (CoreNodeId
nid CoreNodeId -> Set CoreNodeId -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member`) Map CoreNodeId (Set CoreNodeId)
greaters0)

-- | The edges in this topology
--
edgesNodeTopology :: NodeTopology -> [(CoreNodeId, CoreNodeId)]
edgesNodeTopology :: NodeTopology -> [(CoreNodeId, CoreNodeId)]
edgesNodeTopology (NodeTopology Map CoreNodeId (Set CoreNodeId)
m) =
    (((CoreNodeId, Set CoreNodeId) -> [(CoreNodeId, CoreNodeId)])
 -> [(CoreNodeId, Set CoreNodeId)] -> [(CoreNodeId, CoreNodeId)])
-> [(CoreNodeId, Set CoreNodeId)]
-> ((CoreNodeId, Set CoreNodeId) -> [(CoreNodeId, CoreNodeId)])
-> [(CoreNodeId, CoreNodeId)]
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((CoreNodeId, Set CoreNodeId) -> [(CoreNodeId, CoreNodeId)])
-> [(CoreNodeId, Set CoreNodeId)] -> [(CoreNodeId, CoreNodeId)]
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Map CoreNodeId (Set CoreNodeId) -> [(CoreNodeId, Set CoreNodeId)]
forall k a. Map k a -> [(k, a)]
Map.toList Map CoreNodeId (Set CoreNodeId)
m) (((CoreNodeId, Set CoreNodeId) -> [(CoreNodeId, CoreNodeId)])
 -> [(CoreNodeId, CoreNodeId)])
-> ((CoreNodeId, Set CoreNodeId) -> [(CoreNodeId, CoreNodeId)])
-> [(CoreNodeId, CoreNodeId)]
forall a b. (a -> b) -> a -> b
$ \(CoreNodeId
greater, Set CoreNodeId
lessers) ->
        (CoreNodeId -> (CoreNodeId, CoreNodeId))
-> [CoreNodeId] -> [(CoreNodeId, CoreNodeId)]
forall a b. (a -> b) -> [a] -> [b]
map ((CoreNodeId -> CoreNodeId -> (CoreNodeId, CoreNodeId))
-> CoreNodeId -> CoreNodeId -> (CoreNodeId, CoreNodeId)
forall a b c. (a -> b -> c) -> b -> a -> c
flip (,) CoreNodeId
greater) (Set CoreNodeId -> [CoreNodeId]
forall a. Set a -> [a]
Set.toList Set CoreNodeId
lessers)

-- | The neighbor count of the node with the fewest neighbors, unless there are
-- zero nodes
--
minimumDegreeNodeTopology :: NodeTopology -> Maybe Int
minimumDegreeNodeTopology :: NodeTopology -> Maybe Int
minimumDegreeNodeTopology top :: NodeTopology
top@(NodeTopology Map CoreNodeId (Set CoreNodeId)
m) =
    [Int] -> Maybe Int
check [ [CoreNodeId] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (HasCallStack => NodeTopology -> CoreNodeId -> [CoreNodeId]
NodeTopology -> CoreNodeId -> [CoreNodeId]
coreNodeIdNeighbors NodeTopology
top CoreNodeId
nid) | CoreNodeId
nid <- Map CoreNodeId (Set CoreNodeId) -> [CoreNodeId]
forall k a. Map k a -> [k]
Map.keys Map CoreNodeId (Set CoreNodeId)
m ]
  where
    check :: [Int] -> Maybe Int
check = \case
        []   -> Maybe Int
forall a. Maybe a
Nothing
        Int
x:[Int]
xs -> Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$ (Int -> Int -> Int) -> Int -> [Int] -> Int
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
x [Int]
xs

unionNodeTopology :: NodeTopology -> NodeTopology -> NodeTopology
unionNodeTopology :: NodeTopology -> NodeTopology -> NodeTopology
unionNodeTopology (NodeTopology Map CoreNodeId (Set CoreNodeId)
l) (NodeTopology Map CoreNodeId (Set CoreNodeId)
r) =
    Map CoreNodeId (Set CoreNodeId) -> NodeTopology
NodeTopology (Map CoreNodeId (Set CoreNodeId) -> NodeTopology)
-> Map CoreNodeId (Set CoreNodeId) -> NodeTopology
forall a b. (a -> b) -> a -> b
$ (Set CoreNodeId -> Set CoreNodeId -> Set CoreNodeId)
-> Map CoreNodeId (Set CoreNodeId)
-> Map CoreNodeId (Set CoreNodeId)
-> Map CoreNodeId (Set CoreNodeId)
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith Set CoreNodeId -> Set CoreNodeId -> Set CoreNodeId
forall a. Ord a => Set a -> Set a -> Set a
Set.union Map CoreNodeId (Set CoreNodeId)
l Map CoreNodeId (Set CoreNodeId)
r

mapNodeTopology :: (CoreNodeId -> CoreNodeId) -> NodeTopology -> NodeTopology
mapNodeTopology :: (CoreNodeId -> CoreNodeId) -> NodeTopology -> NodeTopology
mapNodeTopology CoreNodeId -> CoreNodeId
f NodeTopology
topo =
    Map CoreNodeId (Set CoreNodeId) -> NodeTopology
NodeTopology (Map CoreNodeId (Set CoreNodeId) -> NodeTopology)
-> Map CoreNodeId (Set CoreNodeId) -> NodeTopology
forall a b. (a -> b) -> a -> b
$ (Set CoreNodeId -> Set CoreNodeId -> Set CoreNodeId)
-> [(CoreNodeId, Set CoreNodeId)]
-> Map CoreNodeId (Set CoreNodeId)
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith Set CoreNodeId -> Set CoreNodeId -> Set CoreNodeId
forall a. Ord a => Set a -> Set a -> Set a
Set.union ([(CoreNodeId, Set CoreNodeId)] -> Map CoreNodeId (Set CoreNodeId))
-> [(CoreNodeId, Set CoreNodeId)]
-> Map CoreNodeId (Set CoreNodeId)
forall a b. (a -> b) -> a -> b
$
    [ CoreNodeId -> CoreNodeId
f CoreNodeId
l CoreNodeId -> CoreNodeId -> (CoreNodeId, Set CoreNodeId)
forall {a}. Ord a => a -> a -> (a, Set a)
`sortedSingleton` CoreNodeId -> CoreNodeId
f CoreNodeId
r
    | (CoreNodeId
l, CoreNodeId
r) <- NodeTopology -> [(CoreNodeId, CoreNodeId)]
edgesNodeTopology NodeTopology
topo
    ]
  where
    sortedSingleton :: a -> a -> (a, Set a)
sortedSingleton a
l a
r =
        if a
l a -> a -> Bool
forall a. Ord a => a -> a -> Bool
> a
r then (a
l, a -> Set a
forall a. a -> Set a
Set.singleton a
r) else (a
r, a -> Set a
forall a. a -> Set a
Set.singleton a
l)