88{-# LANGUAGE NamedFieldPuns #-}
99{-# LANGUAGE PackageImports #-}
1010{-# LANGUAGE ScopedTypeVariables #-}
11- {-# LANGUAGE TypeApplications #-}
1211{-# LANGUAGE TupleSections #-}
12+ {-# LANGUAGE TypeApplications #-}
1313
1414{-# OPTIONS_GHC -Wno-unused-imports #-}
1515
@@ -39,12 +39,14 @@ import Control.Monad.Class.MonadThrow (MonadThrow (..))
3939import Control.Monad.IO.Class (MonadIO (.. ))
4040import Control.Monad.Trans.Except (ExceptT , runExceptT )
4141import Control.Monad.Trans.Except.Extra (left )
42+ import Control.Monad.Trans.Maybe (MaybeT (.. ), mapMaybeT )
4243import "contra-tracer" Control.Tracer
4344import Data.Either (partitionEithers )
4445import Data.Map.Strict (Map )
4546import qualified Data.Map.Strict as Map
4647import Data.Maybe (catMaybes , fromMaybe , mapMaybe )
4748import Data.Monoid (Last (.. ))
49+ import Data.Foldable (traverse_ )
4850import Data.Proxy (Proxy (.. ))
4951import Data.Text (Text , breakOn , pack )
5052import qualified Data.Text as Text
@@ -125,7 +127,7 @@ import Cardano.Node.TraceConstraints (TraceConstraints)
125127import Cardano.Tracing.Tracers
126128import Ouroboros.Network.PeerSelection.PeerSharing (PeerSharing (.. ))
127129import Ouroboros.Network.PeerSelection.State.LocalRootPeers (HotValency , WarmValency )
128- import Ouroboros.Network.PeerSelection.LedgerPeers.Type (UseLedgerPeers )
130+ import Ouroboros.Network.PeerSelection.LedgerPeers.Type (LedgerPeerSnapshot ( .. ), UseLedgerPeers )
129131import Ouroboros.Network.PeerSelection.PeerTrustable (PeerTrustable )
130132import Ouroboros.Network.PeerSelection.Bootstrap (UseBootstrapPeers )
131133
@@ -420,16 +422,24 @@ handleSimpleNode blockType runP p2pMode tracers nc onKernel = do
420422 nt@ TopologyP2P. RealNodeTopology
421423 { ntUseLedgerPeers
422424 , ntUseBootstrapPeers
425+ , ntPeerSnapshotPath
423426 } <- TopologyP2P. readTopologyFileOrError (startupTracer tracers) nc
424427 let (localRoots, publicRoots) = producerAddresses nt
425428 traceWith (startupTracer tracers)
426429 $ NetworkConfig localRoots
427430 publicRoots
428431 ntUseLedgerPeers
429- localRootsVar <- newTVarIO localRoots
430- publicRootsVar <- newTVarIO publicRoots
431- useLedgerVar <- newTVarIO ntUseLedgerPeers
432+ ntPeerSnapshotPath
433+ localRootsVar <- newTVarIO localRoots
434+ publicRootsVar <- newTVarIO publicRoots
435+ useLedgerVar <- newTVarIO ntUseLedgerPeers
432436 useBootstrapVar <- newTVarIO ntUseBootstrapPeers
437+ ledgerPeerSnapshotPathVar <- newTVarIO ntPeerSnapshotPath
438+ ledgerPeerSnapshotVar <- newTVarIO =<< updateLedgerPeerSnapshot
439+ (startupTracer tracers)
440+ (readTVar ledgerPeerSnapshotPathVar)
441+ (const . pure $ () )
442+
433443 let nodeArgs = RunNodeArgs
434444 { rnTraceConsensus = consensusTracers tracers
435445 , rnTraceNTN = nodeToNodeTracers tracers
@@ -462,6 +472,11 @@ handleSimpleNode blockType runP p2pMode tracers nc onKernel = do
462472 updateTopologyConfiguration
463473 (startupTracer tracers) nc
464474 localRootsVar publicRootsVar useLedgerVar useBootstrapVar
475+ ledgerPeerSnapshotPathVar
476+ void $ updateLedgerPeerSnapshot
477+ (startupTracer tracers)
478+ (readTVar ledgerPeerSnapshotPathVar)
479+ (writeTVar ledgerPeerSnapshotVar)
465480 traceWith (startupTracer tracers) (BlockForgingUpdate NotEffective )
466481 )
467482 Nothing
@@ -473,13 +488,15 @@ handleSimpleNode blockType runP p2pMode tracers nc onKernel = do
473488 (readTVar publicRootsVar)
474489 (readTVar useLedgerVar)
475490 (readTVar useBootstrapVar)
491+ (readTVar ledgerPeerSnapshotVar)
476492 in
477493 Node. run
478494 nodeArgs {
479495 rnNodeKernelHook = \ registry nodeKernel -> do
480496 -- reinstall `SIGHUP` handler
481497 installP2PSigHUPHandler (startupTracer tracers) blockType nc nodeKernel
482498 localRootsVar publicRootsVar useLedgerVar useBootstrapVar
499+ ledgerPeerSnapshotPathVar
483500 rnNodeKernelHook nodeArgs registry nodeKernel
484501 }
485502 StdRunNodeArgs
@@ -648,17 +665,19 @@ installP2PSigHUPHandler :: Tracer IO (StartupTrace blk)
648665 -> StrictTVar IO (Map RelayAccessPoint PeerAdvertise )
649666 -> StrictTVar IO UseLedgerPeers
650667 -> StrictTVar IO UseBootstrapPeers
668+ -> StrictTVar IO (Maybe PeerSnapshotFile )
651669 -> IO ()
652670#ifndef UNIX
653671installP2PSigHUPHandler _ _ _ _ _ _ _ _ = return ()
654672#else
655673installP2PSigHUPHandler startupTracer blockType nc nodeKernel localRootsVar publicRootsVar useLedgerVar
656- useBootstrapPeersVar =
674+ useBootstrapPeersVar ledgerPeerSnapshotPathVar =
657675 void $ Signals. installHandler
658676 Signals. sigHUP
659677 (Signals. Catch $ do
660678 updateBlockForging startupTracer blockType nodeKernel nc
661- updateTopologyConfiguration startupTracer nc localRootsVar publicRootsVar useLedgerVar useBootstrapPeersVar
679+ updateTopologyConfiguration startupTracer nc localRootsVar publicRootsVar
680+ useLedgerVar useBootstrapPeersVar ledgerPeerSnapshotPathVar
662681 )
663682 Nothing
664683#endif
@@ -743,9 +762,10 @@ updateTopologyConfiguration :: Tracer IO (StartupTrace blk)
743762 -> StrictTVar IO (Map RelayAccessPoint PeerAdvertise )
744763 -> StrictTVar IO UseLedgerPeers
745764 -> StrictTVar IO UseBootstrapPeers
765+ -> StrictTVar IO (Maybe PeerSnapshotFile )
746766 -> IO ()
747767updateTopologyConfiguration startupTracer nc localRootsVar publicRootsVar useLedgerVar
748- useBootsrapPeersVar = do
768+ useBootsrapPeersVar ledgerPeerSnapshotPathVar = do
749769 traceWith startupTracer NetworkConfigUpdate
750770 result <- try $ readTopologyFileOrError startupTracer nc
751771 case result of
@@ -755,17 +775,36 @@ updateTopologyConfiguration startupTracer nc localRootsVar publicRootsVar useLed
755775 $ pack " Error reading topology configuration file:" <> err
756776 Right nt@ RealNodeTopology { ntUseLedgerPeers
757777 , ntUseBootstrapPeers
778+ , ntPeerSnapshotPath
758779 } -> do
759780 let (localRoots, publicRoots) = producerAddresses nt
760781 traceWith startupTracer
761- $ NetworkConfig localRoots publicRoots ntUseLedgerPeers
782+ $ NetworkConfig localRoots publicRoots ntUseLedgerPeers ntPeerSnapshotPath
762783 atomically $ do
763784 writeTVar localRootsVar localRoots
764785 writeTVar publicRootsVar publicRoots
765786 writeTVar useLedgerVar ntUseLedgerPeers
766787 writeTVar useBootsrapPeersVar ntUseBootstrapPeers
788+ writeTVar ledgerPeerSnapshotPathVar ntPeerSnapshotPath
767789#endif
768790
791+ updateLedgerPeerSnapshot :: Tracer IO (StartupTrace blk )
792+ -> STM IO (Maybe PeerSnapshotFile )
793+ -> (Maybe LedgerPeerSnapshot -> STM IO () )
794+ -> IO (Maybe LedgerPeerSnapshot )
795+ updateLedgerPeerSnapshot startupTracer readLedgerPeerPath writeVar = runMaybeT $
796+ (\ io_m_lps -> do
797+ m_lps <- io_m_lps
798+ traverse_ (\ (LedgerPeerSnapshot (wOrigin, _)) ->
799+ traceWith startupTracer
800+ (LedgerPeerSnapshotLoaded wOrigin)) m_lps
801+ atomically . writeVar $ m_lps
802+ io_m_lps)
803+ -- ^ ensures that snapshot payload TVar is updated to Nothing
804+ -- if the path entry is removed from topology file sometime
805+ -- before sighup
806+ `mapMaybeT` (liftIO . readPeerSnapshotFile =<< MaybeT (atomically readLedgerPeerPath))
807+
769808--------------------------------------------------------------------------------
770809-- Helper functions
771810--------------------------------------------------------------------------------
@@ -823,6 +862,7 @@ mkP2PArguments
823862 -> STM IO (Map RelayAccessPoint PeerAdvertise )
824863 -> STM IO UseLedgerPeers
825864 -> STM IO UseBootstrapPeers
865+ -> STM IO (Maybe LedgerPeerSnapshot )
826866 -> Diffusion. ExtraArguments 'Diffusion.P2P IO
827867mkP2PArguments NodeConfiguration {
828868 ncTargetNumberOfRootPeers,
@@ -839,13 +879,15 @@ mkP2PArguments NodeConfiguration {
839879 daReadLocalRootPeers
840880 daReadPublicRootPeers
841881 daReadUseLedgerPeers
842- daReadUseBootstrapPeers =
882+ daReadUseBootstrapPeers
883+ daReadLedgerPeerSnapshot =
843884 Diffusion. P2PArguments P2P. ArgumentsExtra
844885 { P2P. daPeerSelectionTargets
845886 , P2P. daReadLocalRootPeers
846887 , P2P. daReadPublicRootPeers
847888 , P2P. daReadUseLedgerPeers
848889 , P2P. daReadUseBootstrapPeers
890+ , P2P. daReadLedgerPeerSnapshot
849891 , P2P. daProtocolIdleTimeout = ncProtocolIdleTimeout
850892 , P2P. daTimeWaitTimeout = ncTimeWaitTimeout
851893 , P2P. daDeadlineChurnInterval = 3300
0 commit comments