wip

cabal.project

@@ -64,3 +64,23 @@ allow-newer:
 -- IMPORTANT
 -- Do NOT add more source-repository-package stanzas here unless they are strictly
 -- temporary! Please read the section in CONTRIBUTING about updating dependencies.
+
+source-repository-package
+  type: git
+  location: https://github.com/IntersectMBO/ouroboros-consensus.git
+  tag: a444fe90a2393c7ba82e8aae1107b4a0783dccb9
+  --sha256: sha256-wU4jAZ8UYVWv5pgLBZGwbEDKSfjvfRvuv5jO59u0mO8=
+  subdir:
+    ouroboros-consensus
+    ouroboros-consensus-cardano
+    ouroboros-consensus-protocol
+    ouroboros-consensus-diffusion
+
+source-repository-package
+  type: git
+  location: https://github.com/IntersectMBO/ouroboros-network.git
+  --sha256: sha256-rzcyX0ORR57ktTH0tgrUbOAR0NMaWt+KFv3bjaV8U9Q=
+  tag: 21b15c2a51a31c26af9a6e3461b22ae38d6881e0
+  subdir:
+    ouroboros-network
+    ouroboros-network-api

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

@@ -16,7 +16,7 @@ module Cardano.Node.Configuration.NodeAddress
   , NodeDnsAddress
   , nodeIPv4ToIPAddress
   , nodeIPv6ToIPAddress
-  , nodeDnsAddressToDomainAddress
+  -- , nodeDnsAddressToDomainAddress
   , NodeHostIPAddress (..)
   , nodeHostIPAddressToSockAddr
   , NodeHostIPv4Address (..)
@@ -32,7 +32,7 @@ module Cardano.Node.Configuration.NodeAddress
 
 import           Cardano.Api
 
-import           Ouroboros.Network.PeerSelection.RelayAccessPoint (DomainAccessPoint (..))
+-- import           Ouroboros.Network.PeerSelection.RelayAccessPoint (DomainAccessPoint (..))
 
 import           Data.Aeson (FromJSON (..), ToJSON (..), Value (..), object, withObject, (.:), (.=))
 import           Data.IP (IP (..), IPv4, IPv6)
@@ -76,9 +76,9 @@ nodeIPv4ToIPAddress = fmap nodeHostIPv4AddressToIPAddress
 nodeIPv6ToIPAddress :: NodeIPv6Address -> NodeIPAddress
 nodeIPv6ToIPAddress = fmap nodeHostIPv6AddressToIPAddress
 
-nodeDnsAddressToDomainAddress :: NodeDnsAddress -> DomainAccessPoint
-nodeDnsAddressToDomainAddress NodeAddress { naHostAddress = NodeHostDnsAddress dns, naPort }
-  = DomainAccessPoint (Text.encodeUtf8 dns) naPort
+-- nodeDnsAddressToDomainAddress :: NodeDnsAddress -> DomainAccessPoint
+-- nodeDnsAddressToDomainAddress NodeAddress { naHostAddress = NodeHostDnsAddress dns, naPort }
+--   = DomainAccessPoint (Text.encodeUtf8 dns) naPort
 
 nodeAddressToSockAddr :: NodeIPAddress -> SockAddr
 nodeAddressToSockAddr (NodeAddress addr port) =
@@ -158,4 +158,3 @@ newtype NodeHostDnsAddress
 
 nodeHostDnsAddressToDomain :: NodeHostDnsAddress -> DNS.Domain
 nodeHostDnsAddressToDomain = Text.encodeUtf8 . unNodeHostDnsAddress
-

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

@@ -631,6 +631,9 @@ mkDiffusionTracersExtra configReflection trBase trForward mbTrEKG _trDataPoint t
     !dtLedgerPeersTr   <- mkCardanoTracer
       trBase trForward mbTrEKG
       ["Net", "Peers", "Ledger"]
