improve UX of topology file parsing corner cases

cardano-node/src/Cardano/Node/Configuration/TopologyP2P.hs

@@ -45,14 +45,15 @@ import           Ouroboros.Network.PeerSelection.State.LocalRootPeers (HotValenc
                    WarmValency (..))
 
 import           Control.Applicative (Alternative (..))
-import           Control.Exception.Safe (Exception (..), IOException, handleAny)
+import           Control.Exception.Safe (Exception (..), IOException, try)
 import           Control.Monad
 import           Control.Monad.IO.Class
 import qualified "contra-tracer" Control.Tracer as CT
 import           Data.Aeson
 import           Data.Bifunctor (first)
 import qualified Data.ByteString as BS
 import qualified Data.ByteString.Lazy.Char8 as LBS
+import           Data.Maybe (isJust, isNothing)
 import           Data.Text (Text)
 import qualified Data.Text as Text
 import           Data.Word (Word64)
@@ -232,26 +233,63 @@ instance ToJSON adr => ToJSON (NetworkTopology adr) where
 readTopologyFile :: ()
   => forall adr. FromJSON adr
   => NodeConfiguration -> CT.Tracer IO (StartupTrace blk) -> IO (Either Text (NetworkTopology adr))
-readTopologyFile NodeConfiguration{ncTopologyFile=TopologyFile topologyFilePath, ncConsensusMode} tracer = runExceptT $ do
+readTopologyFile NodeConfiguration{ncTopologyFile=TopologyFile topologyFilePath, ncConsensusMode, ncProtocolFiles} tracer = runExceptT $ do
   bs <- handleIOExceptionsLiftWith handler $ BS.readFile topologyFilePath
-  topology@RealNodeTopology{ntUseBootstrapPeers} <-
+  topology@RealNodeTopology{ntUseLedgerPeers, ntUseBootstrapPeers, ntPeerSnapshotPath} <-
     liftEither . first handlerJSON $
       eitherDecode $ LBS.fromStrict bs
 
   unless (isValidTrustedPeerConfiguration topology) $
     throwError handlerBootstrap
 
+  when (isBlockProducer && useLedgerPeers ntUseLedgerPeers) $
+    liftIO $ CT.traceWith tracer
+           $ NetworkConfigUpdateWarning
+           $ createMsg "Use of ledger peers is not recommended for BP operation"
+
+  when (isJust ntPeerSnapshotPath && not (useLedgerPeers ntUseLedgerPeers) && isBlockProducer) $
+    liftIO $ CT.traceWith tracer
+           $ NetworkConfigUpdateInfo
+           $ createMsg "Ledger peers and peer snapshot, although specified in the topology file, are disabled in line with recommended BP operation"
+
+  when (inPraosMode && isJust ntPeerSnapshotPath &&  not (useLedgerPeers ntUseLedgerPeers)) $
+    if isBlockProducer
+    then liftIO $ CT.traceWith tracer
+           $ NetworkConfigUpdateWarning
+           $ createMsg
+           $  "Peer snapshot file specified but topology disables ledger peers - ignoring file. "
+           <> "To turn off this message remove peerSnapshotFile from the topology file."
+    else liftIO $ CT.traceWith tracer
+           $ NetworkConfigUpdateWarning
+           $ createMsg
+           $  "Peer snapshot file specified but topology disables ledger peers - ignoring file. "
+           <> "To turn off this message enable the use of ledger peers or remove peerSnapshotFile from the topology file."
+
+
+  when (inGenesisMode && not (useLedgerPeers ntUseLedgerPeers) && not isBlockProducer) $
+    liftIO $ CT.traceWith tracer
+           $ NetworkConfigUpdateWarning
+           $ createMsg "It is recommended to use ledger peers and peer snapshot file for relay operations in Genesis mode"
+
+  when (inGenesisMode && isNothing ntPeerSnapshotPath && useLedgerPeers ntUseLedgerPeers && not isBlockProducer) $
+    liftIO $ CT.traceWith tracer
+           $ NetworkConfigUpdateWarning
+           $ createMsg
+           $  "It is recommended to specify an up-to-date ledger peer snapshot file for relay operations in Genesis mode "
+           <> "when the use of ledger peers is enabled."
+
   -- make all relative paths in the topology file relative to the topology file location
   adjustFilePaths (takeDirectory topologyFilePath </>) <$>
     if isGenesisCompatible ncConsensusMode ntUseBootstrapPeers
        then pure topology
        else do
