@@ -84,6 +84,7 @@ import Ouroboros.Consensus.Util.Orphans ()
84
84
import Cardano.Network.PeerSelection.Bootstrap (UseBootstrapPeers (.. ))
85
85
import Cardano.Network.PeerSelection.PeerTrustable (PeerTrustable )
86
86
import Cardano.Network.Types (NumberOfBigLedgerPeers (.. ))
87
+ import Cardano.Network.ConsensusMode (ConsensusMode (.. ))
87
88
import qualified Ouroboros.Cardano.PeerSelection.PeerSelectionActions as Cardano
88
89
import Ouroboros.Cardano.PeerSelection.Churn (peerChurnGovernor )
89
90
import Ouroboros.Cardano.Network.Types (ChurnMode (.. ))
@@ -124,15 +125,17 @@ import Ouroboros.Network.Protocol.ChainSync.Codec
124
125
import Ouroboros.Network.Subscription (DnsSubscriptionTarget (.. ),
125
126
IPSubscriptionTarget (.. ))
126
127
128
+ import Control.Applicative (empty )
127
129
import Control.Concurrent (killThread , mkWeakThreadId , myThreadId , getNumCapabilities )
128
130
import Control.Concurrent.Class.MonadSTM.Strict
129
131
import Control.Exception (try , Exception , IOException )
130
132
import qualified Control.Exception as Exception
131
- import Control.Monad (forM , forM_ , unless , void , when )
133
+ import Control.Monad (forM , forM_ , unless , void , when , join )
132
134
import Control.Monad.Class.MonadThrow (MonadThrow (.. ))
133
135
import Control.Monad.IO.Class (MonadIO (.. ))
134
136
import Control.Monad.Trans.Except (ExceptT , runExceptT )
135
- import Control.Monad.Trans.Except.Extra (left )
137
+ import Control.Monad.Trans.Except.Extra (left , hushM )
138
+ import Control.Monad.Trans.Maybe (MaybeT (runMaybeT , MaybeT ), hoistMaybe )
136
139
import "contra-tracer" Control.Tracer
137
140
import Data.Bits
138
141
import Data.Either (partitionEithers )
@@ -486,13 +489,21 @@ handleSimpleNode blockType runP p2pMode tracers nc onKernel = do
486
489
publicRoots
487
490
ntUseLedgerPeers
488
491
ntPeerSnapshotPath
492
+ case ncPeerSharing nc of
493
+ PeerSharingEnabled
494
+ | hasProtocolFile (ncProtocolFiles nc) ->
495
+ traceWith (startupTracer tracers) . NetworkConfigUpdateWarning . Text. pack $
496
+ " Mainnet block producers may not meet the Praos performance guarantees "
497
+ <> " and host IP address will be leaked since peer sharing is enabled."
498
+ _otherwise -> pure ()
489
499
localRootsVar <- newTVarIO localRoots
490
500
publicRootsVar <- newTVarIO publicRoots
491
501
useLedgerVar <- newTVarIO ntUseLedgerPeers
492
502
useBootstrapVar <- newTVarIO ntUseBootstrapPeers
493
503
ledgerPeerSnapshotPathVar <- newTVarIO ntPeerSnapshotPath
494
504
ledgerPeerSnapshotVar <- newTVarIO =<< updateLedgerPeerSnapshot
495
505
(startupTracer tracers)
506
+ nc
496
507
(readTVar ledgerPeerSnapshotPathVar)
497
508
(readTVar useLedgerVar)
498
509
(const . pure $ () )
@@ -534,6 +545,7 @@ handleSimpleNode blockType runP p2pMode tracers nc onKernel = do
534
545
ledgerPeerSnapshotPathVar
535
546
void $ updateLedgerPeerSnapshot
536
547
(startupTracer tracers)
548
+ nc
537
549
(readTVar ledgerPeerSnapshotPathVar)
538
550
(readTVar useLedgerVar)
539
551
(writeTVar ledgerPeerSnapshotVar)
@@ -763,6 +775,7 @@ installP2PSigHUPHandler startupTracer blockType nc nodeKernel localRootsVar publ
763
775
useLedgerVar useBootstrapPeersVar ledgerPeerSnapshotPathVar
764
776
void $ updateLedgerPeerSnapshot
765
777
startupTracer
778
+ nc
766
779
(readTVar ledgerPeerSnapshotPathVar)
767
780
(readTVar useLedgerVar)
768
781
(writeTVar ledgerPeerSnapshotVar)
@@ -854,7 +867,7 @@ updateTopologyConfiguration :: Tracer IO (StartupTrace blk)
854
867
updateTopologyConfiguration startupTracer nc localRootsVar publicRootsVar useLedgerVar
855
868
useBootsrapPeersVar ledgerPeerSnapshotPathVar = do
856
869
traceWith startupTracer NetworkConfigUpdate
857
- result <- try $ readTopologyFileOrError nc startupTracer
870
+ result <- try $ TopologyP2P. readTopologyFileOrError nc startupTracer
858
871
case result of
859
872
Left (FatalError err) ->
860
873
traceWith startupTracer
@@ -876,31 +889,45 @@ updateTopologyConfiguration startupTracer nc localRootsVar publicRootsVar useLed
876
889
#endif
877
890
878
891
updateLedgerPeerSnapshot :: Tracer IO (StartupTrace blk )
892
+ -> NodeConfiguration
879
893
-> STM IO (Maybe PeerSnapshotFile )
880
894
-> STM IO UseLedgerPeers
881
895
-> (Maybe LedgerPeerSnapshot -> STM IO () )
882
896
-> IO (Maybe LedgerPeerSnapshot )
883
- updateLedgerPeerSnapshot startupTracer readLedgerPeerPath readUseLedgerVar writeVar = do
884
- mPeerSnapshotFile <- atomically readLedgerPeerPath
885
- mLedgerPeerSnapshot <- forM mPeerSnapshotFile $ \ f -> do
886
- lps@ (LedgerPeerSnapshot (wOrigin, _)) <- readPeerSnapshotFile f
887
- useLedgerPeers <- atomically readUseLedgerVar
897
+ updateLedgerPeerSnapshot startupTracer (NodeConfiguration {ncConsensusMode}) readLedgerPeerPath readUseLedgerVar writeVar = do
898
+ (mPeerSnapshotFile, useLedgerPeers)
899
+ <- atomically $ (,) <$> readLedgerPeerPath <*> readUseLedgerVar
900
+
901
+ let trace = traceWith startupTracer
902
+ traceL = liftIO . trace
903
+
904
+ mLedgerPeerSnapshot <- runMaybeT $ do
888
905
case useLedgerPeers of
889
- DontUseLedgerPeers ->
890
- traceWith startupTracer (LedgerPeerSnapshotLoaded . Left $ (useLedgerPeers, wOrigin))
891
- UseLedgerPeers afterSlot
892
- | Always <- afterSlot ->
893
- traceWith startupTracer (LedgerPeerSnapshotLoaded . Right $ wOrigin)
894
- | After slotNo <- afterSlot ->
895
- case wOrigin of
896
- Origin -> error " Unsupported big ledger peer snapshot file: taken at Origin"
897
- At slotNo' | slotNo' >= slotNo ->
898
- traceWith startupTracer (LedgerPeerSnapshotLoaded . Right $ wOrigin)
899
- _otherwise ->
900
- traceWith startupTracer (LedgerPeerSnapshotLoaded . Left $ (useLedgerPeers, wOrigin))
901
- return lps
902
- atomically . writeVar $ mLedgerPeerSnapshot
903
- pure mLedgerPeerSnapshot
906
+ DontUseLedgerPeers -> empty
907
+ UseLedgerPeers afterSlot -> do
908
+ eSnapshot
909
+ <- liftIO . readPeerSnapshotFile =<< hoistMaybe mPeerSnapshotFile
910
+ lps@ (LedgerPeerSnapshot (wOrigin, _)) <-
911
+ case ncConsensusMode of
912
+ GenesisMode ->
913
+ MaybeT $ hushM eSnapshot (trace . NetworkConfigUpdateError )
914
+ PraosMode ->
915
+ MaybeT $ hushM eSnapshot (trace . NetworkConfigUpdateWarning )
916
+ case afterSlot of
917
+ Always -> do
918
+ traceL $ LedgerPeerSnapshotLoaded . Right $ wOrigin
919
+ return lps
920
+ After ledgerSlotNo
921
+ | fileSlot >= ledgerSlotNo -> do
922
+ traceL $ LedgerPeerSnapshotLoaded . Right $ wOrigin
923
+ pure lps
924
+ | otherwise -> do
925
+ traceL $ LedgerPeerSnapshotLoaded . Left $ (useLedgerPeers, wOrigin)
926
+ empty
927
+ where
928
+ fileSlot = case wOrigin of ; Origin -> 0 ; At slot -> slot
929
+
930
+ mLedgerPeerSnapshot <$ atomically (writeVar mLedgerPeerSnapshot)
904
931
905
932
--------------------------------------------------------------------------------
906
933
-- Helper functions
0 commit comments