networking improvemnts to new tracing system

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

@@ -769,8 +769,9 @@ updateLedgerPeerSnapshot startupTracer (NodeConfiguration {ncConsensusMode}) rea
     case useLedgerPeers of
       DontUseLedgerPeers       -> empty
       UseLedgerPeers afterSlot -> do
+        snapshotFile <- hoistMaybe mPeerSnapshotFile
         eSnapshot
-          <- liftIO . readPeerSnapshotFile =<< hoistMaybe mPeerSnapshotFile
+          <- liftIO $ readPeerSnapshotFile snapshotFile
         lps@(LedgerPeerSnapshot (wOrigin, _)) <-
           case ncConsensusMode of
             GenesisMode ->
@@ -779,15 +780,20 @@ updateLedgerPeerSnapshot startupTracer (NodeConfiguration {ncConsensusMode}) rea
               MaybeT $ hushM eSnapshot (trace . NetworkConfigUpdateWarning)
         case afterSlot of
           Always -> do
-            traceL $ LedgerPeerSnapshotLoaded . Right $ wOrigin
+            traceL $ LedgerPeerSnapshotLoaded wOrigin
             return lps
           After ledgerSlotNo
             | fileSlot >= ledgerSlotNo -> do
-                traceL $ LedgerPeerSnapshotLoaded . Right $ wOrigin
+                traceL $ LedgerPeerSnapshotLoaded wOrigin
                 pure lps
             | otherwise -> do
-                traceL $ LedgerPeerSnapshotLoaded . Left $ (useLedgerPeers, wOrigin)
-                empty
+                case ncConsensusMode of
+                  GenesisMode -> do
+                    traceL $ LedgerPeerSnapshotError ledgerSlotNo fileSlot snapshotFile
+                    liftIO $ throwIO (LedgerPeerSnapshotTooOld ledgerSlotNo fileSlot snapshotFile)
+                  PraosMode -> do
+                    traceL $ LedgerPeerSnapshotIgnored ledgerSlotNo fileSlot snapshotFile
+                    empty
             where
               fileSlot = case wOrigin of; Origin -> 0; At slot -> slot
 

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