-         liftIO $ CT.traceWith tracer $ NetworkConfigUpdateError genesisIncompatible
+         liftIO $ CT.traceWith tracer $ NetworkConfigUpdateWarning genesisIncompatible
          pure $ topology{ntUseBootstrapPeers = DontUseBootstrapPeers}
   where
+    createMsg msg =
+      "Cardano.Node.Configuration.Topology.readTopologyFile: " <> msg
     handler :: IOException -> Text
-    handler e = Text.pack $ "Cardano.Node.Configuration.Topology.readTopologyFile: "
-                          ++ displayException e
+    handler = Text.pack . createMsg . displayException
     handlerJSON :: String -> Text
     handlerJSON err = mconcat
       [ "Is your topology file formatted correctly? "
@@ -263,8 +301,8 @@ readTopologyFile NodeConfiguration{ncTopologyFile=TopologyFile topologyFilePath,
       , Text.pack err
       ]
     genesisIncompatible
-      = Text.pack $  "Cardano.Node.Configuration.Topology.readTopologyFile: "
-                  <> "Bootstrap peers (field 'bootstrapPeers') are not compatible "
+      = Text.pack . createMsg $
+                     "Bootstrap peers (field 'bootstrapPeers') are not compatible "
                   <> "with Genesis syncing mode, reverting to 'DontUseBootstrapPeers'. "
                   <> "Big ledger peers will be leveraged for decentralized syncing - it "
                   <> "is recommened to provide an up-to-date big ledger peer snapshot file "
@@ -277,8 +315,13 @@ readTopologyFile NodeConfiguration{ncTopologyFile=TopologyFile topologyFilePath,
       , "in bootstrap mode. Make sure you provide at least one bootstrap peer "
       , "source. "
       ]
+    useLedgerPeers DontUseLedgerPeers = False
+    useLedgerPeers _ = True
     isGenesisCompatible GenesisMode UseBootstrapPeers{} = False
     isGenesisCompatible _ _ = True
+    inPraosMode = ncConsensusMode == PraosMode
+    inGenesisMode = ncConsensusMode == GenesisMode
+    isBlockProducer = hasProtocolFile ncProtocolFiles
 
 readTopologyFileOrError :: ()
   => forall adr. FromJSON adr
@@ -289,12 +332,18 @@ readTopologyFileOrError nc tr =
                            <> Text.unpack err)
              pure
 
-readPeerSnapshotFile :: PeerSnapshotFile -> IO LedgerPeerSnapshot
-readPeerSnapshotFile  (PeerSnapshotFile peerSnapshotFile) =
-  handleException $
-    either error pure =<< eitherDecodeFileStrict peerSnapshotFile
+readPeerSnapshotFile :: PeerSnapshotFile -> IO (Either Text LedgerPeerSnapshot)
+readPeerSnapshotFile (PeerSnapshotFile file) = do
+  content <- first renderException <$> try (BS.readFile file)
+  return $ first handler $ content >>= eitherDecodeStrict
   where
-    handleException = handleAny $ \e -> error $ "Cardano.Node.Configuration.TopologyP2P.readPeerSnapshotFile: " <> displayException e
+    renderException :: IOException -> String
+    renderException = displayException
+
+    handler :: String -> Text
+    handler msg =
+      Text.pack
+        $ "Cardano.Node.Configuration.TopologyP2P.readPeerSnapshotFile: " <> msg
 
 --
 -- Checking for chance of progress in bootstrap phase

cardano-node/src/Cardano/Node/Run.hs

@@ -84,6 +84,7 @@ import           Ouroboros.Consensus.Util.Orphans ()
 import           Cardano.Network.PeerSelection.Bootstrap (UseBootstrapPeers (..))
 import           Cardano.Network.PeerSelection.PeerTrustable (PeerTrustable)
 import           Cardano.Network.Types (NumberOfBigLedgerPeers (..))
+import           Cardano.Network.ConsensusMode (ConsensusMode (..))
 import qualified Ouroboros.Cardano.PeerSelection.PeerSelectionActions as Cardano
 import           Ouroboros.Cardano.PeerSelection.Churn (peerChurnGovernor)
 import           Ouroboros.Cardano.Network.Types (ChurnMode (..))
