With ipSubscriptionTracer.

cardano-node/src/Cardano/TraceDispatcher/Network/Combinators.hs

@@ -1,5 +1,7 @@
-{-# LANGUAGE GADTs     #-}
-{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE GADTs               #-}
+{-# LANGUAGE PolyKinds           #-}
+{-# LANGUAGE RecordWildCards     #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 
 module Cardano.TraceDispatcher.Network.Combinators
   (
@@ -24,18 +26,22 @@ module Cardano.TraceDispatcher.Network.Combinators
   , severityTBlockFetchSerialised
   , namesForTBlockFetchSerialised
 
-  , severityTxSubmissionTracerNode
-  , namesForTxSubmissionTracerNode
+  , severityTxSubmissionNode
+  , namesForTxSubmissionNode
 
-  , severityTxSubmission2TracerNode
-  , namesForTxSubmission2TracerNode
+  , severityTxSubmission2Node
+  , namesForTxSubmission2Node
+
+  , severityIpSubscription
+  , namesForIpSubscription
 
   ) where
 
 
 import           Cardano.Logging
 import           Cardano.Prelude
 
+import qualified Network.Socket as Socket
 
 import           Ouroboros.Network.Block (Point, Serialised, Tip)
 import qualified Ouroboros.Network.BlockFetch.ClientState as BlockFetch
@@ -47,9 +53,13 @@ import           Ouroboros.Network.Protocol.ChainSync.Type (ChainSync (..),
                      Message (..))
 import qualified Ouroboros.Network.Protocol.LocalStateQuery.Type as LSQ
 import qualified Ouroboros.Network.Protocol.LocalTxSubmission.Type as LTS
+import           Ouroboros.Network.Protocol.Trans.Hello.Type (Hello,
+                     Message (..))
 import qualified Ouroboros.Network.Protocol.TxSubmission.Type as TXS
 import qualified Ouroboros.Network.Protocol.TxSubmission2.Type as TXS
-import           Ouroboros.Network.Protocol.Trans.Hello.Type(Hello, Message(..))
+import           Ouroboros.Network.Subscription.Ip (WithIPList (..))
+import           Ouroboros.Network.Subscription.Worker (ConnectResult (..),
+                     SubscriberError, SubscriptionTrace (..))
 
 import           Ouroboros.Consensus.Block (Header)
 import           Ouroboros.Consensus.Ledger.SupportsMempool (ApplyTxErr, GenTx,
@@ -339,9 +349,9 @@ namesForTBlockFetchSerialised (BlockFetch.TraceLabelPeer _ v) =
     namesTBlockFetch'' MsgBatchDone {}    = ["BatchDone"]
     namesTBlockFetch'' MsgClientDone {}   = ["ClientDone"]
 
-severityTxSubmissionTracerNode :: BlockFetch.TraceLabelPeer peer
+severityTxSubmissionNode :: BlockFetch.TraceLabelPeer peer
   (TraceSendRecv (TXS.TxSubmission (GenTxId blk) (GenTx blk))) -> SeverityS
-severityTxSubmissionTracerNode (BlockFetch.TraceLabelPeer _ v) = severityTxSubNode v
+severityTxSubmissionNode (BlockFetch.TraceLabelPeer _ v) = severityTxSubNode v
   where
     severityTxSubNode (TraceSendMsg msg) = severityTxSubNode' msg
     severityTxSubNode (TraceRecvMsg msg) = severityTxSubNode' msg
@@ -363,9 +373,9 @@ severityTxSubmissionTracerNode (BlockFetch.TraceLabelPeer _ v) = severityTxSubNo
     -- TODO: Can't use 'MsgKThxBye' because NodeToNodeV_2 is not introduced yet.
 
 
-namesForTxSubmissionTracerNode :: BlockFetch.TraceLabelPeer peer
+namesForTxSubmissionNode :: BlockFetch.TraceLabelPeer peer
   (TraceSendRecv (TXS.TxSubmission (GenTxId blk) (GenTx blk))) -> [Text]
-namesForTxSubmissionTracerNode (BlockFetch.TraceLabelPeer _ v) =
+namesForTxSubmissionNode (BlockFetch.TraceLabelPeer _ v) =
   "NodeToNode" : "TxSubmission" : namesTxSubNode v
   where
     namesTxSubNode (TraceSendMsg msg) = "Send" : namesTxSubNode' msg
@@ -387,9 +397,9 @@ namesForTxSubmissionTracerNode (BlockFetch.TraceLabelPeer _ v) =
     namesTxSubNode'' _                      = ["KThxBye"]
     -- TODO: Can't use 'MsgKThxBye' because NodeToNodeV_2 is not introduced yet.
 
-severityTxSubmission2TracerNode :: BlockFetch.TraceLabelPeer peer
+severityTxSubmission2Node :: BlockFetch.TraceLabelPeer peer
   (TraceSendRecv (TXS.TxSubmission2 (GenTxId blk) (GenTx blk))) -> SeverityS
-severityTxSubmission2TracerNode (BlockFetch.TraceLabelPeer _ v) = severityTxSubNode v
+severityTxSubmission2Node (BlockFetch.TraceLabelPeer _ v) = severityTxSubNode v
   where
     severityTxSubNode (TraceSendMsg msg) = severityTxSubNode' msg
     severityTxSubNode (TraceRecvMsg msg) = severityTxSubNode' msg
@@ -402,18 +412,18 @@ severityTxSubmission2TracerNode (BlockFetch.TraceLabelPeer _ v) = severityTxSubN
           from
           to
      -> SeverityS
-    severityTxSubNode'' MsgHello {}                        = Debug
-    severityTxSubNode'' (MsgTalk TXS.MsgRequestTxIds {})   = Info
-    severityTxSubNode'' (MsgTalk TXS.MsgReplyTxIds {})     = Info
-    severityTxSubNode'' (MsgTalk TXS.MsgRequestTxs {})     = Info
-    severityTxSubNode'' (MsgTalk TXS.MsgReplyTxs {})       = Info
-    severityTxSubNode'' (MsgTalk TXS.MsgDone {})           = Info
-    severityTxSubNode'' (MsgTalk _)                        = Info
+    severityTxSubNode'' MsgHello {}                      = Debug
+    severityTxSubNode'' (MsgTalk TXS.MsgRequestTxIds {}) = Info
+    severityTxSubNode'' (MsgTalk TXS.MsgReplyTxIds {})   = Info
+    severityTxSubNode'' (MsgTalk TXS.MsgRequestTxs {})   = Info
+    severityTxSubNode'' (MsgTalk TXS.MsgReplyTxs {})     = Info
+    severityTxSubNode'' (MsgTalk TXS.MsgDone {})         = Info
+    severityTxSubNode'' (MsgTalk _)                      = Info
     -- TODO: Can't use 'MsgKThxBye' because NodeToNodeV_2 is not introduced yet.
 
-namesForTxSubmission2TracerNode :: BlockFetch.TraceLabelPeer peer
+namesForTxSubmission2Node :: BlockFetch.TraceLabelPeer peer
   (TraceSendRecv (TXS.TxSubmission2 (GenTxId blk) (GenTx blk))) -> [Text]
-namesForTxSubmission2TracerNode (BlockFetch.TraceLabelPeer _ v) =
+namesForTxSubmission2Node (BlockFetch.TraceLabelPeer _ v) =
   "NodeToNode" : "TxSubmission2" : namesTxSubNode v
   where
     namesTxSubNode (TraceSendMsg msg) = "Send" : namesTxSubNode' msg
@@ -423,7 +433,7 @@ namesForTxSubmission2TracerNode (BlockFetch.TraceLabelPeer _ v) =
 
     namesTxSubNode'' ::
          Message
-          (Hello (TXS.TxSubmission (GenTxId blk) (GenTx blk)) stIdle) 
+          (Hello (TXS.TxSubmission (GenTxId blk) (GenTx blk)) stIdle)
           from
           to
       -> [Text]
@@ -435,3 +445,58 @@ namesForTxSubmission2TracerNode (BlockFetch.TraceLabelPeer _ v) =
     namesTxSubNode'' (MsgTalk TXS.MsgDone {})         = ["Done"]
     namesTxSubNode'' (MsgTalk _)                      = ["KThxBye"]
     -- TODO: Can't use 'MsgKThxBye' because NodeToNodeV_2 is not introduced yet.
+
+severityIpSubscription ::
+     WithIPList (SubscriptionTrace Socket.SockAddr)
+  -> SeverityS
+severityIpSubscription WithIPList {..} = case wilEvent of
+    SubscriptionTraceConnectStart _ -> Info
+    SubscriptionTraceConnectEnd _ connectResult -> case connectResult of
+      ConnectSuccess         -> Info
+      ConnectSuccessLast     -> Notice
+      ConnectValencyExceeded -> Warning
+    SubscriptionTraceConnectException _ e ->
+        case fromException $ SomeException e of
+             Just (_::SubscriberError) -> Debug
+             Nothing                   -> Error
+    SubscriptionTraceSocketAllocationException {} -> Error
+    SubscriptionTraceTryConnectToPeer {} -> Info
+    SubscriptionTraceSkippingPeer {} -> Info
+    SubscriptionTraceSubscriptionRunning -> Debug
+    SubscriptionTraceSubscriptionWaiting {} -> Debug
+    SubscriptionTraceSubscriptionFailed -> Error
+    SubscriptionTraceSubscriptionWaitingNewConnection {} -> Notice
+    SubscriptionTraceStart {} -> Debug
+    SubscriptionTraceRestart {} -> Info
+    SubscriptionTraceConnectionExist {} -> Notice
+    SubscriptionTraceUnsupportedRemoteAddr {} -> Error
+    SubscriptionTraceMissingLocalAddress -> Warning
+    SubscriptionTraceApplicationException _ e ->
+        case fromException $ SomeException e of
+             Just (_::SubscriberError) -> Debug
+             Nothing                   -> Error
+    SubscriptionTraceAllocateSocket {} -> Debug
+    SubscriptionTraceCloseSocket {} -> Info
+
+namesForIpSubscription ::
+     WithIPList (SubscriptionTrace Socket.SockAddr)
+  -> [Text]
+namesForIpSubscription WithIPList {..} = case wilEvent of
+    SubscriptionTraceConnectStart _ -> ["ConnectStart"]
+    SubscriptionTraceConnectEnd _ _connectResult -> ["ConnectEnd"]
+    SubscriptionTraceConnectException _ _e -> ["ConnectException"]
+    SubscriptionTraceSocketAllocationException {} -> ["SocketAllocationException"]
+    SubscriptionTraceTryConnectToPeer {}  -> ["TryConnectToPeer"]
+    SubscriptionTraceSkippingPeer {} -> ["SkippingPeer"]
+    SubscriptionTraceSubscriptionRunning -> ["SubscriptionRunning"]
+    SubscriptionTraceSubscriptionWaiting {} -> ["SubscriptionWaiting"]
+    SubscriptionTraceSubscriptionFailed -> ["SubscriptionFailed"]
+    SubscriptionTraceSubscriptionWaitingNewConnection {} -> ["SubscriptionWaitingNewConnection"]
+    SubscriptionTraceStart {} -> ["Start"]
+    SubscriptionTraceRestart {} -> ["Restart"]
+    SubscriptionTraceConnectionExist {} -> ["ConnectionExist"]
+    SubscriptionTraceUnsupportedRemoteAddr {} -> ["UnsupportedRemoteAddr"]
+    SubscriptionTraceMissingLocalAddress -> ["MissingLocalAddress"]
+    SubscriptionTraceApplicationException _ _e -> ["ApplicationException"]
+    SubscriptionTraceAllocateSocket {} -> ["AllocateSocket"]
+    SubscriptionTraceCloseSocket {} -> ["CloseSocket"]

cardano-node/src/Cardano/TraceDispatcher/Network/Docu.hs

@@ -12,10 +12,14 @@ module Cardano.TraceDispatcher.Network.Docu
   , docTBlockFetch
   , docTTxSubmissionNode
   , docTTxSubmission2Node
+  , docIpSubscriptionTracer
   ) where
 
 import           Cardano.Logging
 import           Cardano.Prelude
+import qualified Network.Socket as Socket
+import           Data.Time.Clock (DiffTime)
+
 
 import           Ouroboros.Consensus.Ledger.SupportsMempool (ApplyTxErr, GenTx,
                      GenTxId)
@@ -32,6 +36,9 @@ import qualified Ouroboros.Network.Protocol.LocalTxSubmission.Type as LTS
 import           Ouroboros.Network.Protocol.Trans.Hello.Type (Message (..))
 import qualified Ouroboros.Network.Protocol.TxSubmission.Type as TXS
 import qualified Ouroboros.Network.Protocol.TxSubmission2.Type as TXS
+import           Ouroboros.Network.Subscription.Ip (WithIPList (..))
+import           Ouroboros.Network.Subscription.Worker (ConnectResult (..),
+                     LocalAddresses, SubscriptionTrace (..))
 
 
 protoHeader :: header
@@ -67,6 +74,22 @@ protoBlockingReplyList = undefined
 protoTxId :: txid
 protoTxId = undefined
 
+protoLocalAdresses :: LocalAddresses addr
+protoLocalAdresses = undefined
+
+protoSocketAddress :: Socket.SockAddr
+protoSocketAddress = undefined
+
+protoRes :: ConnectResult
+protoRes = undefined
+
+protoDiffTime :: DiffTime
+protoDiffTime = undefined
+
+protoException :: NoMethodError
+protoException = undefined
+
+
 ------------------------------------
 
 docTChainSync :: Documented (BlockFetch.TraceLabelPeer peer (TraceSendRecv
@@ -536,3 +559,86 @@ docTTxSubmission2Node = Documented [
         \making a blocking call for more transaction identifiers."
   --TODO: Can't use 'MsgKThxBye' because NodeToNodeV_2 is not introduced yet.
   ]
+
+docIpSubscriptionTracer :: Documented (WithIPList (SubscriptionTrace Socket.SockAddr))
+docIpSubscriptionTracer = Documented $ map withIPList (undoc docSubscriptionTracer)
+  where
+    withIPList (DocMsg v nl comment) =
+      DocMsg (WithIPList protoLocalAdresses [] v) nl comment
+
+docSubscriptionTracer :: Documented (SubscriptionTrace Socket.SockAddr)
+docSubscriptionTracer = Documented [
+      DocMsg
+        (SubscriptionTraceConnectStart protoSocketAddress)
+        []
+        "Connection Attempt Start with destination."
+    , DocMsg
+        (SubscriptionTraceConnectEnd protoSocketAddress protoRes)
+        []
+        "Connection Attempt end with destination and outcome."
+    , DocMsg
+        (SubscriptionTraceSocketAllocationException protoSocketAddress protoException)
+        []
+        "Socket Allocation Exception with destination and the exception."
+    , DocMsg
+        (SubscriptionTraceConnectException protoSocketAddress protoException)
+        []
+        "Connection Attempt Exception with destination and exception."
+    , DocMsg
+        (SubscriptionTraceTryConnectToPeer protoSocketAddress)
+        []
+        "Trying to connect to peer with address."
+    , DocMsg
+        (SubscriptionTraceSkippingPeer protoSocketAddress)
+        []
+        "Skipping peer with address."
+    , DocMsg
+        SubscriptionTraceSubscriptionRunning
+        []
+        "Required subscriptions started."
+    , DocMsg
+        (SubscriptionTraceSubscriptionWaiting 1)
+        []
+        "Waiting on address with active connections."
+    , DocMsg
+        SubscriptionTraceSubscriptionFailed
+        []
+        "Failed to start all required subscriptions."
+    , DocMsg
+        (SubscriptionTraceSubscriptionWaitingNewConnection protoDiffTime)
+        []
+        "Waiting delay time before attempting a new connection."
+    , DocMsg
+        (SubscriptionTraceStart 1)
+        []
+        "Starting Subscription Worker with a valency."
+    , DocMsg
+        (SubscriptionTraceRestart protoDiffTime 1 2)
+        []
+        "Restarting Subscription after duration with desired valency and\
+        \ current valency."
+    , DocMsg
+        (SubscriptionTraceConnectionExist protoSocketAddress)
+        []
+        "Connection exists to destination."
+    , DocMsg
+        (SubscriptionTraceUnsupportedRemoteAddr protoSocketAddress)
+        []
+        "Unsupported remote target address."
+    , DocMsg
+        SubscriptionTraceMissingLocalAddress
+        []
+        "Missing local address."
+    , DocMsg
+        (SubscriptionTraceApplicationException protoSocketAddress protoException)
+        []
+        "Application Exception occured."
+    , DocMsg
+        (SubscriptionTraceAllocateSocket protoSocketAddress)
+        []
+        "Allocate socket to address."
+    , DocMsg
+        (SubscriptionTraceCloseSocket protoSocketAddress)
+        []
+        "Closed socket to address."
+  ]

cardano-node/src/Cardano/TraceDispatcher/Network/Formatting.hs

@@ -16,6 +16,7 @@ module Cardano.TraceDispatcher.Network.Formatting
 
 import           Data.Aeson (Value (String), toJSON, (.=))
 import           Data.Text (pack)
+import qualified Network.Socket as Socket
 import           Text.Show
 
 import           Cardano.TraceDispatcher.Common.Formatting ()
@@ -46,6 +47,8 @@ import           Ouroboros.Network.Protocol.Trans.Hello.Type
                      (ClientHasAgency (..), Message (..), ServerHasAgency (..))
 import qualified Ouroboros.Network.Protocol.TxSubmission.Type as STX
 import qualified Ouroboros.Network.Protocol.TxSubmission2.Type as TXS
+import           Ouroboros.Network.Subscription.Ip (SubscriptionTrace,
+                     WithIPList (..))
 
 instance LogFormatting (AnyMessageAndAgency ps)
       => LogFormatting (TraceSendRecv ps) where
@@ -302,3 +305,11 @@ instance (Show txid, Show tx)
                   (ServerAgency (TokServerTalk stok))
                   (MsgTalk msg)) =
     forMachine dtal (AnyMessageAndAgency (ServerAgency stok) msg)
+
+instance LogFormatting (WithIPList (SubscriptionTrace Socket.SockAddr)) where
+  forMachine _dtal (WithIPList localAddresses dests ev) =
+    mkObject [ "kind" .= String "WithIPList SubscriptionTrace"
+             , "localAddresses" .= String (pack $ show localAddresses)
+             , "dests" .= String (pack $ show dests)
+             , "event" .= String (pack $ show ev)]
+  forHuman  obj = pack $ show obj

cardano-node/src/Cardano/TraceDispatcher/Tracers.hs

@@ -258,14 +258,19 @@ mkDispatchTracers' trBase = do
                 severityTBlockFetchSerialised
                 trBase
     tsnTr  <-  mkStandardTracer
-                "TxSubmissionTracer"
-                namesForTxSubmissionTracerNode
-                severityTxSubmissionTracerNode
+                "TxSubmission"
+                namesForTxSubmissionNode
+                severityTxSubmissionNode
                 trBase
     ts2nTr  <-  mkStandardTracer
-                "TxSubmission2Tracer"
-                namesForTxSubmission2TracerNode
-                severityTxSubmission2TracerNode
+                "TxSubmission2"
+                namesForTxSubmission2Node
+                severityTxSubmission2Node
+                trBase
+    ipsTr   <-  mkStandardTracer
+                "IpSubscription"
+                namesForIpSubscription
+                severityIpSubscription
                 trBase
     pure Tracers
       { chainDBTracer = T.Tracer (traceWith cdbmTr)
@@ -299,7 +304,7 @@ mkDispatchTracers' trBase = do
         , NodeToNode.tTxSubmissionTracer = T.Tracer (traceWith tsnTr)
         , NodeToNode.tTxSubmission2Tracer = T.Tracer (traceWith ts2nTr)
         }
-      , ipSubscriptionTracer = T.nullTracer
+      , ipSubscriptionTracer = T.Tracer (traceWith ipsTr)
       , dnsSubscriptionTracer= T.nullTracer
       , dnsResolverTracer = T.nullTracer
       , errorPolicyTracer = T.nullTracer
@@ -376,6 +381,8 @@ configTracers config Tracers {..} = do
       [traceTrans (NodeToNode.tTxSubmissionTracer nodeToNodeTracers)]
     configureTracers config docTTxSubmission2Node
       [traceTrans (NodeToNode.tTxSubmission2Tracer nodeToNodeTracers)]
+    configureTracers config docIpSubscriptionTracer
+      [traceTrans ipSubscriptionTracer]      
     pure ()
 
 docTracers :: forall peer localPeer blk.