@@ -27,7 +27,7 @@ import           Cardano.Node.Configuration.POM (NodeConfiguration (..), ncProto
 import           Cardano.Node.Configuration.Socket
 import           Cardano.Node.Protocol (ProtocolInstantiationError)
 import           Cardano.Node.Protocol.Types (SomeConsensusProtocol (..))
-import           Cardano.Node.Types (PeerSnapshotFile)
+import           Cardano.Node.Types (PeerSnapshotFile (..))
 import           Cardano.Slotting.Slot (SlotNo, WithOrigin)
 import qualified Ouroboros.Consensus.BlockchainTime.WallClock.Types as WCT
 import           Ouroboros.Consensus.Cardano.Block
@@ -48,6 +48,7 @@ import           Ouroboros.Network.PeerSelection.State.LocalRootPeers (HotValenc
 
 import           Prelude
 
+import           Control.Exception (Exception (..))
 import           Data.Map.Strict (Map)
 import           Data.Monoid (Last (..))
 import           Data.Text (Text, pack)
@@ -139,9 +140,28 @@ data StartupTrace blk =
   | BIShelley BasicInfoShelleyBased
   | BIByron BasicInfoByron
   | BINetwork BasicInfoNetwork
-  | LedgerPeerSnapshotLoaded (Either (UseLedgerPeers, WithOrigin SlotNo) (WithOrigin SlotNo))
+  | LedgerPeerSnapshotLoaded (WithOrigin SlotNo)
+  -- | Ledger peer snapshot ignored since the peer snapshot slot is older than
+  -- `UseLedgerPeers` in the topology file.  Arguments are:
+  -- useLedgerPeersAfterSlot, peerSnapshotSlot, peerSnapshotFile.
+  | LedgerPeerSnapshotIgnored SlotNo SlotNo PeerSnapshotFile
+  -- | Like above, but in `GenesisMode` it is an error to have an old snapshot.
+  | LedgerPeerSnapshotError SlotNo SlotNo PeerSnapshotFile
   | MovedTopLevelOption String
 
+data LedgerPeerSnapshotError = LedgerPeerSnapshotTooOld SlotNo SlotNo PeerSnapshotFile
+  deriving Show
+
+instance Exception LedgerPeerSnapshotError where
+  displayException (LedgerPeerSnapshotTooOld useLedgerAfterSlot peerSnapshotSlot (PeerSnapshotFile snapshotFile)) =
+      "The ledger peer snapshot slot "
+    <> show peerSnapshotSlot
+    <> " is older than the 'useLedgerAfterSlot' entry in the topology file: "
+    <> show useLedgerAfterSlot
+    <> ".\n"
+    <> "Possible fix: update the ledger peer snapshot file: " <> show snapshotFile
+
+
 data EnabledBlockForging
   = EnabledBlockForging
   | DisabledBlockForging

cardano-node/src/Cardano/Node/Tracing/Consistency.hs

@@ -66,6 +66,7 @@ import qualified Ouroboros.Network.ConnectionManager.Core as ConnectionManager
 import qualified Ouroboros.Network.ConnectionManager.Types as ConnectionManager
 import           Ouroboros.Network.Diffusion (DiffusionTracer)
 import           Ouroboros.Network.Driver.Simple (TraceSendRecv)
+import qualified Ouroboros.Network.Driver.Stateful as Stateful (TraceSendRecv)
 import qualified Ouroboros.Network.InboundGovernor as InboundGovernor
 import           Ouroboros.Network.KeepAlive (TraceKeepAliveClient (..))
 import qualified Ouroboros.Network.NodeToClient as NtC
@@ -86,6 +87,7 @@ import           Ouroboros.Network.Protocol.ChainSync.Type (ChainSync)
 import           Ouroboros.Network.Protocol.Handshake.Unversioned (UnversionedProtocol (..),
                    UnversionedProtocolData (..))
 import           Ouroboros.Network.Protocol.LocalStateQuery.Type (LocalStateQuery)
+import qualified Ouroboros.Network.Protocol.LocalStateQuery.Type as LocalStateQuery
 import qualified Ouroboros.Network.Protocol.LocalTxMonitor.Type as LTM
 import qualified Ouroboros.Network.Protocol.LocalTxSubmission.Type as LTS
 import           Ouroboros.Network.Protocol.TxSubmission2.Type (TxSubmission2)
@@ -229,8 +231,9 @@ getAllNamespaces =
         stateQueryNS = map (nsGetTuple . nsReplacePrefix ["StateQueryServer"])
                            (allNamespaces :: [Namespace
                                 (BlockFetch.TraceLabelPeer peer
-                                  (TraceSendRecv
-                                    (LocalStateQuery blk (Point blk) (Query blk))))])
+                                  (Stateful.TraceSendRecv
+                                    (LocalStateQuery blk (Point blk) (Query blk))
+                                    LocalStateQuery.State))])
 
 -- Node to Node
         chainSyncNodeNS = map (nsGetTuple . nsReplacePrefix ["ChainSync", "Remote"])

cardano-node/src/Cardano/Node/Tracing/Documentation.hs

@@ -80,6 +80,7 @@ import qualified Ouroboros.Network.ConnectionManager.Core as ConnectionManager
 import qualified Ouroboros.Network.ConnectionManager.Types as ConnectionManager
 import           Ouroboros.Network.Diffusion.Types (DiffusionTracer)
 import           Ouroboros.Network.Driver.Simple (TraceSendRecv)
+import qualified Ouroboros.Network.Driver.Stateful as Stateful (TraceSendRecv)
 import qualified Ouroboros.Network.InboundGovernor as InboundGovernor
 import           Ouroboros.Network.KeepAlive (TraceKeepAliveClient (..))
 import           Ouroboros.Network.NodeToNode (RemoteAddress)
@@ -98,6 +99,7 @@ import           Ouroboros.Network.Protocol.ChainSync.Type (ChainSync)
 import           Ouroboros.Network.Protocol.Handshake.Unversioned (UnversionedProtocol (..),
                    UnversionedProtocolData (..))
 import           Ouroboros.Network.Protocol.LocalStateQuery.Type (LocalStateQuery)