@@ -124,15 +125,17 @@ import           Ouroboros.Network.Protocol.ChainSync.Codec
 import           Ouroboros.Network.Subscription (DnsSubscriptionTarget (..),
                    IPSubscriptionTarget (..))
 
+import           Control.Applicative (empty)
 import           Control.Concurrent (killThread, mkWeakThreadId, myThreadId, getNumCapabilities)
 import           Control.Concurrent.Class.MonadSTM.Strict
 import           Control.Exception (try, Exception, IOException)
 import qualified Control.Exception as Exception
-import           Control.Monad (forM, forM_, unless, void, when)
+import           Control.Monad (forM, forM_, unless, void, when, join)
 import           Control.Monad.Class.MonadThrow (MonadThrow (..))
 import           Control.Monad.IO.Class (MonadIO (..))
 import           Control.Monad.Trans.Except (ExceptT, runExceptT)
-import           Control.Monad.Trans.Except.Extra (left)
+import           Control.Monad.Trans.Except.Extra (left, hushM)
+import           Control.Monad.Trans.Maybe (MaybeT(runMaybeT, MaybeT), hoistMaybe)
 import           "contra-tracer" Control.Tracer
 import           Data.Bits
 import           Data.Either (partitionEithers)
@@ -486,13 +489,21 @@ handleSimpleNode blockType runP p2pMode tracers nc onKernel = do
                                 publicRoots
                                 ntUseLedgerPeers
                                 ntPeerSnapshotPath
+        case ncPeerSharing nc of
+          PeerSharingEnabled
+            | hasProtocolFile (ncProtocolFiles nc) ->
+                traceWith (startupTracer tracers) . NetworkConfigUpdateWarning . Text.pack $
+                     "Mainnet block producers may not meet the Praos performance guarantees "
+                  <> "and host IP address will be leaked since peer sharing is enabled."
+          _otherwise -> pure ()
         localRootsVar   <- newTVarIO localRoots
         publicRootsVar  <- newTVarIO publicRoots
         useLedgerVar    <- newTVarIO ntUseLedgerPeers
         useBootstrapVar <- newTVarIO ntUseBootstrapPeers
         ledgerPeerSnapshotPathVar <- newTVarIO ntPeerSnapshotPath
         ledgerPeerSnapshotVar <- newTVarIO =<< updateLedgerPeerSnapshot
                                                 (startupTracer tracers)
+                                                nc
                                                 (readTVar ledgerPeerSnapshotPathVar)
                                                 (readTVar useLedgerVar)
                                                 (const . pure $ ())
@@ -534,6 +545,7 @@ handleSimpleNode blockType runP p2pMode tracers nc onKernel = do
                   ledgerPeerSnapshotPathVar
                 void $ updateLedgerPeerSnapshot
                   (startupTracer tracers)
+                  nc
                   (readTVar ledgerPeerSnapshotPathVar)
                   (readTVar useLedgerVar)
                   (writeTVar ledgerPeerSnapshotVar)
@@ -763,6 +775,7 @@ installP2PSigHUPHandler startupTracer blockType nc nodeKernel localRootsVar publ
                                   useLedgerVar useBootstrapPeersVar ledgerPeerSnapshotPathVar
       void $ updateLedgerPeerSnapshot
                startupTracer
+               nc
                (readTVar ledgerPeerSnapshotPathVar)
                (readTVar useLedgerVar)
                (writeTVar ledgerPeerSnapshotVar)
@@ -854,7 +867,7 @@ updateTopologyConfiguration :: Tracer IO (StartupTrace blk)
 updateTopologyConfiguration startupTracer nc localRootsVar publicRootsVar useLedgerVar
                             useBootsrapPeersVar ledgerPeerSnapshotPathVar = do
     traceWith startupTracer NetworkConfigUpdate
-    result <- try $ readTopologyFileOrError nc startupTracer
+    result <- try $ TopologyP2P.readTopologyFileOrError nc startupTracer
     case result of
       Left (FatalError err) ->
         traceWith startupTracer
@@ -876,31 +889,45 @@ updateTopologyConfiguration startupTracer nc localRootsVar publicRootsVar useLed
 #endif
 
 updateLedgerPeerSnapshot :: Tracer IO (StartupTrace blk)
