{-# LANGUAGE BangPatterns   #-}
{-# LANGUAGE DerivingVia    #-}
{-# LANGUAGE NamedFieldPuns #-}

module Ouroboros.Network.PeerSelection.State.LocalRootPeers
  ( -- * Types
    LocalRootPeers (..)
  , LocalRootConfig (..)
  , HotValency (..)
  , WarmValency (..)
  , Config
    -- Export constructors for defining tests.
  , invariant
    -- * Basic operations
  , mapPeers
  , empty
  , null
  , size
  , member
  , hotTarget
  , warmTarget
  , fromGroups
  , toGroups
  , toGroupSets
  , toMap
  , keysSet
    -- * Special operations
  , clampToLimit
  ) where

import Prelude hiding (null)

import Data.Map.Strict (Map)
import Data.Map.Strict qualified as Map
import Data.Set (Set)
import Data.Set qualified as Set

import Ouroboros.Network.DiffusionMode
import Ouroboros.Network.PeerSelection.PeerAdvertise (PeerAdvertise)


---------------------------------------
-- Local root peer set representation
--

data LocalRootConfig extraFlags = LocalRootConfig {
    forall extraFlags. LocalRootConfig extraFlags -> PeerAdvertise
peerAdvertise       :: !PeerAdvertise,
    forall extraFlags. LocalRootConfig extraFlags -> DiffusionMode
diffusionMode       :: !DiffusionMode,
    forall extraFlags. LocalRootConfig extraFlags -> extraFlags
extraLocalRootFlags :: !extraFlags
  }
  deriving (Int -> LocalRootConfig extraFlags -> ShowS
[LocalRootConfig extraFlags] -> ShowS
LocalRootConfig extraFlags -> String
(Int -> LocalRootConfig extraFlags -> ShowS)
-> (LocalRootConfig extraFlags -> String)
-> ([LocalRootConfig extraFlags] -> ShowS)
-> Show (LocalRootConfig extraFlags)
forall extraFlags.
Show extraFlags =>
Int -> LocalRootConfig extraFlags -> ShowS
forall extraFlags.
Show extraFlags =>
[LocalRootConfig extraFlags] -> ShowS
forall extraFlags.
Show extraFlags =>
LocalRootConfig extraFlags -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall extraFlags.
Show extraFlags =>
Int -> LocalRootConfig extraFlags -> ShowS
showsPrec :: Int -> LocalRootConfig extraFlags -> ShowS
$cshow :: forall extraFlags.
Show extraFlags =>
LocalRootConfig extraFlags -> String
show :: LocalRootConfig extraFlags -> String
$cshowList :: forall extraFlags.
Show extraFlags =>
[LocalRootConfig extraFlags] -> ShowS
showList :: [LocalRootConfig extraFlags] -> ShowS
Show, LocalRootConfig extraFlags -> LocalRootConfig extraFlags -> Bool
(LocalRootConfig extraFlags -> LocalRootConfig extraFlags -> Bool)
-> (LocalRootConfig extraFlags
    -> LocalRootConfig extraFlags -> Bool)
-> Eq (LocalRootConfig extraFlags)
forall extraFlags.
Eq extraFlags =>
LocalRootConfig extraFlags -> LocalRootConfig extraFlags -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall extraFlags.
Eq extraFlags =>
LocalRootConfig extraFlags -> LocalRootConfig extraFlags -> Bool
== :: LocalRootConfig extraFlags -> LocalRootConfig extraFlags -> Bool
$c/= :: forall extraFlags.
Eq extraFlags =>
LocalRootConfig extraFlags -> LocalRootConfig extraFlags -> Bool
/= :: LocalRootConfig extraFlags -> LocalRootConfig extraFlags -> Bool
Eq)

data LocalRootPeers extraFlags peeraddr =
     LocalRootPeers
       -- We use two partial & overlapping representations:

       -- The collection of all the peers, with the associated PeerAdvertise
       -- and extra values
       (Map peeraddr (LocalRootConfig extraFlags))

       -- The groups, but without the associated PeerAdvertise and
       -- PeerTrustable values
       [(HotValency, WarmValency, Set peeraddr)]
  deriving LocalRootPeers extraFlags peeraddr
-> LocalRootPeers extraFlags peeraddr -> Bool
(LocalRootPeers extraFlags peeraddr
 -> LocalRootPeers extraFlags peeraddr -> Bool)
-> (LocalRootPeers extraFlags peeraddr
    -> LocalRootPeers extraFlags peeraddr -> Bool)
-> Eq (LocalRootPeers extraFlags peeraddr)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall extraFlags peeraddr.
(Eq peeraddr, Eq extraFlags) =>
LocalRootPeers extraFlags peeraddr
-> LocalRootPeers extraFlags peeraddr -> Bool
$c== :: forall extraFlags peeraddr.
(Eq peeraddr, Eq extraFlags) =>
LocalRootPeers extraFlags peeraddr
-> LocalRootPeers extraFlags peeraddr -> Bool
== :: LocalRootPeers extraFlags peeraddr
-> LocalRootPeers extraFlags peeraddr -> Bool
$c/= :: forall extraFlags peeraddr.
(Eq peeraddr, Eq extraFlags) =>
LocalRootPeers extraFlags peeraddr
-> LocalRootPeers extraFlags peeraddr -> Bool
/= :: LocalRootPeers extraFlags peeraddr
-> LocalRootPeers extraFlags peeraddr -> Bool
Eq

mapPeers :: (Ord b)
         => (a -> b)
         -> LocalRootPeers extraFlags a
         -> LocalRootPeers extraFlags b
mapPeers :: forall b a extraFlags.
Ord b =>
(a -> b)
-> LocalRootPeers extraFlags a -> LocalRootPeers extraFlags b
mapPeers a -> b
f (LocalRootPeers Map a (LocalRootConfig extraFlags)
m [(HotValency, WarmValency, Set a)]
l) =
  Map b (LocalRootConfig extraFlags)
-> [(HotValency, WarmValency, Set b)]
-> LocalRootPeers extraFlags b
forall extraFlags peeraddr.
Map peeraddr (LocalRootConfig extraFlags)
-> [(HotValency, WarmValency, Set peeraddr)]
-> LocalRootPeers extraFlags peeraddr
LocalRootPeers ((a -> b)
-> Map a (LocalRootConfig extraFlags)
-> Map b (LocalRootConfig extraFlags)
forall k2 k1 a. Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a
Map.mapKeys a -> b
f Map a (LocalRootConfig extraFlags)
m) (((HotValency, WarmValency, Set a)
 -> (HotValency, WarmValency, Set b))
-> [(HotValency, WarmValency, Set a)]
-> [(HotValency, WarmValency, Set b)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Set a -> Set b)
-> (HotValency, WarmValency, Set a)
-> (HotValency, WarmValency, Set b)
forall a b.
(a -> b)
-> (HotValency, WarmValency, a) -> (HotValency, WarmValency, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> b) -> Set a -> Set b
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map a -> b
f)) [(HotValency, WarmValency, Set a)]
l)

-- | Newtype wrapper representing hot valency value from local root group
-- configuration
--
newtype HotValency = HotValency { HotValency -> Int
getHotValency :: Int }
  deriving (Int -> HotValency -> ShowS
[HotValency] -> ShowS
HotValency -> String
(Int -> HotValency -> ShowS)
-> (HotValency -> String)
-> ([HotValency] -> ShowS)
-> Show HotValency
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> HotValency -> ShowS
showsPrec :: Int -> HotValency -> ShowS
$cshow :: HotValency -> String
show :: HotValency -> String
$cshowList :: [HotValency] -> ShowS
showList :: [HotValency] -> ShowS
Show, HotValency -> HotValency -> Bool
(HotValency -> HotValency -> Bool)
-> (HotValency -> HotValency -> Bool) -> Eq HotValency
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: HotValency -> HotValency -> Bool
== :: HotValency -> HotValency -> Bool
$c/= :: HotValency -> HotValency -> Bool
/= :: HotValency -> HotValency -> Bool
Eq, Eq HotValency
Eq HotValency =>
(HotValency -> HotValency -> Ordering)
-> (HotValency -> HotValency -> Bool)
-> (HotValency -> HotValency -> Bool)
-> (HotValency -> HotValency -> Bool)
-> (HotValency -> HotValency -> Bool)
-> (HotValency -> HotValency -> HotValency)
-> (HotValency -> HotValency -> HotValency)
-> Ord HotValency
HotValency -> HotValency -> Bool
HotValency -> HotValency -> Ordering
HotValency -> HotValency -> HotValency
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 :: HotValency -> HotValency -> Ordering
compare :: HotValency -> HotValency -> Ordering
$c< :: HotValency -> HotValency -> Bool
< :: HotValency -> HotValency -> Bool
$c<= :: HotValency -> HotValency -> Bool
<= :: HotValency -> HotValency -> Bool
$c> :: HotValency -> HotValency -> Bool
> :: HotValency -> HotValency -> Bool
$c>= :: HotValency -> HotValency -> Bool
>= :: HotValency -> HotValency -> Bool
$cmax :: HotValency -> HotValency -> HotValency
max :: HotValency -> HotValency -> HotValency
$cmin :: HotValency -> HotValency -> HotValency
min :: HotValency -> HotValency -> HotValency
Ord)
  deriving Integer -> HotValency
HotValency -> HotValency
HotValency -> HotValency -> HotValency
(HotValency -> HotValency -> HotValency)
-> (HotValency -> HotValency -> HotValency)
-> (HotValency -> HotValency -> HotValency)
-> (HotValency -> HotValency)
-> (HotValency -> HotValency)
-> (HotValency -> HotValency)
-> (Integer -> HotValency)
-> Num HotValency
forall a.
(a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (Integer -> a)
-> Num a
$c+ :: HotValency -> HotValency -> HotValency
+ :: HotValency -> HotValency -> HotValency
$c- :: HotValency -> HotValency -> HotValency
- :: HotValency -> HotValency -> HotValency
$c* :: HotValency -> HotValency -> HotValency
* :: HotValency -> HotValency -> HotValency
$cnegate :: HotValency -> HotValency
negate :: HotValency -> HotValency
$cabs :: HotValency -> HotValency
abs :: HotValency -> HotValency
$csignum :: HotValency -> HotValency
signum :: HotValency -> HotValency
$cfromInteger :: Integer -> HotValency
fromInteger :: Integer -> HotValency
Num via Int

-- | Newtype wrapper representing warm valency value from local root group
-- configuration
--
newtype WarmValency = WarmValency { WarmValency -> Int
getWarmValency :: Int }
  deriving (Int -> WarmValency -> ShowS
[WarmValency] -> ShowS
WarmValency -> String
(Int -> WarmValency -> ShowS)
-> (WarmValency -> String)
-> ([WarmValency] -> ShowS)
-> Show WarmValency
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> WarmValency -> ShowS
showsPrec :: Int -> WarmValency -> ShowS
$cshow :: WarmValency -> String
show :: WarmValency -> String
$cshowList :: [WarmValency] -> ShowS
showList :: [WarmValency] -> ShowS
Show, WarmValency -> WarmValency -> Bool
(WarmValency -> WarmValency -> Bool)
-> (WarmValency -> WarmValency -> Bool) -> Eq WarmValency
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: WarmValency -> WarmValency -> Bool
== :: WarmValency -> WarmValency -> Bool
$c/= :: WarmValency -> WarmValency -> Bool
/= :: WarmValency -> WarmValency -> Bool
Eq, Eq WarmValency
Eq WarmValency =>
(WarmValency -> WarmValency -> Ordering)
-> (WarmValency -> WarmValency -> Bool)
-> (WarmValency -> WarmValency -> Bool)
-> (WarmValency -> WarmValency -> Bool)
-> (WarmValency -> WarmValency -> Bool)
-> (WarmValency -> WarmValency -> WarmValency)
-> (WarmValency -> WarmValency -> WarmValency)
-> Ord WarmValency
WarmValency -> WarmValency -> Bool
WarmValency -> WarmValency -> Ordering
WarmValency -> WarmValency -> WarmValency
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 :: WarmValency -> WarmValency -> Ordering
compare :: WarmValency -> WarmValency -> Ordering
$c< :: WarmValency -> WarmValency -> Bool
< :: WarmValency -> WarmValency -> Bool
$c<= :: WarmValency -> WarmValency -> Bool
<= :: WarmValency -> WarmValency -> Bool
$c> :: WarmValency -> WarmValency -> Bool
> :: WarmValency -> WarmValency -> Bool
$c>= :: WarmValency -> WarmValency -> Bool
>= :: WarmValency -> WarmValency -> Bool
$cmax :: WarmValency -> WarmValency -> WarmValency
max :: WarmValency -> WarmValency -> WarmValency
$cmin :: WarmValency -> WarmValency -> WarmValency
min :: WarmValency -> WarmValency -> WarmValency
Ord)
  deriving Integer -> WarmValency
WarmValency -> WarmValency
WarmValency -> WarmValency -> WarmValency
(WarmValency -> WarmValency -> WarmValency)
-> (WarmValency -> WarmValency -> WarmValency)
-> (WarmValency -> WarmValency -> WarmValency)
-> (WarmValency -> WarmValency)
-> (WarmValency -> WarmValency)
-> (WarmValency -> WarmValency)
-> (Integer -> WarmValency)
-> Num WarmValency
forall a.
(a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (Integer -> a)
-> Num a
$c+ :: WarmValency -> WarmValency -> WarmValency
+ :: WarmValency -> WarmValency -> WarmValency
$c- :: WarmValency -> WarmValency -> WarmValency
- :: WarmValency -> WarmValency -> WarmValency
$c* :: WarmValency -> WarmValency -> WarmValency
* :: WarmValency -> WarmValency -> WarmValency
$cnegate :: WarmValency -> WarmValency
negate :: WarmValency -> WarmValency
$cabs :: WarmValency -> WarmValency
abs :: WarmValency -> WarmValency
$csignum :: WarmValency -> WarmValency
signum :: WarmValency -> WarmValency
$cfromInteger :: Integer -> WarmValency
fromInteger :: Integer -> WarmValency
Num via Int

-- | Data available from topology file.
--
type Config extraFlags peeraddr =
     [(HotValency, WarmValency, Map peeraddr (LocalRootConfig extraFlags))]


-- It is an abstract type, so the derived Show is unhelpful, e.g. for replaying
-- test cases.
--
instance (Show extraFlags, Show peeraddr, Ord peeraddr)
  => Show (LocalRootPeers extraFlags peeraddr) where
  show :: LocalRootPeers extraFlags peeraddr -> String
show LocalRootPeers extraFlags peeraddr
lrps = String
"fromGroups " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [(HotValency, WarmValency,
  Map peeraddr (LocalRootConfig extraFlags))]
-> String
forall a. Show a => a -> String
show (LocalRootPeers extraFlags peeraddr
-> [(HotValency, WarmValency,
     Map peeraddr (LocalRootConfig extraFlags))]
forall peeraddr extraFlags.
Ord peeraddr =>
LocalRootPeers extraFlags peeraddr
-> [(HotValency, WarmValency,
     Map peeraddr (LocalRootConfig extraFlags))]
toGroups LocalRootPeers extraFlags peeraddr
lrps)

invariant :: Ord peeraddr => LocalRootPeers extraFlags peeraddr -> Bool
invariant :: forall peeraddr extraFlags.
Ord peeraddr =>
LocalRootPeers extraFlags peeraddr -> Bool
invariant (LocalRootPeers Map peeraddr (LocalRootConfig extraFlags)
m [(HotValency, WarmValency, Set peeraddr)]
gs) =

    -- The overlapping representations must be consistent
    [Set peeraddr] -> Set peeraddr
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions [ Set peeraddr
g | (HotValency
_, WarmValency
_, Set peeraddr
g) <- [(HotValency, WarmValency, Set peeraddr)]
gs ] Set peeraddr -> Set peeraddr -> Bool
forall a. Eq a => a -> a -> Bool
== Map peeraddr (LocalRootConfig extraFlags) -> Set peeraddr
forall k a. Map k a -> Set k
Map.keysSet Map peeraddr (LocalRootConfig extraFlags)
m

    -- The localRootPeers groups must not overlap with each other
 Bool -> Bool -> Bool
&& Map peeraddr (LocalRootConfig extraFlags) -> Int
forall k a. Map k a -> Int
Map.size Map peeraddr (LocalRootConfig extraFlags)
m Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [ Set peeraddr -> Int
forall a. Set a -> Int
Set.size Set peeraddr
g | (HotValency
_, WarmValency
_, Set peeraddr
g) <- [(HotValency, WarmValency, Set peeraddr)]
gs ]

    -- Individual group targets must be greater than zero and achievable given
    -- the group sizes.
    --
    -- Also the warm target needs to be greater than or equal to the hot target
 Bool -> Bool -> Bool
&& [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [   HotValency
0 HotValency -> HotValency -> Bool
forall a. Ord a => a -> a -> Bool
< HotValency
h
          Bool -> Bool -> Bool
&& WarmValency -> Int
getWarmValency WarmValency
w Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= HotValency -> Int
getHotValency HotValency
h
          -- If warm valency is achievable, by monotonicity, hot valency also is
          Bool -> Bool -> Bool
&& WarmValency -> Int
getWarmValency WarmValency
w Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Set peeraddr -> Int
forall a. Set a -> Int
Set.size Set peeraddr
g
       | (HotValency
h, WarmValency
w, Set peeraddr
g) <- [(HotValency, WarmValency, Set peeraddr)]
gs ]


empty :: LocalRootPeers extraFlags peeraddr
empty :: forall extraFlags peeraddr. LocalRootPeers extraFlags peeraddr
empty = Map peeraddr (LocalRootConfig extraFlags)
-> [(HotValency, WarmValency, Set peeraddr)]
-> LocalRootPeers extraFlags peeraddr
forall extraFlags peeraddr.
Map peeraddr (LocalRootConfig extraFlags)
-> [(HotValency, WarmValency, Set peeraddr)]
-> LocalRootPeers extraFlags peeraddr
LocalRootPeers Map peeraddr (LocalRootConfig extraFlags)
forall k a. Map k a
Map.empty []

null :: LocalRootPeers extraFlags peeraddr -> Bool
null :: forall extraFlags peeraddr.
LocalRootPeers extraFlags peeraddr -> Bool
null (LocalRootPeers Map peeraddr (LocalRootConfig extraFlags)
m [(HotValency, WarmValency, Set peeraddr)]
_) = Map peeraddr (LocalRootConfig extraFlags) -> Bool
forall k a. Map k a -> Bool
Map.null Map peeraddr (LocalRootConfig extraFlags)
m

size :: LocalRootPeers extraFlags peeraddr -> Int
size :: forall extraFlags peeraddr.
LocalRootPeers extraFlags peeraddr -> Int
size (LocalRootPeers Map peeraddr (LocalRootConfig extraFlags)
m [(HotValency, WarmValency, Set peeraddr)]
_) = Map peeraddr (LocalRootConfig extraFlags) -> Int
forall k a. Map k a -> Int
Map.size Map peeraddr (LocalRootConfig extraFlags)
m

member :: Ord peeraddr => peeraddr -> LocalRootPeers extraFlags peeraddr -> Bool
member :: forall peeraddr extraFlags.
Ord peeraddr =>
peeraddr -> LocalRootPeers extraFlags peeraddr -> Bool
member peeraddr
p (LocalRootPeers Map peeraddr (LocalRootConfig extraFlags)
m [(HotValency, WarmValency, Set peeraddr)]
_) = peeraddr -> Map peeraddr (LocalRootConfig extraFlags) -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member peeraddr
p Map peeraddr (LocalRootConfig extraFlags)
m

hotTarget :: LocalRootPeers extraFlags peeraddr -> HotValency
hotTarget :: forall extraFlags peeraddr.
LocalRootPeers extraFlags peeraddr -> HotValency
hotTarget (LocalRootPeers Map peeraddr (LocalRootConfig extraFlags)
_ [(HotValency, WarmValency, Set peeraddr)]
gs) = [HotValency] -> HotValency
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [ HotValency
h | (HotValency
h, WarmValency
_, Set peeraddr
_) <- [(HotValency, WarmValency, Set peeraddr)]
gs ]

warmTarget :: LocalRootPeers extraFlags peeraddr -> WarmValency
warmTarget :: forall extraFlags peeraddr.
LocalRootPeers extraFlags peeraddr -> WarmValency
warmTarget (LocalRootPeers Map peeraddr (LocalRootConfig extraFlags)
_ [(HotValency, WarmValency, Set peeraddr)]
gs) = [WarmValency] -> WarmValency
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [ WarmValency
w | (HotValency
_, WarmValency
w, Set peeraddr
_) <- [(HotValency, WarmValency, Set peeraddr)]
gs ]

toMap :: LocalRootPeers extraFlags peeraddr -> Map peeraddr (LocalRootConfig extraFlags)
toMap :: forall extraFlags peeraddr.
LocalRootPeers extraFlags peeraddr
-> Map peeraddr (LocalRootConfig extraFlags)
toMap (LocalRootPeers Map peeraddr (LocalRootConfig extraFlags)
m [(HotValency, WarmValency, Set peeraddr)]
_) = Map peeraddr (LocalRootConfig extraFlags)
m

keysSet :: LocalRootPeers extraFlags peeraddr -> Set peeraddr
keysSet :: forall extraFlags peeraddr.
LocalRootPeers extraFlags peeraddr -> Set peeraddr
keysSet (LocalRootPeers Map peeraddr (LocalRootConfig extraFlags)
m [(HotValency, WarmValency, Set peeraddr)]
_) = Map peeraddr (LocalRootConfig extraFlags) -> Set peeraddr
forall k a. Map k a -> Set k
Map.keysSet Map peeraddr (LocalRootConfig extraFlags)
m

toGroupSets :: LocalRootPeers extraFlags peeraddr -> [(HotValency, WarmValency, Set peeraddr)]
toGroupSets :: forall extraFlags peeraddr.
LocalRootPeers extraFlags peeraddr
-> [(HotValency, WarmValency, Set peeraddr)]
toGroupSets (LocalRootPeers Map peeraddr (LocalRootConfig extraFlags)
_ [(HotValency, WarmValency, Set peeraddr)]
gs) = [(HotValency, WarmValency, Set peeraddr)]
gs


-- | The local root peers info has some invariants that are not directly
-- enforced in the types, and the config comes from an external source. Of
-- course it's good to validate that at source, but here we need to not fail
-- if we're given imperfect data.
--
-- So what we do is bash it until it is valid. We don't need to be too careful
-- about how we do it, it's ok to be brutal. We should however make sure we
-- trace a warning about dodgy config.
--
fromGroups :: Ord peeraddr
           => [(HotValency, WarmValency, Map peeraddr (LocalRootConfig extraFlags))]
           -> LocalRootPeers extraFlags peeraddr
fromGroups :: forall peeraddr extraFlags.
Ord peeraddr =>
[(HotValency, WarmValency,
  Map peeraddr (LocalRootConfig extraFlags))]
-> LocalRootPeers extraFlags peeraddr
fromGroups =
    (\[(HotValency, WarmValency,
  Map peeraddr (LocalRootConfig extraFlags))]
gs -> let m' :: Map peeraddr (LocalRootConfig extraFlags)
m'  = [Map peeraddr (LocalRootConfig extraFlags)]
-> Map peeraddr (LocalRootConfig extraFlags)
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
Map.unions [ Map peeraddr (LocalRootConfig extraFlags)
g | (HotValency
_, WarmValency
_, Map peeraddr (LocalRootConfig extraFlags)
g) <- [(HotValency, WarmValency,
  Map peeraddr (LocalRootConfig extraFlags))]
gs ]
                gs' :: [(HotValency, WarmValency, Set peeraddr)]
gs' = [ (HotValency
h, WarmValency
w, Map peeraddr (LocalRootConfig extraFlags) -> Set peeraddr
forall k a. Map k a -> Set k
Map.keysSet Map peeraddr (LocalRootConfig extraFlags)
g) | (HotValency
h, WarmValency
w, Map peeraddr (LocalRootConfig extraFlags)
g) <- [(HotValency, WarmValency,
  Map peeraddr (LocalRootConfig extraFlags))]
gs ]
             in Map peeraddr (LocalRootConfig extraFlags)
-> [(HotValency, WarmValency, Set peeraddr)]
-> LocalRootPeers extraFlags peeraddr
forall extraFlags peeraddr.
Map peeraddr (LocalRootConfig extraFlags)
-> [(HotValency, WarmValency, Set peeraddr)]
-> LocalRootPeers extraFlags peeraddr
LocalRootPeers Map peeraddr (LocalRootConfig extraFlags)
m' [(HotValency, WarmValency, Set peeraddr)]
gs')
  ([(HotValency, WarmValency,
   Map peeraddr (LocalRootConfig extraFlags))]
 -> LocalRootPeers extraFlags peeraddr)
-> ([(HotValency, WarmValency,
      Map peeraddr (LocalRootConfig extraFlags))]
    -> [(HotValency, WarmValency,
         Map peeraddr (LocalRootConfig extraFlags))])
-> [(HotValency, WarmValency,
     Map peeraddr (LocalRootConfig extraFlags))]
-> LocalRootPeers extraFlags peeraddr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set peeraddr
-> [(HotValency, WarmValency,
     Map peeraddr (LocalRootConfig extraFlags))]
-> [(HotValency, WarmValency,
     Map peeraddr (LocalRootConfig extraFlags))]
forall {k} {a}.
Ord k =>
Set k
-> [(HotValency, WarmValency, Map k a)]
-> [(HotValency, WarmValency, Map k a)]
establishStructureInvariant Set peeraddr
forall a. Set a
Set.empty
  where
    -- The groups must not overlap;
    -- have achievable targets;
    -- Hot targets need to be smaller than or equal to warm targets
    -- and be non-empty.
    establishStructureInvariant :: Set k
-> [(HotValency, WarmValency, Map k a)]
-> [(HotValency, WarmValency, Map k a)]
establishStructureInvariant !Set k
_ [] = []
    establishStructureInvariant !Set k
acc ((HotValency
h, WarmValency
w, Map k a
g): [(HotValency, WarmValency, Map k a)]
gs)
      | WarmValency
w' WarmValency -> WarmValency -> Bool
forall a. Ord a => a -> a -> Bool
> WarmValency
0 Bool -> Bool -> Bool
&& HotValency
h' HotValency -> HotValency -> Bool
forall a. Ord a => a -> a -> Bool
> HotValency
0 = (HotValency
h', WarmValency
w', Map k a
g') (HotValency, WarmValency, Map k a)
-> [(HotValency, WarmValency, Map k a)]
-> [(HotValency, WarmValency, Map k a)]
forall a. a -> [a] -> [a]
: Set k
-> [(HotValency, WarmValency, Map k a)]
-> [(HotValency, WarmValency, Map k a)]
establishStructureInvariant Set k
acc' [(HotValency, WarmValency, Map k a)]
gs
      | Bool
otherwise        =                  Set k
-> [(HotValency, WarmValency, Map k a)]
-> [(HotValency, WarmValency, Map k a)]
establishStructureInvariant Set k
acc' [(HotValency, WarmValency, Map k a)]
gs
      where
        !g' :: Map k a
g'   = Map k a
g Map k a -> Set k -> Map k a
forall k a. Ord k => Map k a -> Set k -> Map k a
`Map.withoutKeys` Set k
acc
        !w' :: WarmValency
w'   = WarmValency -> WarmValency -> WarmValency
forall a. Ord a => a -> a -> a
min WarmValency
w (Int -> WarmValency
WarmValency (Map k a -> Int
forall k a. Map k a -> Int
Map.size Map k a
g'))
        !h' :: HotValency
h'   = Int -> HotValency
HotValency (HotValency -> Int
getHotValency HotValency
h Int -> Int -> Int
forall a. Ord a => a -> a -> a
`min` WarmValency -> Int
getWarmValency WarmValency
w')
        !acc' :: Set k
acc' = Set k
acc Set k -> Set k -> Set k
forall a. Semigroup a => a -> a -> a
<> Map k a -> Set k
forall k a. Map k a -> Set k
Map.keysSet Map k a
g

-- | Inverse of 'fromGroups', for the subset of inputs to 'fromGroups' that
-- satisfy the invariant.
--
toGroups :: Ord peeraddr
         => LocalRootPeers extraFlags peeraddr
         -> [(HotValency, WarmValency, Map peeraddr (LocalRootConfig extraFlags))]
toGroups :: forall peeraddr extraFlags.
Ord peeraddr =>
LocalRootPeers extraFlags peeraddr
-> [(HotValency, WarmValency,
     Map peeraddr (LocalRootConfig extraFlags))]
toGroups (LocalRootPeers Map peeraddr (LocalRootConfig extraFlags)
m [(HotValency, WarmValency, Set peeraddr)]
gs) =
    [ (HotValency
h, WarmValency
w, (peeraddr -> LocalRootConfig extraFlags)
-> Set peeraddr -> Map peeraddr (LocalRootConfig extraFlags)
forall k a. (k -> a) -> Set k -> Map k a
Map.fromSet (Map peeraddr (LocalRootConfig extraFlags)
m Map peeraddr (LocalRootConfig extraFlags)
-> peeraddr -> LocalRootConfig extraFlags
forall k a. Ord k => Map k a -> k -> a
Map.!) Set peeraddr
g)
    | (HotValency
h, WarmValency
w, Set peeraddr
g) <- [(HotValency, WarmValency, Set peeraddr)]
gs ]


-- | Limit the size of the root peers collection to fit within given bounds.
--
-- The governor needs to be able to do this to enforce its invariant that:
--
-- > LocalRootPeers.size localRootPeers <= targetNumberOfKnownPeers
--
-- It needs to be able to /establish/ that invariant given arbitrary
-- configuration for local root peers. It makes sense to do it this way rather
-- than just enforce that local root peers config fits the invariant because
-- the invariant depends on both the targets and the local root peers config
-- and these can both vary dynamically and independently.
--
-- It is unlikely in practice that there are so many local root peers
-- configured that it goes over this targets, so it's ok to resolve it pretty
-- arbitrarily. We just take the local roots in left to right order up to the
-- limit. So we have the property that
--
-- > LocalRootPeers.size (LocalRootPeers.clampToLimit sz lrps)
-- >  == min sz (LocalRootPeers.size lrps)
--
clampToLimit :: Ord peeraddr
             => Int -- ^ The limit on the total number of local peers
             -> LocalRootPeers extraFlags peeraddr
             -> LocalRootPeers extraFlags peeraddr
clampToLimit :: forall peeraddr extraFlags.
Ord peeraddr =>
Int
-> LocalRootPeers extraFlags peeraddr
-> LocalRootPeers extraFlags peeraddr
clampToLimit Int
totalLimit (LocalRootPeers Map peeraddr (LocalRootConfig extraFlags)
m [(HotValency, WarmValency, Set peeraddr)]
gs0) =
    let gs' :: [(HotValency, WarmValency, Set peeraddr)]
gs' = Int
-> [(HotValency, WarmValency, Set peeraddr)]
-> [(HotValency, WarmValency, Set peeraddr)]
forall {a}.
Int
-> [(HotValency, WarmValency, Set a)]
-> [(HotValency, WarmValency, Set a)]
limitTotalSize Int
0 [(HotValency, WarmValency, Set peeraddr)]
gs0
        m' :: Map peeraddr (LocalRootConfig extraFlags)
m'  = Map peeraddr (LocalRootConfig extraFlags)
m Map peeraddr (LocalRootConfig extraFlags)
-> Set peeraddr -> Map peeraddr (LocalRootConfig extraFlags)
forall k a. Ord k => Map k a -> Set k -> Map k a
`Map.restrictKeys` [Set peeraddr] -> Set peeraddr
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions [ Set peeraddr
g | (HotValency
_, WarmValency
_, Set peeraddr
g) <- [(HotValency, WarmValency, Set peeraddr)]
gs' ]
     in Map peeraddr (LocalRootConfig extraFlags)
-> [(HotValency, WarmValency, Set peeraddr)]
-> LocalRootPeers extraFlags peeraddr
forall extraFlags peeraddr.
Map peeraddr (LocalRootConfig extraFlags)
-> [(HotValency, WarmValency, Set peeraddr)]
-> LocalRootPeers extraFlags peeraddr
LocalRootPeers Map peeraddr (LocalRootConfig extraFlags)
m' [(HotValency, WarmValency, Set peeraddr)]
gs'

  where
    limitTotalSize :: Int
-> [(HotValency, WarmValency, Set a)]
-> [(HotValency, WarmValency, Set a)]
limitTotalSize !Int
_ [] = []
    limitTotalSize !Int
n ((HotValency
h, WarmValency
w, Set a
g) : [(HotValency, WarmValency, Set a)]
gs)

        -- No space at all!
      | Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
totalLimit
      = []

        -- It fits entirely!
      | let n' :: Int
n' = Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Set a -> Int
forall a. Set a -> Int
Set.size Set a
g
      , Int
n' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
totalLimit
      = (HotValency
h, WarmValency
w, Set a
g) (HotValency, WarmValency, Set a)
-> [(HotValency, WarmValency, Set a)]
-> [(HotValency, WarmValency, Set a)]
forall a. a -> [a] -> [a]
: Int
-> [(HotValency, WarmValency, Set a)]
-> [(HotValency, WarmValency, Set a)]
limitTotalSize Int
n' [(HotValency, WarmValency, Set a)]
gs

        -- We can fit a bit more if we chop it up!
      | Bool
otherwise
      , let !g' :: Set a
g' = Int -> Set a -> Set a
forall a. Int -> Set a -> Set a
Set.take (Int
totalLimit Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
n) Set a
g
            !w' :: WarmValency
w' = WarmValency -> WarmValency -> WarmValency
forall a. Ord a => a -> a -> a
min WarmValency
w (Int -> WarmValency
WarmValency (Set a -> Int
forall a. Set a -> Int
Set.size Set a
g'))
            !h' :: HotValency
h' = Int -> HotValency
HotValency (HotValency -> Int
getHotValency HotValency
h Int -> Int -> Int
forall a. Ord a => a -> a -> a
`min` WarmValency -> Int
getWarmValency WarmValency
w')
      = [(HotValency
h', WarmValency
w', Set a
g')]