+import qualified Ouroboros.Network.Protocol.LocalStateQuery.Type as LocalStateQuery
 import qualified Ouroboros.Network.Protocol.LocalTxMonitor.Type as LTM
 import qualified Ouroboros.Network.Protocol.LocalTxSubmission.Type as LTS
 import           Ouroboros.Network.Protocol.TxSubmission2.Type (TxSubmission2)
@@ -489,8 +491,10 @@ docTracersFirstPhase condConfigFileName = do
     stateQueryTrDoc <- documentTracer (stateQueryTr ::
       Logging.Trace IO
             (BlockFetch.TraceLabelPeer peer
-             (TraceSendRecv
-               (LocalStateQuery blk (Point blk) (Query blk)))))
+             (Stateful.TraceSendRecv
+               (LocalStateQuery blk (Point blk) (Query blk))
+               LocalStateQuery.State
+               )))
 
 -- Node to Node
 

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

@@ -536,11 +536,11 @@ instance MetaTrace (AnyMessage (HS.Handshake a b)) where
     HS.MsgRefuse          {} -> ["Refuse"]
 
   severityFor (Namespace _ [sym]) _ = case sym of
-    "ProposeVersions" -> Just Info
-    "ReplyVersions"   -> Just Info
-    "QueryReply"      -> Just Info
-    "AcceptVersion"   -> Just Info
-    "Refuse"          -> Just Info
+    "ProposeVersions" -> Just Debug
+    "ReplyVersions"   -> Just Debug
+    "QueryReply"      -> Just Debug
+    "AcceptVersion"   -> Just Debug
+    "Refuse"          -> Just Debug
     _otherwise        -> Nothing
   severityFor _ _ = Nothing
 

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

@@ -116,6 +116,7 @@ instance MetaTrace (Stateful.AnyMessage ps f) =>
     severityFor (Namespace out tl) (Just msg)
   severityFor (Namespace out ("Send" : tl)) Nothing =
     severityFor (Namespace out tl :: Namespace (Stateful.AnyMessage ps f)) Nothing
+
   severityFor (Namespace out ("Receive" : tl)) (Just (Stateful.TraceSendMsg msg)) =
     severityFor (Namespace out tl) (Just msg)
   severityFor (Namespace out ("Receive" : tl)) Nothing =
@@ -215,14 +216,14 @@ instance MetaTrace (Simple.AnyMessage (ChainSync blk pt tip)) where
     namespaceFor (Simple.AnyMessageAndAgency _agency (MsgDone {})) =
       Namespace [] ["Done"]
 
-    severityFor (Namespace _ ["RequestNext"]) _ = Just Info
-    severityFor (Namespace _ ["AwaitReply"]) _ = Just Info
-    severityFor (Namespace _ ["RollForward"]) _ = Just Info
-    severityFor (Namespace _ ["RollBackward"]) _ = Just Info
-    severityFor (Namespace _ ["FindIntersect"]) _ = Just Info
-    severityFor (Namespace _ ["IntersectFound"]) _ = Just Info
-    severityFor (Namespace _ ["IntersectNotFound"]) _ = Just Info
-    severityFor (Namespace _ ["Done"]) _ = Just Info
+    severityFor (Namespace _ ["RequestNext"]) _ = Just Debug
+    severityFor (Namespace _ ["AwaitReply"]) _ = Just Debug
+    severityFor (Namespace _ ["RollForward"]) _ = Just Debug
+    severityFor (Namespace _ ["RollBackward"]) _ = Just Debug
+    severityFor (Namespace _ ["FindIntersect"]) _ = Just Debug
+    severityFor (Namespace _ ["IntersectFound"]) _ = Just Debug
+    severityFor (Namespace _ ["IntersectNotFound"]) _ = Just Debug
+    severityFor (Namespace _ ["Done"]) _ = Just Debug
     severityFor _ _ = Nothing
 
     documentFor (Namespace _ ["RequestNext"]) = Just $ mconcat
