-
Notifications
You must be signed in to change notification settings - Fork 86
/
LocalRootPeers.hs
270 lines (230 loc) · 9.06 KB
/
LocalRootPeers.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}
module Ouroboros.Network.PeerSelection.State.LocalRootPeers
( -- * Types
LocalRootPeers (..)
, HotValency (..)
, WarmValency (..)
, LocalRootsConfig
-- Export constructors for defining tests.
, invariant
-- * Basic operations
, 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 Ouroboros.Network.PeerSelection.PeerAdvertise (PeerAdvertise)
import Ouroboros.Network.PeerSelection.PeerTrustable (PeerTrustable (..))
---------------------------------------
-- Local root peer set representation
--
data LocalRootPeers peeraddr =
LocalRootPeers
-- We use two partial & overlapping representations:
-- The collection of all the peers, with the associated PeerAdvertise
-- and PeerTrustable values
(Map peeraddr (PeerAdvertise, PeerTrustable))
-- The groups, but without the associated PeerAdvertise and
-- PeerTrustable values
[(HotValency, WarmValency, Set peeraddr)]
deriving Eq
-- | Newtype wrapper representing hot valency value from local root group
-- configuration
--
newtype HotValency = HotValency { getHotValency :: Int }
deriving (Show, Eq, Ord)
deriving Num via Int
-- | Newtype wrapper representing warm valency value from local root group
-- configuration
--
newtype WarmValency = WarmValency { getWarmValency :: Int }
deriving (Show, Eq, Ord)
deriving Num via Int
-- | Data available from topology file.
--
type Config peeraddr =
[(HotValency, WarmValency, Map peeraddr ( PeerAdvertise, PeerTrustable))]
-- It is an abstract type, so the derived Show is unhelpful, e.g. for replaying
-- test cases.
--
instance (Show peeraddr, Ord peeraddr) => Show (LocalRootPeers peeraddr) where
show lrps = "fromGroups " ++ show (toGroups lrps)
invariant :: Ord peeraddr => LocalRootPeers peeraddr -> Bool
invariant (LocalRootPeers m gs) =
-- The overlapping representations must be consistent
Set.unions [ g | (_, _, g) <- gs ] == Map.keysSet m
-- The localRootPeers groups must not overlap with each other
&& Map.size m == sum [ Set.size g | (_, _, g) <- 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
&& and [ 0 < h
&& getWarmValency w >= getHotValency h
-- If warm valency is achievable, by monotonicity, hot valency also is
&& getWarmValency w <= Set.size g
| (h, w, g) <- gs ]
empty :: LocalRootPeers peeraddr
empty = LocalRootPeers Map.empty []
null :: LocalRootPeers peeraddr -> Bool
null (LocalRootPeers m _) = Map.null m
size :: LocalRootPeers peeraddr -> Int
size (LocalRootPeers m _) = Map.size m
member :: Ord peeraddr => peeraddr -> LocalRootPeers peeraddr -> Bool
member p (LocalRootPeers m _) = Map.member p m
hotTarget :: LocalRootPeers peeraddr -> HotValency
hotTarget (LocalRootPeers _ gs) = sum [ h | (h, _, _) <- gs ]
warmTarget :: LocalRootPeers peeraddr -> WarmValency
warmTarget (LocalRootPeers _ gs) = sum [ w | (_, w, _) <- gs ]
toMap :: LocalRootPeers peeraddr -> Map peeraddr (PeerAdvertise, PeerTrustable)
toMap (LocalRootPeers m _) = m
keysSet :: LocalRootPeers peeraddr -> Set peeraddr
keysSet (LocalRootPeers m _) = Map.keysSet m
toGroupSets :: LocalRootPeers peeraddr -> [(HotValency, WarmValency, Set peeraddr)]
toGroupSets (LocalRootPeers _ gs) = 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 (PeerAdvertise, PeerTrustable))]
-> LocalRootPeers peeraddr
fromGroups =
(\gs -> let m' = Map.unions [ g | (_, _, g) <- gs ]
gs' = [ (h, w, Map.keysSet g) | (h, w, g) <- gs ]
in LocalRootPeers m' gs')
. establishStructureInvariant 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 !_ [] = []
establishStructureInvariant !acc ((h, w, g): gs)
| w' > 0 && h' > 0 = (h', w', g') : establishStructureInvariant acc' gs
| otherwise = establishStructureInvariant acc' gs
where
!g' = g `Map.withoutKeys` acc
!w' = min w (WarmValency (Map.size g'))
!h' = HotValency (getHotValency h `min` getWarmValency w')
!acc' = acc <> Map.keysSet g
-- | Inverse of 'fromGroups', for the subset of inputs to 'fromGroups' that
-- satisfy the invariant.
--
toGroups :: Ord peeraddr
=> LocalRootPeers peeraddr
-> [(HotValency, WarmValency, Map peeraddr (PeerAdvertise, PeerTrustable))]
toGroups (LocalRootPeers m gs) =
[ (h, w, Map.fromSet (m Map.!) g)
| (h, w, g) <- 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 peeraddr
-> LocalRootPeers peeraddr
clampToLimit totalLimit (LocalRootPeers m gs0) =
let gs' = limitTotalSize 0 gs0
m' = m `Map.restrictKeys` Set.unions [ g | (_, _, g) <- gs' ]
in LocalRootPeers m' gs'
where
limitTotalSize !_ [] = []
limitTotalSize !n ((h, w, g) : gs)
-- No space at all!
| n == totalLimit
= []
-- It fits entirely!
| let n' = n + Set.size g
, n' <= totalLimit
= (h, w, g) : limitTotalSize n' gs
-- We can fit a bit more if we chop it up!
| otherwise
, let !g' = Set.take (totalLimit - n) g
!w' = min w (WarmValency (Set.size g'))
!h' = HotValency (getHotValency h `min` getWarmValency w')
= [(h', w', g')]
clampToTrustable :: Ord peeraddr
=> LocalRootPeers peeraddr
-> LocalRootPeers peeraddr
clampToTrustable (LocalRootPeers m gs) =
let trustedMap = Map.filter (\(_, pt) -> case pt of
IsTrustable -> True
IsNotTrustable -> False
)
m
in LocalRootPeers trustedMap (trustedGroups gs)
where
trustedGroups [] = []
trustedGroups ((h, w, g):gss) =
let trusted = Map.filter (\(_, pt) -> case pt of
IsTrustable -> True
IsNotTrustable -> False
)
m
trustedSet = Map.keysSet trusted
trustedGroup = Set.intersection g trustedSet
w' = min w (WarmValency (Set.size trustedGroup))
h' = HotValency (getHotValency h `min` getWarmValency w')
in if Set.null trustedGroup
then trustedGroups gss
else (h', w', trustedGroup) : trustedGroups gss
isPeerTrustable :: Ord peeraddr
=> peeraddr
-> LocalRootPeers peeraddr
-> Bool
isPeerTrustable peeraddr lrp =
case Map.lookup peeraddr (toMap lrp) of
Just (_, IsTrustable) -> True
_ -> False
trustableKeysSet :: LocalRootPeers peeraddr
-> Set peeraddr
trustableKeysSet (LocalRootPeers m _) =
Map.keysSet
. Map.filter (\(_, trustable) -> case trustable of
IsTrustable -> True
IsNotTrustable -> False)
$ m