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

{-# OPTIONS_GHC -Wno-orphans #-}
module Ouroboros.Network.Tracing () where

import Data.Aeson (Value (String), (.=))
import Data.IP qualified as IP
import Data.Text (Text, pack)
import Network.Socket (SockAddr (..))

import Cardano.Logging
import Network.TypedProtocol.Codec (AnyMessage (..))
import Ouroboros.Network.Protocol.Handshake.Type qualified as HS
import Ouroboros.Network.Snocket (LocalAddress (..), RemoteAddress)

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.
--------------------------------------------------------------------------------

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.
--------------------------------------------------------------------------------

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"]
    ]