@@ -369,19 +370,19 @@ instance MetaTrace (Simple.AnyMessage (LTM.LocalTxMonitor txid tx slotNo)) where
     namespaceFor (Simple.AnyMessageAndAgency _agency LTM.MsgReplyGetMeasures {}) =
       Namespace [] ["ReplyGetMeasures"]
 
-    severityFor (Namespace _ ["Acquire"]) _ = Just Info
-    severityFor (Namespace _ ["Acquired"]) _ = Just Info
-    severityFor (Namespace _ ["AwaitAcquire"]) _ = Just Info
-    severityFor (Namespace _ ["NextTx"]) _ = Just Info
-    severityFor (Namespace _ ["ReplyNextTx"]) _ = Just Info
-    severityFor (Namespace _ ["HasTx"]) _ = Just Info
-    severityFor (Namespace _ ["ReplyHasTx"]) _ = Just Info
-    severityFor (Namespace _ ["GetSizes"]) _ = Just Info
-    severityFor (Namespace _ ["ReplyGetSizes"]) _ = Just Info
-    severityFor (Namespace _ ["Release"]) _ = Just Info
-    severityFor (Namespace _ ["Done"]) _ = Just Info
-    severityFor (Namespace _ ["GetMeasures"]) _ = Just Info
-    severityFor (Namespace _ ["ReplyGetMeasures"]) _ = Just Info
+    severityFor (Namespace _ ["Acquire"]) _ = Just Debug
+    severityFor (Namespace _ ["Acquired"]) _ = Just Debug
+    severityFor (Namespace _ ["AwaitAcquire"]) _ = Just Debug
+    severityFor (Namespace _ ["NextTx"]) _ = Just Debug
+    severityFor (Namespace _ ["ReplyNextTx"]) _ = Just Debug
+    severityFor (Namespace _ ["HasTx"]) _ = Just Debug
+    severityFor (Namespace _ ["ReplyHasTx"]) _ = Just Debug
+    severityFor (Namespace _ ["GetSizes"]) _ = Just Debug
+    severityFor (Namespace _ ["ReplyGetSizes"]) _ = Just Debug
+    severityFor (Namespace _ ["Release"]) _ = Just Debug
+    severityFor (Namespace _ ["Done"]) _ = Just Debug
+    severityFor (Namespace _ ["GetMeasures"]) _ = Just Debug
+    severityFor (Namespace _ ["ReplyGetMeasures"]) _ = Just Debug
     severityFor _ _ = Nothing
 
     documentFor (Namespace _ ["Acquire"]) = Just
@@ -459,10 +460,10 @@ instance MetaTrace (Simple.AnyMessage (LTS.LocalTxSubmission tx err)) where
     namespaceFor (Simple.AnyMessageAndAgency _agency LTS.MsgDone{}) =
       Namespace [] ["Done"]
 
-    severityFor (Namespace _ ["SubmitTx"]) _ = Just Info
-    severityFor (Namespace _ ["AcceptTx"]) _ = Just Info
-    severityFor (Namespace _ ["RejectTx"]) _ = Just Info
-    severityFor (Namespace _ ["Done"]) _ = Just Info
+    severityFor (Namespace _ ["SubmitTx"]) _ = Just Debug
+    severityFor (Namespace _ ["AcceptTx"]) _ = Just Debug
+    severityFor (Namespace _ ["RejectTx"]) _ = Just Debug
+    severityFor (Namespace _ ["Done"]) _ = Just Debug
     severityFor _ _ = Nothing
 
     documentFor (Namespace _ ["SubmitTx"]) = Just
@@ -487,41 +488,6 @@ instance MetaTrace (Simple.AnyMessage (LTS.LocalTxSubmission tx err)) where
 -- TStateQuery Tracer
 --------------------------------------------------------------------------------
 