+    !dtDnsTr <- mkCardanoTracer
+      trBase trForward mbTrEKG
+      ["Net", "PeerSelection", "DNS"]
     configureTracers configReflection trConfig [dtLedgerPeersTr]
 
     pure $ Diffusion.P2PTracers P2P.TracersExtra
@@ -668,6 +671,8 @@ mkDiffusionTracersExtra configReflection trBase trForward mbTrEKG _trDataPoint t
                  traceWith localServerTr
              , P2P.dtTraceLedgerPeersTracer = Tracer $
                  traceWith dtLedgerPeersTr
+             , P2P.dtDnsTracer = Tracer $
+                 traceWith dtDnsTr
              }
 
 mkDiffusionTracersExtra configReflection trBase trForward mbTrEKG _trDataPoint trConfig DisabledP2PMode = do

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

@@ -14,9 +14,11 @@
 module Cardano.Node.Tracing.Tracers.Diffusion
   () where
 
-
+import qualified Data.Text.Encoding as Text
+import           Ouroboros.Network.PeerSelection.RootPeersDNS.DNSActions
 import           Cardano.Logging
-import           Data.Aeson (Value (String), (.=))
+import           Data.Aeson (ToJSON (..), Value (String), (.=))
+import qualified Data.Aeson as Aeson
 import           Data.Text (pack)
 import           Formatting
 import qualified Network.Mux as Mux
@@ -757,6 +759,30 @@ instance MetaTrace (ND.DiffusionTracer ntnAddr ntcAddr) where
       , Namespace [] ["SystemdSocketConfiguration"]
       ]
 
+
+instance
+  (
+  ) => LogFormatting DnsTrace where
+  forMachine _dtal (DnsResult peerKind domain mSRVDomain result) =
+    mconcat [ "kind" .= String "DnsResult"
+            , "peerType" .= show peerKind
+            , "domain" .= Text.decodeUtf8 domain
+            , "viaSRV" .= toJSON (Text.decodeUtf8 <$> mSRVDomain)
+            , "result" .= Aeson.toJSONList result
+            ]
+  forMachine _dtal (DnsTraceLookupError peerKind lookupType domain dnsError) =
+    mconcat [ "kind" .= String "DnsTraceLookupError"
+            , "peerType" .= show peerKind
+            , "DNSLookupType" .= toJSON (show <$> lookupType)
+            , "domain" .= Text.decodeUtf8 domain
+            , "DNSError" .= show dnsError
+            ]
+  forMachine _dtal (DnsSRVFail peerKind domain) =
+    mconcat [ "kind" .= String "DnsSRVFail"
+            , "peerType" .= show peerKind
+            , "domain" .= Text.decodeUtf8 domain
+            ]
+
 --------------------------------------------------------------------------------
 -- LedgerPeers Tracer
 --------------------------------------------------------------------------------
@@ -839,23 +865,50 @@ instance LogFormatting TraceLedgerPeers where
       [ "kind" .= String "TraceLedgerPeersDomains"
       , "domainAccessPoints" .= daps
       ]
-  forMachine _dtal (TraceLedgerPeersResult dap ips) =
-    mconcat
-      [ "kind" .= String "TraceLedgerPeersResult"
-      , "domainAccessPoint" .= show dap
-      , "ips" .= map show ips
-      ]
-  forMachine _dtal (TraceLedgerPeersFailure dap reason) =
-    mconcat
-      [ "kind" .= String "TraceLedgerPeersFailure"
-      , "domainAccessPoint" .= show dap
-      , "error" .= show reason
-      ]
+  -- forMachine _dtal (TraceLedgerPeersResult dap ips) =
+  --   mconcat
+  --     [ "kind" .= String "TraceLedgerPeersResult"
+  --     , "domainAccessPoint" .= show dap
+  --     , "ips" .= map show ips
+  --     ]
+  -- forMachine _dtal (TraceLedgerPeersFailure dap reason) =
+  --   mconcat
+  --     [ "kind" .= String "TraceLedgerPeersFailure"
+  --     , "domainAccessPoint" .= show dap
+  --     , "error" .= show reason
+  --     ]
   forMachine _dtal UsingBigLedgerPeerSnapshot =
     mconcat
       [ "kind" .= String "UsingBigLedgerPeerSnapshot"
       ]
 
