{-# 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
  , trustableKeysSet
    -- * Special operations
  , clampToLimit
  , clampToTrustable
  , isPeerTrustable
  ) 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 Cardano.Network.PeerSelection.PeerTrustable (PeerTrustable (..))
import Ouroboros.Network.NodeToNode.Version (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
extraFlags    :: !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')]

clampToTrustable :: Ord peeraddr
                 => LocalRootPeers PeerTrustable peeraddr
                 -> LocalRootPeers PeerTrustable peeraddr
clampToTrustable :: forall peeraddr.
Ord peeraddr =>
LocalRootPeers PeerTrustable peeraddr
-> LocalRootPeers PeerTrustable peeraddr
clampToTrustable (LocalRootPeers Map peeraddr (LocalRootConfig PeerTrustable)
m [(HotValency, WarmValency, Set peeraddr)]
gs) =
  let trustedMap :: Map peeraddr (LocalRootConfig PeerTrustable)
trustedMap = (LocalRootConfig PeerTrustable -> Bool)
-> Map peeraddr (LocalRootConfig PeerTrustable)
-> Map peeraddr (LocalRootConfig PeerTrustable)
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter (\LocalRootConfig { PeerTrustable
extraFlags :: forall extraFlags. LocalRootConfig extraFlags -> extraFlags
extraFlags :: PeerTrustable
extraFlags } -> case PeerTrustable
extraFlags of
                                 PeerTrustable
IsTrustable    -> Bool
True
                                 PeerTrustable
IsNotTrustable -> Bool
False
                              )
                              Map peeraddr (LocalRootConfig PeerTrustable)
m
   in Map peeraddr (LocalRootConfig PeerTrustable)
-> [(HotValency, WarmValency, Set peeraddr)]
-> LocalRootPeers PeerTrustable peeraddr
forall extraFlags peeraddr.
Map peeraddr (LocalRootConfig extraFlags)
-> [(HotValency, WarmValency, Set peeraddr)]
-> LocalRootPeers extraFlags peeraddr
LocalRootPeers Map peeraddr (LocalRootConfig PeerTrustable)
trustedMap ([(HotValency, WarmValency, Set peeraddr)]
-> [(HotValency, WarmValency, Set peeraddr)]
trustedGroups [(HotValency, WarmValency, Set peeraddr)]
gs)
  where
    trustedGroups :: [(HotValency, WarmValency, Set peeraddr)]
-> [(HotValency, WarmValency, Set peeraddr)]
trustedGroups [] = []
    trustedGroups ((HotValency
h, WarmValency
w, Set peeraddr
g):[(HotValency, WarmValency, Set peeraddr)]
gss) =
      let trusted :: Map peeraddr (LocalRootConfig PeerTrustable)
trusted = (LocalRootConfig PeerTrustable -> Bool)
-> Map peeraddr (LocalRootConfig PeerTrustable)
-> Map peeraddr (LocalRootConfig PeerTrustable)
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter (\LocalRootConfig { PeerTrustable
extraFlags :: forall extraFlags. LocalRootConfig extraFlags -> extraFlags
extraFlags :: PeerTrustable
extraFlags } -> case PeerTrustable
extraFlags of
                                  PeerTrustable
IsTrustable    -> Bool
True
                                  PeerTrustable
IsNotTrustable -> Bool
False
                               )
                               Map peeraddr (LocalRootConfig PeerTrustable)
m
          trustedSet :: Set peeraddr
trustedSet = Map peeraddr (LocalRootConfig PeerTrustable) -> Set peeraddr
forall k a. Map k a -> Set k
Map.keysSet Map peeraddr (LocalRootConfig PeerTrustable)
trusted
          trustedGroup :: Set peeraddr
trustedGroup = Set peeraddr -> Set peeraddr -> Set peeraddr
forall a. Ord a => Set a -> Set a -> Set a
Set.intersection Set peeraddr
g Set peeraddr
trustedSet
          w' :: WarmValency
w' = WarmValency -> WarmValency -> WarmValency
forall a. Ord a => a -> a -> a
min WarmValency
w (Int -> WarmValency
WarmValency (Set peeraddr -> Int
forall a. Set a -> Int
Set.size Set peeraddr
trustedGroup))
          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')
       in if Set peeraddr -> Bool
forall a. Set a -> Bool
Set.null Set peeraddr
trustedGroup
             then [(HotValency, WarmValency, Set peeraddr)]
-> [(HotValency, WarmValency, Set peeraddr)]
trustedGroups [(HotValency, WarmValency, Set peeraddr)]
gss
             else (HotValency
h', WarmValency
w', Set peeraddr
trustedGroup) (HotValency, WarmValency, Set peeraddr)
-> [(HotValency, WarmValency, Set peeraddr)]
-> [(HotValency, WarmValency, Set peeraddr)]
forall a. a -> [a] -> [a]
: [(HotValency, WarmValency, Set peeraddr)]
-> [(HotValency, WarmValency, Set peeraddr)]
trustedGroups [(HotValency, WarmValency, Set peeraddr)]
gss

isPeerTrustable :: Ord peeraddr
                => peeraddr
                -> LocalRootPeers PeerTrustable peeraddr
                -> Bool
isPeerTrustable :: forall peeraddr.
Ord peeraddr =>
peeraddr -> LocalRootPeers PeerTrustable peeraddr -> Bool
isPeerTrustable peeraddr
peeraddr LocalRootPeers PeerTrustable peeraddr
lrp =
  case peeraddr
-> Map peeraddr (LocalRootConfig PeerTrustable)
-> Maybe (LocalRootConfig PeerTrustable)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup peeraddr
peeraddr (LocalRootPeers PeerTrustable peeraddr
-> Map peeraddr (LocalRootConfig PeerTrustable)
forall extraFlags peeraddr.
LocalRootPeers extraFlags peeraddr
-> Map peeraddr (LocalRootConfig extraFlags)
toMap LocalRootPeers PeerTrustable peeraddr
lrp) of
    Just LocalRootConfig { extraFlags :: forall extraFlags. LocalRootConfig extraFlags -> extraFlags
extraFlags = PeerTrustable
IsTrustable }
      -> Bool
True
    Maybe (LocalRootConfig PeerTrustable)
_ -> Bool
False

trustableKeysSet :: LocalRootPeers PeerTrustable peeraddr
                 -> Set peeraddr
trustableKeysSet :: forall peeraddr.
LocalRootPeers PeerTrustable peeraddr -> Set peeraddr
trustableKeysSet (LocalRootPeers Map peeraddr (LocalRootConfig PeerTrustable)
m [(HotValency, WarmValency, Set peeraddr)]
_) =
    Map peeraddr (LocalRootConfig PeerTrustable) -> Set peeraddr
forall k a. Map k a -> Set k
Map.keysSet
  (Map peeraddr (LocalRootConfig PeerTrustable) -> Set peeraddr)
-> (Map peeraddr (LocalRootConfig PeerTrustable)
    -> Map peeraddr (LocalRootConfig PeerTrustable))
-> Map peeraddr (LocalRootConfig PeerTrustable)
-> Set peeraddr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LocalRootConfig PeerTrustable -> Bool)
-> Map peeraddr (LocalRootConfig PeerTrustable)
-> Map peeraddr (LocalRootConfig PeerTrustable)
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter (\LocalRootConfig { PeerTrustable
extraFlags :: forall extraFlags. LocalRootConfig extraFlags -> extraFlags
extraFlags :: PeerTrustable
extraFlags } ->
                 case PeerTrustable
extraFlags of
                   PeerTrustable
IsTrustable    -> Bool
True
                   PeerTrustable
IsNotTrustable -> Bool
False)
  (Map peeraddr (LocalRootConfig PeerTrustable) -> Set peeraddr)
-> Map peeraddr (LocalRootConfig PeerTrustable) -> Set peeraddr
forall a b. (a -> b) -> a -> b
$ Map peeraddr (LocalRootConfig PeerTrustable)
m