-instance (forall result. Show (Query blk result))
-      => LogFormatting (Simple.AnyMessage (LSQ.LocalStateQuery blk pt (Query blk))) where
-  forMachine _dtal (Simple.AnyMessageAndAgency stok LSQ.MsgAcquire{}) =
-    mconcat [ "kind" .= String "MsgAcquire"
-             , "agency" .= String (pack $ show stok)
-             ]
-  forMachine _dtal (Simple.AnyMessageAndAgency stok LSQ.MsgAcquired{}) =
-    mconcat [ "kind" .= String "MsgAcquired"
-             , "agency" .= String (pack $ show stok)
-             ]
-  forMachine _dtal (Simple.AnyMessageAndAgency stok LSQ.MsgFailure{}) =
-    mconcat [ "kind" .= String "MsgFailure"
-             , "agency" .= String (pack $ show stok)
-             ]
-  forMachine _dtal (Simple.AnyMessageAndAgency stok LSQ.MsgQuery{}) =
-    mconcat [ "kind" .= String "MsgQuery"
-             , "agency" .= String (pack $ show stok)
-             ]
-  forMachine _dtal (Simple.AnyMessageAndAgency stok LSQ.MsgResult{}) =
-    mconcat [ "kind" .= String "MsgResult"
-             , "agency" .= String (pack $ show stok)
-             ]
-  forMachine _dtal (Simple.AnyMessageAndAgency stok LSQ.MsgRelease{}) =
-    mconcat [ "kind" .= String "MsgRelease"
-             , "agency" .= String (pack $ show stok)
-             ]
-  forMachine _dtal (Simple.AnyMessageAndAgency stok LSQ.MsgReAcquire{}) =
-    mconcat [ "kind" .= String "MsgReAcquire"
-             , "agency" .= String (pack $ show stok)
-             ]
-  forMachine _dtal (Simple.AnyMessageAndAgency stok LSQ.MsgDone{}) =
-    mconcat [ "kind" .= String "MsgDone"
-             , "agency" .= String (pack $ show stok)
-             ]
-
 instance (forall result. Show (Query blk result))
       => LogFormatting (Stateful.AnyMessage (LSQ.LocalStateQuery blk pt (Query blk)) f) where
   forMachine _dtal (Stateful.AnyMessageAndAgency stok _ LSQ.MsgAcquire{}) =
@@ -557,85 +523,6 @@ instance (forall result. Show (Query blk result))
              , "agency" .= String (pack $ show stok)
              ]
 
