{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PackageImports    #-}

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

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

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

module Ouroboros.Network.Tracing.Server () where

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

---------
-- base -
---------
--
---------------------
-- Package: "aeson" -
---------------------
import "aeson" Data.Aeson (ToJSON, Value (String), toJSON, (.=))
---------------------------------
-- Package: "ouroboros-network" -
---------------------------------
import "ouroboros-network" Ouroboros.Network.Server as Server
import "ouroboros-network" Ouroboros.Network.Server.RateLimiting qualified as SRL
-- Needed for `instance ToJSON (ConnectionId addr) where`
import "ouroboros-network" Ouroboros.Network.OrphanInstances qualified ()
--------------------
-- Package: "text" -
--------------------
import "text" Data.Text (pack)
--------------------------------
-- Package: "trace-dispatcher" -
--------------------------------
import "trace-dispatcher" Cardano.Logging
---------
-- Self -
---------
import Ouroboros.Network.Tracing.ConnectionId ()

--------------------------------------------------------------------------------
-- AcceptPolicy Tracer
--------------------------------------------------------------------------------

instance LogFormatting SRL.AcceptConnectionsPolicyTrace where
    forMachine :: DetailLevel -> AcceptConnectionsPolicyTrace -> Object
forMachine DetailLevel
_dtal (SRL.ServerTraceAcceptConnectionRateLimiting DiffTime
delay Int
numOfConnections) =
      [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
"ServerTraceAcceptConnectionRateLimiting"
               , Key
"delay" Key -> String -> Object
forall v. ToJSON v => Key -> v -> Object
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= DiffTime -> String
forall a. Show a => a -> String
show DiffTime
delay
               , Key
"numberOfConnection" Key -> String -> Object
forall v. ToJSON v => Key -> v -> Object
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Int -> String
forall a. Show a => a -> String
show Int
numOfConnections
               ]
    forMachine DetailLevel
_dtal (SRL.ServerTraceAcceptConnectionHardLimit Word32
softLimit) =
      [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
"ServerTraceAcceptConnectionHardLimit"
               , Key
"softLimit" Key -> String -> Object
forall v. ToJSON v => Key -> v -> Object
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Word32 -> String
forall a. Show a => a -> String
show Word32
softLimit
               ]
    forMachine DetailLevel
_dtal (SRL.ServerTraceAcceptConnectionResume Int
numOfConnections) =
      [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
"ServerTraceAcceptConnectionResume"
               , Key
"numberOfConnection" Key -> String -> Object
forall v. ToJSON v => Key -> v -> Object
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Int -> String
forall a. Show a => a -> String
show Int
numOfConnections
               ]
    forHuman :: AcceptConnectionsPolicyTrace -> Text
forHuman   = AcceptConnectionsPolicyTrace -> Text
forall a. Show a => a -> Text
showT

instance MetaTrace SRL.AcceptConnectionsPolicyTrace where
    namespaceFor :: AcceptConnectionsPolicyTrace
-> Namespace AcceptConnectionsPolicyTrace
namespaceFor SRL.ServerTraceAcceptConnectionRateLimiting {} =
      [Text] -> [Text] -> Namespace AcceptConnectionsPolicyTrace
forall a. [Text] -> [Text] -> Namespace a
Namespace [] [Text
"ConnectionRateLimiting"]
    namespaceFor SRL.ServerTraceAcceptConnectionHardLimit {} =
      [Text] -> [Text] -> Namespace AcceptConnectionsPolicyTrace
forall a. [Text] -> [Text] -> Namespace a
Namespace [] [Text
"ConnectionHardLimit"]
    namespaceFor SRL.ServerTraceAcceptConnectionResume {} =
      [Text] -> [Text] -> Namespace AcceptConnectionsPolicyTrace
forall a. [Text] -> [Text] -> Namespace a
Namespace [] [Text
"ConnectionLimitResume"]

    severityFor :: Namespace AcceptConnectionsPolicyTrace
-> Maybe AcceptConnectionsPolicyTrace -> Maybe SeverityS
severityFor (Namespace [Text]
_ [Text
"ConnectionRateLimiting"]) Maybe AcceptConnectionsPolicyTrace
_ = SeverityS -> Maybe SeverityS
forall a. a -> Maybe a
Just SeverityS
Info
    severityFor (Namespace [Text]
_ [Text
"ConnectionHardLimit"]) Maybe AcceptConnectionsPolicyTrace
_    = SeverityS -> Maybe SeverityS
forall a. a -> Maybe a
Just SeverityS
Warning
    severityFor (Namespace [Text]
_ [Text
"ConnectionLimitResume"]) Maybe AcceptConnectionsPolicyTrace
_  = SeverityS -> Maybe SeverityS
forall a. a -> Maybe a
Just SeverityS
Info
    severityFor Namespace AcceptConnectionsPolicyTrace
_ Maybe AcceptConnectionsPolicyTrace
_                                        = Maybe SeverityS
forall a. Maybe a
Nothing

    documentFor :: Namespace AcceptConnectionsPolicyTrace -> Maybe Text
documentFor (Namespace [Text]
_ [Text
"ConnectionRateLimiting"]) = Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
      [ Text
"Rate limiting accepting connections,"
      , Text
" delaying next accept for given time, currently serving n connections."
      ]
    documentFor (Namespace [Text]
_ [Text
"ConnectionHardLimit"]) = Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
      [ Text
"Hard rate limit reached,"
      , Text
" waiting until the number of connections drops below n."
      ]
    documentFor (Namespace [Text]
_ [Text
"ConnectionLimitResume"]) = Text -> Maybe Text
forall a. a -> Maybe a
Just
      Text
""
    documentFor Namespace AcceptConnectionsPolicyTrace
_ = Maybe Text
forall a. Maybe a
Nothing

    allNamespaces :: [Namespace AcceptConnectionsPolicyTrace]
allNamespaces = [
        [Text] -> [Text] -> Namespace AcceptConnectionsPolicyTrace
forall a. [Text] -> [Text] -> Namespace a
Namespace [] [Text
"ConnectionRateLimiting"]
      , [Text] -> [Text] -> Namespace AcceptConnectionsPolicyTrace
forall a. [Text] -> [Text] -> Namespace a
Namespace [] [Text
"ConnectionHardLimit"]
      , [Text] -> [Text] -> Namespace AcceptConnectionsPolicyTrace
forall a. [Text] -> [Text] -> Namespace a
Namespace [] [Text
"ConnectionLimitResume"]
      ]

--------------------------------------------------------------------------------
-- Server Tracer
--------------------------------------------------------------------------------

instance (Show addr, LogFormatting addr, ToJSON addr)
      => LogFormatting (Server.Trace addr) where
  forMachine :: DetailLevel -> Trace addr -> Object
forMachine DetailLevel
_dtal (TrAcceptConnection ConnectionId addr
connId)     =
    [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
"AcceptConnection"
             , Key
"address" Key -> Value -> Object
forall v. ToJSON v => Key -> v -> Object
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ConnectionId addr -> Value
forall a. ToJSON a => a -> Value
toJSON ConnectionId addr
connId
             ]
  forMachine DetailLevel
_dtal (TrAcceptError SomeException
exception)         =
    [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
"AcceptErroor"
             , Key
"reason" Key -> String -> Object
forall v. ToJSON v => Key -> v -> Object
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= SomeException -> String
forall a. Show a => a -> String
show SomeException
exception
             ]
  forMachine DetailLevel
dtal (TrAcceptPolicyTrace AcceptConnectionsPolicyTrace
policyTrace) =
    [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
"AcceptPolicyTrace"
             , Key
"policy" Key -> Object -> Object
forall v. ToJSON v => Key -> v -> Object
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= DetailLevel -> AcceptConnectionsPolicyTrace -> Object
forall a. LogFormatting a => DetailLevel -> a -> Object
forMachine DetailLevel
dtal AcceptConnectionsPolicyTrace
policyTrace
             ]
  forMachine DetailLevel
dtal (TrServerStarted [addr]
peerAddrs)       =
    [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
"AcceptPolicyTrace"
             , Key
"addresses" Key -> Value -> Object
forall v. ToJSON v => Key -> v -> Object
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [Object] -> Value
forall a. ToJSON a => a -> Value
toJSON (DetailLevel -> addr -> Object
forall a. LogFormatting a => DetailLevel -> a -> Object
forMachine DetailLevel
dtal (addr -> Object) -> [addr] -> [Object]
forall a b. (a -> b) -> [a] -> [b]
`map` [addr]
peerAddrs)
             ]
  forMachine DetailLevel
_dtal Trace addr
TrServerStopped                   =
    [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
"ServerStopped"
             ]
  forMachine DetailLevel
_dtal (TrServerError SomeException
exception)         =
    [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
"ServerError"
             , Key
"reason" Key -> String -> Object
forall v. ToJSON v => Key -> v -> Object
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= SomeException -> String
forall a. Show a => a -> String
show SomeException
exception
             ]
  forHuman :: Trace addr -> Text
forHuman = String -> Text
pack (String -> Text) -> (Trace addr -> String) -> Trace addr -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Trace addr -> String
forall a. Show a => a -> String
show

instance MetaTrace (Server.Trace addr) where
    namespaceFor :: Trace addr -> Namespace (Trace addr)
namespaceFor TrAcceptConnection {}  = [Text] -> [Text] -> Namespace (Trace addr)
forall a. [Text] -> [Text] -> Namespace a
Namespace [] [Text
"AcceptConnection"]
    namespaceFor TrAcceptError {}       = [Text] -> [Text] -> Namespace (Trace addr)
forall a. [Text] -> [Text] -> Namespace a
Namespace [] [Text
"AcceptError"]
    namespaceFor TrAcceptPolicyTrace {} = [Text] -> [Text] -> Namespace (Trace addr)
forall a. [Text] -> [Text] -> Namespace a
Namespace [] [Text
"AcceptPolicy"]
    namespaceFor TrServerStarted {}     = [Text] -> [Text] -> Namespace (Trace addr)
forall a. [Text] -> [Text] -> Namespace a
Namespace [] [Text
"Started"]
    namespaceFor TrServerStopped {}     = [Text] -> [Text] -> Namespace (Trace addr)
forall a. [Text] -> [Text] -> Namespace a
Namespace [] [Text
"Stopped"]
    namespaceFor TrServerError {}       = [Text] -> [Text] -> Namespace (Trace addr)
forall a. [Text] -> [Text] -> Namespace a
Namespace [] [Text
"Error"]

    severityFor :: Namespace (Trace addr) -> Maybe (Trace addr) -> Maybe SeverityS
severityFor (Namespace [Text]
_ [Text
"AcceptConnection"]) Maybe (Trace addr)
_ = SeverityS -> Maybe SeverityS
forall a. a -> Maybe a
Just SeverityS
Debug
    severityFor (Namespace [Text]
_ [Text
"AcceptError"]) Maybe (Trace addr)
_      = SeverityS -> Maybe SeverityS
forall a. a -> Maybe a
Just SeverityS
Error
    severityFor (Namespace [Text]
_ [Text
"AcceptPolicy"]) Maybe (Trace addr)
_     = SeverityS -> Maybe SeverityS
forall a. a -> Maybe a
Just SeverityS
Notice
    severityFor (Namespace [Text]
_ [Text
"Started"]) Maybe (Trace addr)
_          = SeverityS -> Maybe SeverityS
forall a. a -> Maybe a
Just SeverityS
Notice
    severityFor (Namespace [Text]
_ [Text
"Stopped"]) Maybe (Trace addr)
_          = SeverityS -> Maybe SeverityS
forall a. a -> Maybe a
Just SeverityS
Notice
    severityFor (Namespace [Text]
_ [Text
"Error"]) Maybe (Trace addr)
_            = SeverityS -> Maybe SeverityS
forall a. a -> Maybe a
Just SeverityS
Critical
    severityFor Namespace (Trace addr)
_ Maybe (Trace addr)
_                                  = Maybe SeverityS
forall a. Maybe a
Nothing

    documentFor :: Namespace (Trace addr) -> Maybe Text
documentFor (Namespace [Text]
_ [Text
"AcceptConnection"]) = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
""
    documentFor (Namespace [Text]
_ [Text
"AcceptError"])      = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
""
    documentFor (Namespace [Text]
_ [Text
"AcceptPolicy"])     = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
""
    documentFor (Namespace [Text]
_ [Text
"Started"])          = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
""
    documentFor (Namespace [Text]
_ [Text
"Stopped"])          = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
""
    documentFor (Namespace [Text]
_ [Text
"Error"])            = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
""
    documentFor Namespace (Trace addr)
_                                  = Maybe Text
forall a. Maybe a
Nothing

    allNamespaces :: [Namespace (Trace addr)]
allNamespaces = [
        [Text] -> [Text] -> Namespace (Trace addr)
forall a. [Text] -> [Text] -> Namespace a
Namespace [] [Text
"AcceptConnection"]
      , [Text] -> [Text] -> Namespace (Trace addr)
forall a. [Text] -> [Text] -> Namespace a
Namespace [] [Text
"AcceptError"]
      , [Text] -> [Text] -> Namespace (Trace addr)
forall a. [Text] -> [Text] -> Namespace a
Namespace [] [Text
"AcceptPolicy"]
      , [Text] -> [Text] -> Namespace (Trace addr)
forall a. [Text] -> [Text] -> Namespace a
Namespace [] [Text
"Started"]
      , [Text] -> [Text] -> Namespace (Trace addr)
forall a. [Text] -> [Text] -> Namespace a
Namespace [] [Text
"Stopped"]
      , [Text] -> [Text] -> Namespace (Trace addr)
forall a. [Text] -> [Text] -> Namespace a
Namespace [] [Text
"Error"]
      ]