+                         -> NodeConfiguration
                          -> STM IO (Maybe PeerSnapshotFile)
                          -> STM IO UseLedgerPeers
                          -> (Maybe LedgerPeerSnapshot -> STM IO ())
                          -> IO (Maybe LedgerPeerSnapshot)
-updateLedgerPeerSnapshot startupTracer readLedgerPeerPath readUseLedgerVar writeVar = do
-  mPeerSnapshotFile <- atomically readLedgerPeerPath
-  mLedgerPeerSnapshot <- forM mPeerSnapshotFile $ \f -> do
-    lps@(LedgerPeerSnapshot (wOrigin, _)) <- readPeerSnapshotFile f
-    useLedgerPeers <- atomically readUseLedgerVar
+updateLedgerPeerSnapshot startupTracer (NodeConfiguration {ncConsensusMode}) readLedgerPeerPath readUseLedgerVar writeVar = do
+  (mPeerSnapshotFile, useLedgerPeers)
+    <- atomically $ (,) <$> readLedgerPeerPath <*> readUseLedgerVar
+
+  let trace    = traceWith startupTracer
+      traceL   = liftIO . trace
+
+  mLedgerPeerSnapshot <- runMaybeT $ do
     case useLedgerPeers of
-      DontUseLedgerPeers ->
-        traceWith startupTracer (LedgerPeerSnapshotLoaded . Left $ (useLedgerPeers, wOrigin))
-      UseLedgerPeers afterSlot
-        | Always <- afterSlot ->
-            traceWith startupTracer (LedgerPeerSnapshotLoaded . Right $ wOrigin)
-        | After slotNo <- afterSlot ->
-            case wOrigin of
-              Origin -> error "Unsupported big ledger peer snapshot file: taken at Origin"
-              At slotNo' | slotNo' >= slotNo ->
-                traceWith startupTracer (LedgerPeerSnapshotLoaded . Right $ wOrigin)
-              _otherwise ->
-                traceWith startupTracer (LedgerPeerSnapshotLoaded . Left $ (useLedgerPeers, wOrigin))
-    return lps
-  atomically . writeVar $ mLedgerPeerSnapshot
-  pure mLedgerPeerSnapshot
+      DontUseLedgerPeers       -> empty
+      UseLedgerPeers afterSlot -> do
+        eSnapshot
+          <- liftIO . readPeerSnapshotFile =<< hoistMaybe mPeerSnapshotFile
+        lps@(LedgerPeerSnapshot (wOrigin, _)) <-
+          case ncConsensusMode of
+            GenesisMode ->
+              MaybeT $ hushM eSnapshot (trace . NetworkConfigUpdateError)
+            PraosMode  ->
+              MaybeT $ hushM eSnapshot (trace . NetworkConfigUpdateWarning)
+        case afterSlot of
+          Always -> do
+            traceL $ LedgerPeerSnapshotLoaded . Right $ wOrigin
+            return lps
+          After ledgerSlotNo
+            | fileSlot >= ledgerSlotNo -> do
+                traceL $ LedgerPeerSnapshotLoaded . Right $ wOrigin
+                pure lps
+            | otherwise -> do
+                traceL $ LedgerPeerSnapshotLoaded . Left $ (useLedgerPeers, wOrigin)
+                empty
+            where
+              fileSlot = case wOrigin of; Origin -> 0; At slot -> slot
+
+  mLedgerPeerSnapshot <$ atomically (writeVar mLedgerPeerSnapshot)
 
 --------------------------------------------------------------------------------
 -- Helper functions

cardano-node/src/Cardano/Node/Startup.hs

@@ -108,6 +108,14 @@ data StartupTrace blk =
   --
   | NetworkConfigUpdateError Text
 
+  -- | Log network configuration update warning.
+  --
+  | NetworkConfigUpdateWarning Text
+
+  -- | Log network configuration update info.
+  --
+  | NetworkConfigUpdateInfo Text
+
   -- | Log peer-to-peer network configuration, either on startup or when its
   -- updated.
   --

cardano-node/src/Cardano/Node/Tracing/Tracers/Startup.hs

