{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs             #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PackageImports    #-}

--------------------------------------------------------------------------------

-- Orphan instances module for Cardano tracer.
{-# OPTIONS_GHC -Wno-orphans #-}
-- Extracted from "cardano-node" `Cardano.Node.Tracing.Tracers.Diffusion`.
-- Branch "master" (2026-02-11, 85869e9dd21d9dac7c4381418346e97259c3303b).

--------------------------------------------------------------------------------

module Ouroboros.Network.Tracing () where

--------------------------------------------------------------------------------

---------
-- base -
---------
--
---------------------
-- Package: "aeson" -
---------------------
import "aeson" Data.Aeson (Value (String), (.=))
-----------------------
-- Package: "iproute" -
-----------------------
import "iproute" Data.IP qualified as IP
-----------------------
-- Package: "network" -
-----------------------
import "network" Network.Socket (SockAddr (..))
--------------------
-- Package: "text" -
--------------------
import "text" Data.Text (Text, pack)
---------------------------------
-- Package: "ouroboros-network" -
---------------------------------
import "ouroboros-network" Ouroboros.Network.Protocol.Handshake.Type qualified as HS
import "ouroboros-network" Ouroboros.Network.Snocket (LocalAddress (..),
           RemoteAddress)
-------------------------------
-- Package: "typed-protocols" -
-------------------------------
import "typed-protocols" Network.TypedProtocol.Codec (AnyMessage (..))
--------------------------------
-- Package: "trace-dispatcher" -
--------------------------------
import "trace-dispatcher" Cardano.Logging
---------
-- Self -
---------
import Ouroboros.Network.Tracing.ConnectionId ()
import Ouroboros.Network.Tracing.ConnectionManager ()
import Ouroboros.Network.Tracing.Driver ()
import Ouroboros.Network.Tracing.InboundGovernor ()
import Ouroboros.Network.Tracing.Server ()

--------------------------------------------------------------------------------
-- Addresses.
--------------------------------------------------------------------------------

-- From `Cardano.Node.Tracing.Tracers.P2P`
-- Branch "ana/10.6-final-integration-mix"

instance LogFormatting LocalAddress where
    forMachine :: DetailLevel -> LocalAddress -> Object
forMachine DetailLevel
_dtal (LocalAddress FilePath
path) =
        [Object] -> Object
forall a. Monoid a => [a] -> a
mconcat [Key
"path" Key -> FilePath -> Object
forall v. ToJSON v => Key -> v -> Object
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= FilePath
path]

instance LogFormatting RemoteAddress where
    forMachine :: DetailLevel -> RemoteAddress -> Object
forMachine DetailLevel
_dtal (SockAddrInet PortNumber
port HostAddress
addr) =
        let ip :: IPv4
ip = HostAddress -> IPv4
IP.fromHostAddress HostAddress
addr in
        [Object] -> Object
forall a. Monoid a => [a] -> a
mconcat [ Key
"addr" Key -> FilePath -> Object
forall v. ToJSON v => Key -> v -> Object
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= IPv4 -> FilePath
forall a. Show a => a -> FilePath
show IPv4
ip
                 , Key
"port" Key -> FilePath -> Object
forall v. ToJSON v => Key -> v -> Object
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= PortNumber -> FilePath
forall a. Show a => a -> FilePath
show PortNumber
port
                 ]
    forMachine DetailLevel
_dtal (SockAddrInet6 PortNumber
port HostAddress
_ HostAddress6
addr HostAddress
_) =
        let ip :: IPv6
ip = HostAddress6 -> IPv6
IP.fromHostAddress6 HostAddress6
addr in
        [Object] -> Object
forall a. Monoid a => [a] -> a
mconcat [ Key
"addr" Key -> FilePath -> Object
forall v. ToJSON v => Key -> v -> Object
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= IPv6 -> FilePath
forall a. Show a => a -> FilePath
show IPv6
ip
                 , Key
"port" Key -> FilePath -> Object
forall v. ToJSON v => Key -> v -> Object
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= PortNumber -> FilePath
forall a. Show a => a -> FilePath
show PortNumber
port
                 ]
    forMachine DetailLevel
_dtal (SockAddrUnix FilePath
path) =
        [Object] -> Object
forall a. Monoid a => [a] -> a
mconcat [ Key
"path" Key -> FilePath -> Object
forall v. ToJSON v => Key -> v -> Object
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= FilePath -> FilePath
forall a. Show a => a -> FilePath
show FilePath
path ]

--------------------------------------------------------------------------------
-- Handshake Tracer.
--------------------------------------------------------------------------------

-- From `Cardano.Node.Tracing.Tracers.Diffusion`
-- Branch "ana/10.6-final-integration-mix"

instance (Show term, Show ntcVersion) =>
  LogFormatting (AnyMessage (HS.Handshake ntcVersion term)) where
  forMachine :: DetailLevel -> AnyMessage (Handshake ntcVersion term) -> Object
forMachine DetailLevel
_dtal (AnyMessageAndAgency StateToken st
stok Message (Handshake ntcVersion term) st st'
msg) =
    [Object] -> Object
forall a. Monoid a => [a] -> a
mconcat [ Key
"kind" Key -> Value -> Object
forall v. ToJSON v => Key -> v -> Object
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text -> Value
String Text
kind
            , Key
"msg" Key -> Value -> Object
forall v. ToJSON v => Key -> v -> Object
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (Text -> Value
String (Text -> Value)
-> (Message (Handshake ntcVersion term) st st' -> Text)
-> Message (Handshake ntcVersion term) st st'
-> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Message (Handshake ntcVersion term) st st' -> Text
forall a. Show a => a -> Text
showT (Message (Handshake ntcVersion term) st st' -> Value)
-> Message (Handshake ntcVersion term) st st' -> Value
forall a b. (a -> b) -> a -> b
$ Message (Handshake ntcVersion term) st st'
msg)
            , Key
"agency" Key -> Value -> Object
forall v. ToJSON v => Key -> v -> Object
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text -> Value
String (FilePath -> Text
pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ SingHandshake st -> FilePath
forall a. Show a => a -> FilePath
show StateToken st
SingHandshake st
stok)
            ]
    where
      kind :: Text
kind = case Message (Handshake ntcVersion term) st st'
msg of
        HS.MsgProposeVersions {} -> Text
"ProposeVersions"
        HS.MsgReplyVersions   {} -> Text
"ReplyVersions"
        HS.MsgQueryReply      {} -> Text
"QueryReply"
        HS.MsgAcceptVersion   {} -> Text
"AcceptVersion"
        HS.MsgRefuse          {} -> Text
"Refuse"

  forHuman :: AnyMessage (Handshake ntcVersion term) -> Text
forHuman (AnyMessageAndAgency StateToken st
stok Message (Handshake ntcVersion term) st st'
msg) =
    Text
"Handshake (agency, message) = " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> SingHandshake st -> Text
forall a. Show a => a -> Text
showT StateToken st
SingHandshake st
stok Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"," Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Message (Handshake ntcVersion term) st st' -> Text
forall a. Show a => a -> Text
showT Message (Handshake ntcVersion term) st st'
msg Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"

instance MetaTrace (AnyMessage (HS.Handshake a b)) where
  namespaceFor :: AnyMessage (Handshake a b)
-> Namespace (AnyMessage (Handshake a b))
namespaceFor (AnyMessage Message (Handshake a b) st st'
msg) = [Text] -> [Text] -> Namespace (AnyMessage (Handshake a b))
forall a. [Text] -> [Text] -> Namespace a
Namespace [] ([Text] -> Namespace (AnyMessage (Handshake a b)))
-> [Text] -> Namespace (AnyMessage (Handshake a b))
forall a b. (a -> b) -> a -> b
$ case Message (Handshake a b) st st'
msg of
    HS.MsgProposeVersions {} -> [Text
"ProposeVersions"]
    HS.MsgReplyVersions   {} -> [Text
"ReplyVersions"]
    HS.MsgQueryReply      {} -> [Text
"QueryReply"]
    HS.MsgAcceptVersion   {} -> [Text
"AcceptVersion"]
    HS.MsgRefuse          {} -> [Text
"Refuse"]

  severityFor :: Namespace (AnyMessage (Handshake a b))
-> Maybe (AnyMessage (Handshake a b)) -> Maybe SeverityS
severityFor (Namespace [Text]
_ [Text
sym]) Maybe (AnyMessage (Handshake a b))
_ = case Text
sym of
    Text
"ProposeVersions" -> SeverityS -> Maybe SeverityS
forall a. a -> Maybe a
Just SeverityS
Debug
    Text
"ReplyVersions"   -> SeverityS -> Maybe SeverityS
forall a. a -> Maybe a
Just SeverityS
Debug
    Text
"QueryReply"      -> SeverityS -> Maybe SeverityS
forall a. a -> Maybe a
Just SeverityS
Debug
    Text
"AcceptVersion"   -> SeverityS -> Maybe SeverityS
forall a. a -> Maybe a
Just SeverityS
Debug
    Text
"Refuse"          -> SeverityS -> Maybe SeverityS
forall a. a -> Maybe a
Just SeverityS
Debug
    Text
_otherwise        -> Maybe SeverityS
forall a. Maybe a
Nothing
  severityFor Namespace (AnyMessage (Handshake a b))
_ Maybe (AnyMessage (Handshake a b))
_ = Maybe SeverityS
forall a. Maybe a
Nothing

  documentFor :: Namespace (AnyMessage (Handshake a b)) -> Maybe Text
documentFor (Namespace [Text]
_ [Text]
sym) = Text -> Maybe Text
forall {a}. (Eq a, IsString a) => a -> Maybe a
wrap (Text -> Maybe Text) -> ([Text] -> Text) -> [Text] -> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat ([Text] -> Maybe Text) -> [Text] -> Maybe Text
forall a b. (a -> b) -> a -> b
$ case [Text]
sym of
    [Text
"ProposeVersions"] ->
      [ Text
"Propose versions together with version parameters.  It must be"
      , Text
" encoded to a sorted list.."
      ]
    [Text
"ReplyVersions"]   ->
      [ Text
"`MsgReplyVersions` received as a response to 'MsgProposeVersions'.  It"
      , Text
" is not supported to explicitly send this message. It can only be"
      , Text
" received as a copy of 'MsgProposeVersions' in a simultaneous open"
      , Text
" scenario."
      ]
    [Text
"QueryReply"]      ->
      [ Text
"`MsgQueryReply` received as a response to a handshake query in "
      , Text
" 'MsgProposeVersions' and lists the supported versions."
      ]
    [Text
"AcceptVersion"]   ->
      [ Text
"The remote end decides which version to use and sends chosen version."
      , Text
"The server is allowed to modify version parameters."
      ]
    [Text
"Refuse"]          -> [Text
"It refuses to run any version."]
    [Text]
_otherwise          -> [] :: [Text]
    where
      wrap :: a -> Maybe a
wrap a
it = case a
it of
        a
""  -> Maybe a
forall a. Maybe a
Nothing
        a
it' -> a -> Maybe a
forall a. a -> Maybe a
Just a
it'

  allNamespaces :: [Namespace (AnyMessage (Handshake a b))]
allNamespaces = [
      [Text] -> [Text] -> Namespace (AnyMessage (Handshake a b))
forall a. [Text] -> [Text] -> Namespace a
Namespace [] [Text
"ProposeVersions"]
    , [Text] -> [Text] -> Namespace (AnyMessage (Handshake a b))
forall a. [Text] -> [Text] -> Namespace a
Namespace [] [Text
"ReplyVersions"]
    , [Text] -> [Text] -> Namespace (AnyMessage (Handshake a b))
forall a. [Text] -> [Text] -> Namespace a
Namespace [] [Text
"QueryReply"]
    , [Text] -> [Text] -> Namespace (AnyMessage (Handshake a b))
forall a. [Text] -> [Text] -> Namespace a
Namespace [] [Text
"AcceptVersion"]
    , [Text] -> [Text] -> Namespace (AnyMessage (Handshake a b))
forall a. [Text] -> [Text] -> Namespace a
Namespace [] [Text
"Refuse"]
    ]