|
| 1 | +{-# LANGUAGE FlexibleInstances #-} |
| 2 | +{-# LANGUAGE GADTs #-} |
| 3 | +{-# LANGUAGE OverloadedStrings #-} |
| 4 | + |
| 5 | +{-# OPTIONS_GHC -Wno-orphans #-} |
| 6 | + |
| 7 | +module Ouroboros.Network.Logging.Framework () where |
| 8 | + |
| 9 | +import Cardano.Logging |
| 10 | + |
| 11 | +import qualified Ouroboros.Network.Protocol.Handshake.Type as HS |
| 12 | +import Ouroboros.Network.Snocket (LocalAddress (..), RemoteAddress) |
| 13 | +import Network.TypedProtocol.Codec (AnyMessage (..)) |
| 14 | + |
| 15 | +import Data.Aeson (Value (String), (.=)) |
| 16 | +import qualified Data.IP as IP |
| 17 | +import Data.Text (Text, pack) |
| 18 | +import Network.Socket (SockAddr (..)) |
| 19 | + |
| 20 | +import Ouroboros.Network.Logging.Framework.ConnectionId () |
| 21 | +import Ouroboros.Network.Logging.Framework.ConnectionManager () |
| 22 | +import Ouroboros.Network.Logging.Framework.Driver () |
| 23 | +import Ouroboros.Network.Logging.Framework.InboundGovernor () |
| 24 | +import Ouroboros.Network.Logging.Framework.Server () |
| 25 | + |
| 26 | +-------------------------------------------------------------------------------- |
| 27 | +-- Addresses. |
| 28 | +-------------------------------------------------------------------------------- |
| 29 | + |
| 30 | +-- From `Cardano.Node.Tracing.Tracers.P2P` |
| 31 | +-- Branch "ana/10.6-final-integration-mix" |
| 32 | + |
| 33 | +instance LogFormatting LocalAddress where |
| 34 | + forMachine _dtal (LocalAddress path) = |
| 35 | + mconcat ["path" .= path] |
| 36 | + |
| 37 | +instance LogFormatting RemoteAddress where |
| 38 | + forMachine _dtal (SockAddrInet port addr) = |
| 39 | + let ip = IP.fromHostAddress addr in |
| 40 | + mconcat [ "addr" .= show ip |
| 41 | + , "port" .= show port |
| 42 | + ] |
| 43 | + forMachine _dtal (SockAddrInet6 port _ addr _) = |
| 44 | + let ip = IP.fromHostAddress6 addr in |
| 45 | + mconcat [ "addr" .= show ip |
| 46 | + , "port" .= show port |
| 47 | + ] |
| 48 | + forMachine _dtal (SockAddrUnix path) = |
| 49 | + mconcat [ "path" .= show path ] |
| 50 | + |
| 51 | +-------------------------------------------------------------------------------- |
| 52 | +-- Handshake Tracer. |
| 53 | +-------------------------------------------------------------------------------- |
| 54 | + |
| 55 | +-- From `Cardano.Node.Tracing.Tracers.Diffusion` |
| 56 | +-- Branch "ana/10.6-final-integration-mix" |
| 57 | + |
| 58 | +instance (Show term, Show ntcVersion) => |
| 59 | + LogFormatting (AnyMessage (HS.Handshake ntcVersion term)) where |
| 60 | + forMachine _dtal (AnyMessageAndAgency stok msg) = |
| 61 | + mconcat [ "kind" .= String kind |
| 62 | + , "msg" .= (String . showT $ msg) |
| 63 | + , "agency" .= String (pack $ show stok) |
| 64 | + ] |
| 65 | + where |
| 66 | + kind = case msg of |
| 67 | + HS.MsgProposeVersions {} -> "ProposeVersions" |
| 68 | + HS.MsgReplyVersions {} -> "ReplyVersions" |
| 69 | + HS.MsgQueryReply {} -> "QueryReply" |
| 70 | + HS.MsgAcceptVersion {} -> "AcceptVersion" |
| 71 | + HS.MsgRefuse {} -> "Refuse" |
| 72 | + |
| 73 | + forHuman (AnyMessageAndAgency stok msg) = |
| 74 | + "Handshake (agency, message) = " <> "(" <> showT stok <> "," <> showT msg <> ")" |
| 75 | + |
| 76 | +instance MetaTrace (AnyMessage (HS.Handshake a b)) where |
| 77 | + namespaceFor (AnyMessage msg) = Namespace [] $ case msg of |
| 78 | + HS.MsgProposeVersions {} -> ["ProposeVersions"] |
| 79 | + HS.MsgReplyVersions {} -> ["ReplyVersions"] |
| 80 | + HS.MsgQueryReply {} -> ["QueryReply"] |
| 81 | + HS.MsgAcceptVersion {} -> ["AcceptVersion"] |
| 82 | + HS.MsgRefuse {} -> ["Refuse"] |
| 83 | + |
| 84 | + severityFor (Namespace _ [sym]) _ = case sym of |
| 85 | + "ProposeVersions" -> Just Info |
| 86 | + "ReplyVersions" -> Just Info |
| 87 | + "QueryReply" -> Just Info |
| 88 | + "AcceptVersion" -> Just Info |
| 89 | + "Refuse" -> Just Info |
| 90 | + _otherwise -> Nothing |
| 91 | + severityFor _ _ = Nothing |
| 92 | + |
| 93 | + documentFor (Namespace _ sym) = wrap . mconcat $ case sym of |
| 94 | + ["ProposeVersions"] -> |
| 95 | + [ "Propose versions together with version parameters. It must be" |
| 96 | + , " encoded to a sorted list.." |
| 97 | + ] |
| 98 | + ["ReplyVersions"] -> |
| 99 | + [ "`MsgReplyVersions` received as a response to 'MsgProposeVersions'. It" |
| 100 | + , " is not supported to explicitly send this message. It can only be" |
| 101 | + , " received as a copy of 'MsgProposeVersions' in a simultaneous open" |
| 102 | + , " scenario." |
| 103 | + ] |
| 104 | + ["QueryReply"] -> |
| 105 | + [ "`MsgQueryReply` received as a response to a handshake query in " |
| 106 | + , " 'MsgProposeVersions' and lists the supported versions." |
| 107 | + ] |
| 108 | + ["AcceptVersion"] -> |
| 109 | + [ "The remote end decides which version to use and sends chosen version." |
| 110 | + , "The server is allowed to modify version parameters." |
| 111 | + ] |
| 112 | + ["Refuse"] -> ["It refuses to run any version."] |
| 113 | + _otherwise -> [] :: [Text] |
| 114 | + where |
| 115 | + wrap it = case it of |
| 116 | + "" -> Nothing |
| 117 | + it' -> Just it' |
| 118 | + |
| 119 | + allNamespaces = [ |
| 120 | + Namespace [] ["ProposeVersions"] |
| 121 | + , Namespace [] ["ReplyVersions"] |
| 122 | + , Namespace [] ["QueryReply"] |
| 123 | + , Namespace [] ["AcceptVersion"] |
| 124 | + , Namespace [] ["Refuse"] |
| 125 | + ] |
| 126 | + |
0 commit comments