-instance MetaTrace (Simple.AnyMessage (LSQ.LocalStateQuery blk pt (Query blk))) where
-    namespaceFor (Simple.AnyMessageAndAgency _agency LSQ.MsgAcquire{}) =
-      Namespace [] ["Acquire"]
-    namespaceFor (Simple.AnyMessageAndAgency _agency LSQ.MsgAcquired{}) =
-      Namespace [] ["Acquired"]
-    namespaceFor (Simple.AnyMessageAndAgency _agency LSQ.MsgFailure{}) =
-      Namespace [] ["Failure"]
-    namespaceFor (Simple.AnyMessageAndAgency _agency LSQ.MsgQuery{}) =
-      Namespace [] ["Query"]
-    namespaceFor (Simple.AnyMessageAndAgency _agency LSQ.MsgResult{}) =
-      Namespace [] ["Result"]
-    namespaceFor (Simple.AnyMessageAndAgency _agency LSQ.MsgRelease{}) =
-      Namespace [] ["Release"]
-    namespaceFor (Simple.AnyMessageAndAgency _agency LSQ.MsgReAcquire{}) =
-      Namespace [] ["ReAcquire"]
-    namespaceFor (Simple.AnyMessageAndAgency _agency LSQ.MsgDone{}) =
-      Namespace [] ["Done"]
-
-    severityFor (Namespace _ ["Acquire"]) _ = Just Info
-    severityFor (Namespace _ ["Acquired"]) _ = Just Info
-    severityFor (Namespace _ ["Failure"]) _ = Just Warning
-    severityFor (Namespace _ ["Query"]) _ = Just Info
-    severityFor (Namespace _ ["Result"]) _ = Just Info
-    severityFor (Namespace _ ["Release"]) _ = Just Info
-    severityFor (Namespace _ ["ReAcquire"]) _ = Just Info
-    severityFor (Namespace _ ["Done"]) _ = Just Info
-    severityFor _ _ = Nothing
-
-    documentFor (Namespace _ ["Acquire"]) = Just $ mconcat
-      [ "The client requests that the state as of a particular recent point on "
-      , "the server's chain (within K of the tip) be made available to query, "
-      , "and waits for confirmation or failure. "
-      , "\n "
-      , "From 'NodeToClient_V8' onwards if the point is not specified, current tip "
-      , "will be acquired.  For previous versions of the protocol 'point' must be "
-      , "given."
-      ]
-    documentFor (Namespace _ ["Acquired"]) = Just
-      "The server can confirm that it has the state at the requested point."
-    documentFor (Namespace _ ["Failure"]) = Just $ mconcat
-      [ "The server can report that it cannot obtain the state for the "
-      , "requested point."
-      ]
-    documentFor (Namespace _ ["Query"]) = Just
-      "The client can perform queries on the current acquired state."
-    documentFor (Namespace _ ["Result"]) = Just
-      "The server must reply with the queries."
-    documentFor (Namespace _ ["Release"]) = Just $ mconcat
-      [ "The client can instruct the server to release the state. This lets "
-      , "the server free resources."
-      ]
-    documentFor (Namespace _ ["ReAcquire"]) = Just $ mconcat
-      [ "This is like 'MsgAcquire' but for when the client already has a "
-      , "state. By moving to another state directly without a 'MsgRelease' it "
-      , "enables optimisations on the server side (e.g. moving to the state for "
-      , "the immediate next block). "
-      , "\n "
-      , "Note that failure to re-acquire is equivalent to 'MsgRelease', "
-      , "rather than keeping the exiting acquired state. "
-      , "\n "
-      , "From 'NodeToClient_V8' onwards if the point is not specified, current tip "
-      , "will be acquired.  For previous versions of the protocol 'point' must be "
-      , "given."
-      ]
-    documentFor (Namespace _ ["Done"]) = Just
-      "The client can terminate the protocol."
-    documentFor _ = Nothing
-
-    allNamespaces = [
-        Namespace [] ["Acquire"]
-      , Namespace [] ["Acquired"]
-      , Namespace [] ["Failure"]
-      , Namespace [] ["Query"]
-      , Namespace [] ["Result"]
-      , Namespace [] ["Release"]
-      , Namespace [] ["ReAcquire"]
-      , Namespace [] ["Done"]
-      ]
-
 instance MetaTrace (Stateful.AnyMessage (LSQ.LocalStateQuery blk pt (Query blk)) f) where
     namespaceFor (Stateful.AnyMessageAndAgency _agency _ LSQ.MsgAcquire{}) =
       Namespace [] ["Acquire"]
@@ -654,14 +541,14 @@ instance MetaTrace (Stateful.AnyMessage (LSQ.LocalStateQuery blk pt (Query blk))
     namespaceFor (Stateful.AnyMessageAndAgency _agency _ LSQ.MsgDone{}) =
       Namespace [] ["Done"]
 
-    severityFor (Namespace _ ["Acquire"]) _ = Just Info
-    severityFor (Namespace _ ["Acquired"]) _ = Just Info
+    severityFor (Namespace _ ["Acquire"]) _ = Just Debug
+    severityFor (Namespace _ ["Acquired"]) _ = Just Debug
     severityFor (Namespace _ ["Failure"]) _ = Just Warning
-    severityFor (Namespace _ ["Query"]) _ = Just Info
-    severityFor (Namespace _ ["Result"]) _ = Just Info
-    severityFor (Namespace _ ["Release"]) _ = Just Info
-    severityFor (Namespace _ ["ReAcquire"]) _ = Just Info
-    severityFor (Namespace _ ["Done"]) _ = Just Info
+    severityFor (Namespace _ ["Query"]) _ = Just Debug
+    severityFor (Namespace _ ["Result"]) _ = Just Debug
+    severityFor (Namespace _ ["Release"]) _ = Just Debug
+    severityFor (Namespace _ ["ReAcquire"]) _ = Just Debug
+    severityFor (Namespace _ ["Done"]) _ = Just Debug
     severityFor _ _ = Nothing
 
     documentFor (Namespace _ ["Acquire"]) = Just $ mconcat