11{-# LANGUAGE FlexibleContexts #-}
2+ {-# LANGUAGE NamedFieldPuns #-}
23{-# LANGUAGE ScopedTypeVariables #-}
34
45module Ouroboros.Network.BlockFetch.ClientRegistry
56 ( -- * Registry of block fetch clients
67 FetchClientRegistry (.. )
78 , newFetchClientRegistry
9+ , KeepAliveRegistry (.. )
10+ , newKeepAliveRegistry
811 , bracketFetchClient
912 , bracketKeepAliveClient
1013 , bracketSyncWithFetchClient
@@ -48,31 +51,38 @@ import Ouroboros.Network.Diffusion.Policies (deactivateTimeout)
4851--
4952data FetchClientRegistry peer header block m =
5053 FetchClientRegistry {
51- fcrCtxVar
54+ ctxVar
5255 :: StrictTMVar
5356 m ( Tracer m (TraceLabelPeer peer (TraceFetchClientState header))
5457 , STM m (FetchClientPolicy header block m)
5558 ),
56- fcrFetchRegistry
59+ fetchRegistry
5760 :: StrictTVar m (Map peer (FetchClientStateVars m header)),
58- fcrSyncRegistry
59- :: StrictTVar m (Map peer (ThreadId m, StrictTMVar m (), StrictTMVar m ())),
60- fcrDqRegistry
61- :: StrictTVar m (Map peer PeerGSV),
62- fcrKeepRegistry
63- :: StrictTVar m (Map peer (ThreadId m, StrictTMVar m ())),
64- fcrDying
65- :: StrictTVar m (Set peer)
66- }
61+ syncRegistry
62+ :: StrictTVar m (Map peer (ThreadId m, StrictTMVar m (), StrictTMVar m ()))
63+ }
64+
6765
6866newFetchClientRegistry :: MonadSTM m
6967 => m (FetchClientRegistry peer header block m )
7068newFetchClientRegistry = FetchClientRegistry <$> newEmptyTMVarIO
7169 <*> newTVarIO Map. empty
7270 <*> newTVarIO Map. empty
73- <*> newTVarIO Map. empty
74- <*> newTVarIO Map. empty
75- <*> newTVarIO Set. empty
71+
72+ data KeepAliveRegistry peer m = KeepAliveRegistry {
73+ dqRegistry
74+ :: StrictTVar m (Map peer PeerGSV),
75+ keepRegistry
76+ :: StrictTVar m (Map peer (ThreadId m, StrictTMVar m ())),
77+ dyingRegistry
78+ :: StrictTVar m (Set peer)
79+ }
80+
81+ newKeepAliveRegistry :: MonadSTM m
82+ => m (KeepAliveRegistry peer m )
83+ newKeepAliveRegistry = KeepAliveRegistry <$> newTVarIO Map. empty
84+ <*> newTVarIO Map. empty
85+ <*> newTVarIO Set. empty
7686
7787-- | This is needed to start a block fetch client. It provides the required
7888-- 'FetchClientContext'. It registers and unregisters the fetch client on
@@ -83,12 +93,13 @@ newFetchClientRegistry = FetchClientRegistry <$> newEmptyTMVarIO
8393bracketFetchClient :: forall m a peer header block version .
8494 (MonadFork m , MonadMask m , MonadTimer m , Ord peer )
8595 => FetchClientRegistry peer header block m
96+ -> KeepAliveRegistry peer m
8697 -> version
8798 -> peer
8899 -> (FetchClientContext header block m -> m a )
89100 -> m a
90- bracketFetchClient ( FetchClientRegistry ctxVar
91- fetchRegistry syncRegistry dqRegistry keepRegistry dyingRegistry)
101+ bracketFetchClient FetchClientRegistry { ctxVar, fetchRegistry, syncRegistry }
102+ KeepAliveRegistry { dqRegistry, keepRegistry, dyingRegistry }
92103 _version peer action = do
93104 ksVar <- newEmptyTMVarIO
94105 fst <$> generalBracket (register ksVar) (unregister ksVar) (action . fst )
@@ -214,7 +225,6 @@ bracketFetchClient (FetchClientRegistry ctxVar
214225 Map. delete peer m
215226
216227
217-
218228-- | The block fetch and chain sync clients for each peer need to synchronise
219229-- their startup and shutdown. This bracket operation provides that
220230-- synchronisation for the chain sync client.
@@ -229,8 +239,7 @@ bracketSyncWithFetchClient :: forall m a peer header block.
229239 -> peer
230240 -> m a
231241 -> m a
232- bracketSyncWithFetchClient (FetchClientRegistry _ctxVar
233- _fetchRegistry syncRegistry _dqRegistry _keepRegistry _dyingRegistry) peer action = do
242+ bracketSyncWithFetchClient FetchClientRegistry { syncRegistry } peer action = do
234243 doneVar <- newEmptyTMVarIO
235244 startVar <- newEmptyTMVarIO
236245 bracket_ (register doneVar startVar) (unregister doneVar) action
@@ -267,12 +276,11 @@ bracketSyncWithFetchClient (FetchClientRegistry _ctxVar
267276
268277bracketKeepAliveClient :: forall m a peer header block .
269278 (MonadSTM m , MonadFork m , MonadMask m , Ord peer )
270- => FetchClientRegistry peer header block m
279+ => KeepAliveRegistry peer m
271280 -> peer
272281 -> (StrictTVar m (Map peer PeerGSV ) -> m a )
273282 -> m a
274- bracketKeepAliveClient(FetchClientRegistry _ctxVar
275- _fetchRegistry _syncRegistry dqRegistry keepRegistry dyingRegistry) peer action = do
283+ bracketKeepAliveClient KeepAliveRegistry { dqRegistry, keepRegistry, dyingRegistry } peer action = do
276284 bracket_ register unregister (action dqRegistry)
277285 where
278286 -- the keepAliveClient will register a PeerGSV and the block fetch client will wait on it.
@@ -326,7 +334,7 @@ setFetchClientContext :: MonadSTM m
326334 -> Tracer m (TraceLabelPeer peer (TraceFetchClientState header ))
327335 -> STM m (FetchClientPolicy header block m )
328336 -> m ()
329- setFetchClientContext ( FetchClientRegistry ctxVar _ _ _ _ _) tracer mkPolicy =
337+ setFetchClientContext FetchClientRegistry { ctxVar } tracer mkPolicy =
330338 atomically $ do
331339 ok <- tryPutTMVar ctxVar (tracer, mkPolicy)
332340 unless ok $ error " setFetchClientContext: called more than once"
@@ -337,25 +345,25 @@ setFetchClientContext (FetchClientRegistry ctxVar _ _ _ _ _) tracer mkPolicy =
337345readFetchClientsStatus :: MonadSTM m
338346 => FetchClientRegistry peer header block m
339347 -> STM m (Map peer (PeerFetchStatus header ))
340- readFetchClientsStatus ( FetchClientRegistry _ registry _ _ _ _) =
341- readTVar registry >>= traverse (readTVar . fetchClientStatusVar)
348+ readFetchClientsStatus FetchClientRegistry { fetchRegistry } =
349+ readTVar fetchRegistry >>= traverse (readTVar . fetchClientStatusVar)
342350
343351-- | A read-only 'STM' action to get the 'FetchClientStateVars' for all fetch
344352-- clients in the 'FetchClientRegistry'.
345353--
346354readFetchClientsStateVars :: MonadSTM m
347355 => FetchClientRegistry peer header block m
348356 -> STM m (Map peer (FetchClientStateVars m header ))
349- readFetchClientsStateVars ( FetchClientRegistry _ registry _ _ _ _) = readTVar registry
357+ readFetchClientsStateVars FetchClientRegistry { fetchRegistry } = readTVar fetchRegistry
350358
351359-- | A read-only 'STM' action to get the 'PeerGSV's for all fetch
352360-- clients in the 'FetchClientRegistry'.
353361--
354- readPeerGSVs :: forall block header m peer .
362+ readPeerGSVs :: forall m peer .
355363 ( MonadSTM m , Ord peer )
356- => FetchClientRegistry peer header block m
364+ => KeepAliveRegistry peer m
357365 -> STM m (Map peer PeerGSV )
358- readPeerGSVs ( FetchClientRegistry _ _ _ dqRegistry keepRegistry _) = do
366+ readPeerGSVs KeepAliveRegistry { dqRegistry, keepRegistry } = do
359367 dr <- readTVar dqRegistry
360368 kr <- readTVar keepRegistry
361369 -- The intersection gives us only the currently hot peers
0 commit comments