@@ -233,6 +233,12 @@ instance ( Show (BlockNodeToNodeVersion blk)
   forMachine _dtal (NetworkConfigUpdateError err) =
       mconcat [ "kind" .= String "NetworkConfigUpdateError"
                , "error" .= String err ]
+  forMachine _dtal (NetworkConfigUpdateWarning msg) =
+      mconcat [ "kind" .= String "NetworkConfigUpdateWarning"
+               , "message" .= String msg ]
+  forMachine _dtal (NetworkConfigUpdateInfo msg) =
+      mconcat [ "kind" .= String "NetworkConfigUpdateInfo"
+               , "message" .= String msg ]
   forMachine _dtal (NetworkConfig localRoots publicRoots useLedgerPeers peerSnapshotFileMaybe) =
       mconcat [ "kind" .= String "NetworkConfig"
                , "localRoots" .= toJSON localRoots
@@ -333,6 +339,10 @@ instance MetaTrace  (StartupTrace blk) where
     Namespace [] ["NetworkConfigUpdateUnsupported"]
   namespaceFor NetworkConfigUpdateError {}  =
     Namespace [] ["NetworkConfigUpdateError"]
+  namespaceFor NetworkConfigUpdateWarning {}  =
+    Namespace [] ["NetworkConfigUpdateWarning"]
+  namespaceFor NetworkConfigUpdateInfo {}  =
+    Namespace [] ["NetworkConfigUpdateInfo"]
   namespaceFor NetworkConfig {}  =
     Namespace [] ["NetworkConfig"]
   namespaceFor NonP2PWarning {}  =
@@ -354,6 +364,8 @@ instance MetaTrace  (StartupTrace blk) where
 
   severityFor (Namespace _ ["SocketConfigError"]) _ = Just Error
   severityFor (Namespace _ ["NetworkConfigUpdate"]) _ = Just Notice
+  severityFor (Namespace _ ["NetworkConfigUpdateInfo"]) _ = Just Info
+  severityFor (Namespace _ ["NetworkConfigUpdateWarning"]) _ = Just Warning
   severityFor (Namespace _ ["NetworkConfigUpdateError"]) _ = Just Error
   severityFor (Namespace _ ["NetworkConfigUpdateUnsupported"]) _ = Just Warning
   severityFor (Namespace _ ["NonP2PWarning"]) _ = Just Warning
@@ -387,6 +399,10 @@ instance MetaTrace  (StartupTrace blk) where
     ""
   documentFor (Namespace [] ["NetworkConfigUpdateUnsupported"]) = Just
     ""
+  documentFor (Namespace [] ["NetworkConfigUpdateInfo"]) = Just
+    ""
+  documentFor (Namespace [] ["NetworkConfigUpdateWarning"]) = Just
+    ""
   documentFor (Namespace [] ["NetworkConfigUpdateError"]) = Just
     ""
   documentFor (Namespace [] ["NetworkConfig"]) = Just
@@ -539,6 +555,8 @@ ppStartupInfoTrace NetworkConfigUpdate = "Performing topology configuration upda
 ppStartupInfoTrace NetworkConfigUpdateUnsupported =
   "Network topology reconfiguration is not supported in non-p2p mode"
 ppStartupInfoTrace (NetworkConfigUpdateError err) = err
+ppStartupInfoTrace (NetworkConfigUpdateWarning msg) = msg
+ppStartupInfoTrace (NetworkConfigUpdateInfo msg) = msg
 ppStartupInfoTrace (NetworkConfig localRoots publicRoots useLedgerPeers peerSnapshotFile) =
     pack
   $ intercalate "\n"

cardano-node/src/Cardano/Tracing/Startup.hs

@@ -27,6 +27,8 @@ instance HasSeverityAnnotation (StartupTrace blk) where
     getSeverityAnnotation (StartupSocketConfigError _) = Error
     getSeverityAnnotation NetworkConfigUpdate = Notice
     getSeverityAnnotation (NetworkConfigUpdateError _) = Error
+    getSeverityAnnotation (NetworkConfigUpdateWarning _) = Warning
+    getSeverityAnnotation (NetworkConfigUpdateInfo _) = Info
     getSeverityAnnotation NetworkConfigUpdateUnsupported = Warning
     getSeverityAnnotation NonP2PWarning = Warning
     getSeverityAnnotation WarningDevelopmentNodeToNodeVersions {} = Warning