+instance MetaTrace DnsTrace where
+  namespaceFor DnsResult {} =
+    Namespace [] ["DnsResult"]
+  namespaceFor DnsTraceLookupError {} =
+    Namespace [] ["DnsTraceLookupError"]
+  namespaceFor DnsSRVFail {} =
+    Namespace [] ["DnsSRVFail"]
+
+  severityFor (Namespace _ ["DnsResult"]) _ = Just Debug
+  severityFor (Namespace _ ["DnsTraceLookupError"]) _ = Just Debug
+  severityFor (Namespace _ ["DnsSRVFail"]) _ = Just Debug
+  severityFor _ _ = Nothing
+
+  documentFor (Namespace _ ["DnsResult"]) = Just
+    ""
+  documentFor (Namespace _ ["DnsTraceLookupError"]) = Just
+    ""
+  documentFor (Namespace _ ["DnsSRVFail"]) = Just
+    ""
+  documentFor _ = Nothing
+
+  allNamespaces = [
+      Namespace [] ["DnsResult"]
+    , Namespace [] ["DnsTraceLookupError"]
+    , Namespace [] ["DnsSRVFail"]
+    ]
+
 instance MetaTrace TraceLedgerPeers where
     namespaceFor PickedLedgerPeer {} =
       Namespace [] ["PickedLedgerPeer"]
@@ -885,10 +938,10 @@ instance MetaTrace TraceLedgerPeers where
       Namespace [] ["NotEnoughBigLedgerPeers"]
     namespaceFor TraceLedgerPeersDomains {} =
       Namespace [] ["TraceLedgerPeersDomains"]
-    namespaceFor TraceLedgerPeersResult {} =
-      Namespace [] ["TraceLedgerPeersResult"]
-    namespaceFor TraceLedgerPeersFailure {} =
-      Namespace [] ["TraceLedgerPeersFailure"]
+    -- namespaceFor TraceLedgerPeersResult {} =
+    --   Namespace [] ["TraceLedgerPeersResult"]
+    -- namespaceFor TraceLedgerPeersFailure {} =
+    --   Namespace [] ["TraceLedgerPeersFailure"]
     namespaceFor UsingBigLedgerPeerSnapshot {} =
       Namespace [] ["UsingBigLedgerPeerSnapshot"]
 

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

@@ -19,6 +19,8 @@
 module Cardano.Node.Tracing.Tracers.P2P
   () where
 
+-- import qualified Data.Text as Text
+import qualified Data.Text.Encoding as Text
 import           Cardano.Logging
 import           Cardano.Node.Configuration.TopologyP2P ()
 import           Cardano.Node.Tracing.Tracers.NodeToNode ()
@@ -84,11 +86,11 @@ instance
              , "domainAddress" .= toJSON d
              , "diffTime" .= show dt
              ]
-  forMachine _dtal (TraceLocalRootResult d res) =
-    mconcat [ "kind" .= String "LocalRootResult"
-             , "domainAddress" .= toJSON d
-             , "result" .= toJSONList res
-             ]
+  -- forMachine _dtal (TraceLocalRootResult d res) =
+  --   mconcat [ "kind" .= String "LocalRootResult"
+  --            , "domainAddress" .= toJSON d
+  --            , "result" .= toJSONList res
+  --            ]
   forMachine _dtal (TraceLocalRootGroups groups) =
     mconcat [ "kind" .= String "LocalRootGroups"
              , "localRootGroups" .= toJSON groups
@@ -100,7 +102,7 @@ instance
              ]
   forMachine _dtal (TraceLocalRootError d exception) =
     mconcat [ "kind" .= String "LocalRootError"
-             , "domainAddress" .= toJSON d
+             , "domainAddress" .= Text.decodeUtf8 d
              , "reason" .= show exception
              ]
   forMachine _dtal (TraceLocalRootReconfigured d exception) =
@@ -119,7 +121,7 @@ instance MetaTrace (TraceLocalRootPeers ntnAddr exception) where
   namespaceFor = \case
     TraceLocalRootDomains {}      -> Namespace [] ["LocalRootDomains"]
     TraceLocalRootWaiting {}      -> Namespace [] ["LocalRootWaiting"]
-    TraceLocalRootResult {}       -> Namespace [] ["LocalRootResult"]
+    -- TraceLocalRootResult {}       -> Namespace [] ["LocalRootResult"]
     TraceLocalRootGroups {}       -> Namespace [] ["LocalRootGroups"]
     TraceLocalRootFailure {}      -> Namespace [] ["LocalRootFailure"]
     TraceLocalRootError {}        -> Namespace [] ["LocalRootError"]
@@ -178,23 +180,23 @@ instance LogFormatting TracePublicRootPeers where
     mconcat [ "kind" .= String "PublicRootDomains"
              , "domainAddresses" .= toJSONList domains
              ]
-  forMachine _dtal (TracePublicRootResult b res) =
-    mconcat [ "kind" .= String "PublicRootResult"
-             , "domain" .= show b
-             , "result" .= toJSONList res
-             ]
-  forMachine _dtal (TracePublicRootFailure b d) =
-    mconcat [ "kind" .= String "PublicRootFailure"
-             , "domain" .= show b
-             , "reason" .= show d
-             ]
+  -- forMachine _dtal (TracePublicRootResult b res) =
+  --   mconcat [ "kind" .= String "PublicRootResult"
+  --            , "domain" .= show b
+  --            , "result" .= toJSONList res
+  --            ]
+  -- forMachine _dtal (TracePublicRootFailure b d) =
+  --   mconcat [ "kind" .= String "PublicRootFailure"
+  --            , "domain" .= show b
+  --            , "reason" .= show d
+  --            ]
   forHuman = pack . show
 
 instance MetaTrace TracePublicRootPeers where
   namespaceFor TracePublicRootRelayAccessPoint {} = Namespace [] ["PublicRootRelayAccessPoint"]
   namespaceFor TracePublicRootDomains {} = Namespace [] ["PublicRootDomains"]
-  namespaceFor TracePublicRootResult {} = Namespace [] ["PublicRootResult"]
-  namespaceFor TracePublicRootFailure {} = Namespace [] ["PublicRootFailure"]
+  -- namespaceFor TracePublicRootResult {} = Namespace [] ["PublicRootResult"]
+  -- namespaceFor TracePublicRootFailure {} = Namespace [] ["PublicRootFailure"]
 
   severityFor (Namespace [] ["PublicRootRelayAccessPoint"]) _ = Just Info
   severityFor (Namespace [] ["PublicRootDomains"]) _ = Just Info

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

@@ -37,6 +37,7 @@ module Cardano.Tracing.Config
   , TraceDiffusionInitialization
   , TraceDnsResolver
   , TraceDnsSubscription
+  , TraceDns
   , TraceErrorPolicy
   , TraceForge
   , TraceForgeStateInfo
@@ -140,6 +141,7 @@ type DebugPeerSelectionInitiator = ("DebugPeerSelectionInitiator" :: Symbol)
 type DebugPeerSelectionInitiatorResponder = ("DebugPeerSelectionInitiatorResponder" :: Symbol)
 type TraceDiffusionInitialization = ("TraceDiffusionInitialization" :: Symbol)
 type TraceDnsResolver = ("TraceDnsResolver" :: Symbol)
+type TraceDns = ("TraceDns" :: Symbol)
 type TraceDnsSubscription = ("TraceDnsSubscription" :: Symbol)
 type TraceErrorPolicy = ("TraceErrorPolicy" :: Symbol)
 type TraceForge = ("TraceForge" :: Symbol)
@@ -212,6 +214,7 @@ data TraceSelection
   , traceDebugPeerSelectionInitiatorTracer :: OnOff DebugPeerSelectionInitiator
   , traceDebugPeerSelectionInitiatorResponderTracer :: OnOff DebugPeerSelectionInitiatorResponder
   , traceDiffusionInitialization :: OnOff TraceDiffusionInitialization
+  , traceDns :: OnOff TraceDns
   , traceDnsResolver :: OnOff TraceDnsResolver
   , traceDnsSubscription :: OnOff TraceDnsSubscription
   , traceErrorPolicy :: OnOff TraceErrorPolicy
@@ -319,6 +322,7 @@ data PartialTraceSelection
       , pTraceKeepAliveProtocol :: Last (OnOff TraceKeepAliveProtocol)
       , pTraceGsm :: Last (OnOff TraceGsm)
       , pTraceCsj :: Last (OnOff TraceCsj)
+      , pTraceDns :: Last (OnOff TraceDns)
       } deriving (Eq, Generic, Show)
 
 
@@ -387,6 +391,7 @@ instance FromJSON PartialTraceSelection where
       <*> parseTracer (Proxy @TraceKeepAliveProtocol) v
       <*> parseTracer (Proxy @TraceGsm) v
       <*> parseTracer (Proxy @TraceCsj) v
+      <*> parseTracer (Proxy @TraceDns) v
 
 
 defaultPartialTraceConfiguration :: PartialTraceSelection
@@ -452,6 +457,7 @@ defaultPartialTraceConfiguration =
     , pTraceKeepAliveProtocol = pure $ OnOff False
     , pTraceGsm = pure $ OnOff True
     , pTraceCsj = pure $ OnOff True
+    , pTraceDns = pure $ OnOff True
     }
 
 
@@ -519,6 +525,7 @@ partialTraceSelectionToEither (Last (Just (PartialTraceDispatcher pTraceSelectio
    traceKeepAliveProtocol <- proxyLastToEither (Proxy @TraceKeepAliveProtocol) pTraceKeepAliveProtocol
    traceGsm <- proxyLastToEither (Proxy @TraceGsm) pTraceGsm
    traceCsj <- proxyLastToEither (Proxy @TraceCsj) pTraceCsj
+   traceDns <- proxyLastToEither (Proxy @TraceDns) pTraceDns
    Right $ TraceDispatcher $ TraceSelection
              { traceVerbosity = traceVerbosity
              , traceAcceptPolicy = traceAcceptPolicy
@@ -579,6 +586,7 @@ partialTraceSelectionToEither (Last (Just (PartialTraceDispatcher pTraceSelectio
              , traceKeepAliveProtocol = traceKeepAliveProtocol
              , traceGsm = traceGsm
              , traceCsj = traceCsj
+             , traceDns = traceDns
              }
 
 partialTraceSelectionToEither (Last (Just (PartialTracingOnLegacy pTraceSelection))) = do
@@ -643,6 +651,7 @@ partialTraceSelectionToEither (Last (Just (PartialTracingOnLegacy pTraceSelectio
   traceKeepAliveProtocol <- proxyLastToEither (Proxy @TraceKeepAliveProtocol) pTraceKeepAliveProtocol
   traceGsm <- proxyLastToEither (Proxy @TraceGsm) pTraceGsm
   traceCsj <- proxyLastToEither (Proxy @TraceCsj) pTraceCsj
+  traceDns <- proxyLastToEither (Proxy @TraceDns) pTraceDns
   Right $ TracingOnLegacy $ TraceSelection
             { traceVerbosity = traceVerbosity
             , traceAcceptPolicy = traceAcceptPolicy
@@ -703,6 +712,7 @@ partialTraceSelectionToEither (Last (Just (PartialTracingOnLegacy pTraceSelectio
             , traceKeepAliveProtocol = traceKeepAliveProtocol
             , traceGsm = traceGsm
             , traceCsj = traceCsj
+            , traceDns = traceDns
             }
 
 proxyLastToEither :: KnownSymbol name => Proxy name -> Last (OnOff name) -> Either Text (OnOff name)