TraceSendRecv and Restructuring.

cardano-node/cardano-node.cabal

@@ -82,6 +82,7 @@ library
                        Cardano.TraceDispatcher.OrphanInstances.HardFork
                        Cardano.TraceDispatcher.OrphanInstances.Common
                        Cardano.TraceDispatcher.OrphanInstances.Shelley
+                       Cardano.TraceDispatcher.Common.Formatting
                        Cardano.TraceDispatcher.ChainDB.Docu
                        Cardano.TraceDispatcher.ChainDB.Formatting
                        Cardano.TraceDispatcher.ChainDB.Combinators

cardano-node/src/Cardano/TraceDispatcher/Common/Formatting.hs

@@ -0,0 +1,27 @@
+{-# OPTIONS_GHC -Wno-orphans  #-}
+
+module Cardano.TraceDispatcher.Common.Formatting
+  (
+  ) where
+
+import           Data.Aeson ((.=))
+import           Text.Show
+
+import           Cardano.Logging
+import           Cardano.Prelude hiding (Show, show)
+
+import           Cardano.TraceDispatcher.Render (showT)
+
+import qualified Ouroboros.Network.BlockFetch.ClientState as BlockFetch
+
+
+instance
+  (  Show peer
+  ,  LogFormatting a)
+  => LogFormatting (BlockFetch.TraceLabelPeer peer a) where
+  forMachine dtal (BlockFetch.TraceLabelPeer peerid a) =
+    mkObject [ "peer" .= showT peerid ] <> forMachine dtal a
+
+  forHuman (BlockFetch.TraceLabelPeer peerid m) = "Peer is " <> showT peerid <> ". " <> forHuman m
+
+  asMetrics (BlockFetch.TraceLabelPeer _peerid m) = asMetrics m

cardano-node/src/Cardano/TraceDispatcher/Consensus/Combinators.hs

@@ -31,10 +31,10 @@ module Cardano.TraceDispatcher.Consensus.Combinators
   , severityForge
   , namesForForge
 
-  , namesBlockchainTime
+  , namesForBlockchainTime
   , severityBlockchainTime
 
-  , namesKeepAliveClient
+  , namesForKeepAliveClient
   , severityKeepAliveClient
 
   ) where
@@ -294,19 +294,19 @@ namesForForge' TraceDidntAdoptBlock {}       = ["DidntAdoptBlock"]
 namesForForge' TraceForgedInvalidBlock {}    = ["ForgedInvalidBlock"]
 namesForForge' TraceAdoptedBlock {}          = ["AdoptedBlock"]
 
-namesBlockchainTime :: TraceBlockchainTimeEvent t -> [Text]
-namesBlockchainTime TraceStartTimeInTheFuture {} = ["StartTimeInTheFuture"]
-namesBlockchainTime TraceCurrentSlotUnknown {}   = ["CurrentSlotUnknown"]
-namesBlockchainTime TraceSystemClockMovedBack {} = ["SystemClockMovedBack"]
+namesForBlockchainTime :: TraceBlockchainTimeEvent t -> [Text]
+namesForBlockchainTime TraceStartTimeInTheFuture {} = ["StartTimeInTheFuture"]
+namesForBlockchainTime TraceCurrentSlotUnknown {}   = ["CurrentSlotUnknown"]
+namesForBlockchainTime TraceSystemClockMovedBack {} = ["SystemClockMovedBack"]
 
 -- TODO: Confirm the severities
 severityBlockchainTime :: TraceBlockchainTimeEvent t -> SeverityS
 severityBlockchainTime TraceStartTimeInTheFuture {} = Warning
 severityBlockchainTime TraceCurrentSlotUnknown {}   = Warning
 severityBlockchainTime TraceSystemClockMovedBack {} = Warning
 
-namesKeepAliveClient :: TraceKeepAliveClient peer -> [Text]
-namesKeepAliveClient _ = ["KeepAliveClient"]
+namesForKeepAliveClient :: TraceKeepAliveClient peer -> [Text]
+namesForKeepAliveClient _ = ["KeepAliveClient"]
 
 severityKeepAliveClient :: TraceKeepAliveClient peer -> SeverityS
 severityKeepAliveClient _ = Info

cardano-node/src/Cardano/TraceDispatcher/Consensus/Formatting.hs

@@ -24,6 +24,7 @@ import           Cardano.TraceDispatcher.OrphanInstances.Byron ()
 import           Cardano.TraceDispatcher.OrphanInstances.Consensus ()
 import           Cardano.TraceDispatcher.OrphanInstances.Network ()
 import           Cardano.TraceDispatcher.OrphanInstances.Shelley ()
+import           Cardano.TraceDispatcher.Common.Formatting ()
 import           Cardano.TraceDispatcher.Render
 
 import           Ouroboros.Consensus.Block
@@ -120,10 +121,6 @@ instance ConvertRawHash blk
                , "point" .= forMachine dtal point
                ]
 
-instance (Show peer, LogFormatting a) => LogFormatting (TraceLabelPeer peer a) where
-  forMachine dtal (TraceLabelPeer peerid a) =
-    mkObject [ "peer" .= show peerid ] <> forMachine dtal a
-
 instance Show peer
       => LogFormatting [TraceLabelPeer peer (FetchDecision [Point header])] where
   forMachine DBrief _ = emptyObject

cardano-node/src/Cardano/TraceDispatcher/Network/Combinators.hs

@@ -1,25 +1,65 @@
+{-# LANGUAGE GADTs     #-}
+{-# LANGUAGE PolyKinds #-}
 
 module Cardano.TraceDispatcher.Network.Combinators
   (
     severityTChainSync
-  , namesTChainSync
+  , namesForTChainSync
 
   ) where
 
 
 import           Cardano.Logging
 import           Cardano.Prelude
 
-import           Ouroboros.Network.Block (Serialised, Tip, Point)
+
+import           Ouroboros.Network.Block (Point, Serialised, Tip)
 import qualified Ouroboros.Network.BlockFetch.ClientState as BlockFetch
+import           Ouroboros.Network.Codec (AnyMessageAndAgency (..))
 import           Ouroboros.Network.Driver.Simple (TraceSendRecv (..))
-import           Ouroboros.Network.Protocol.ChainSync.Type (ChainSync)
+import           Ouroboros.Network.Protocol.ChainSync.Type (ChainSync (..),
+                     Message (..))
+
 
 severityTChainSync :: BlockFetch.TraceLabelPeer peer (TraceSendRecv
     (ChainSync (Serialised blk) (Point blk) (Tip blk))) -> SeverityS
-severityTChainSync _  = undefined
+severityTChainSync (BlockFetch.TraceLabelPeer _ v) = severityTChainSync' v
+  where
+    severityTChainSync' (TraceSendMsg msg) = severityTChainSync'' msg
+    severityTChainSync' (TraceRecvMsg msg) = severityTChainSync'' msg
+
+    severityTChainSync'' (AnyMessageAndAgency _agency msg) = severityTChainSync''' msg
 
+    severityTChainSync''' :: Message
+                                     (ChainSync header point tip) from to
+                                   -> SeverityS
+    severityTChainSync''' MsgRequestNext {}       = Info
+    severityTChainSync''' MsgAwaitReply {}        = Info
+    severityTChainSync''' MsgRollForward {}       = Info
+    severityTChainSync''' MsgRollBackward {}      = Info
+    severityTChainSync''' MsgFindIntersect {}     = Info
+    severityTChainSync''' MsgIntersectFound {}    = Info
+    severityTChainSync''' MsgIntersectNotFound {} = Info
+    severityTChainSync''' MsgDone {}              = Info
 
-namesTChainSync :: BlockFetch.TraceLabelPeer peer (TraceSendRecv
+namesForTChainSync :: BlockFetch.TraceLabelPeer peer (TraceSendRecv
     (ChainSync (Serialised blk) (Point blk) (Tip blk))) -> [Text]
-namesTChainSync _ = undefined
+namesForTChainSync (BlockFetch.TraceLabelPeer _ v) = namesTChainSync v
+  where
+
+    namesTChainSync (TraceSendMsg msg) = "Send" : namesTChainSync' msg
+    namesTChainSync (TraceRecvMsg msg) = "Recieve" : namesTChainSync' msg
+
+    namesTChainSync' (AnyMessageAndAgency _agency msg) = namesTChainSync'' msg
+
+    namesTChainSync'' :: Message
+                                     (ChainSync header point tip) from to
+                                   -> [Text]
+    namesTChainSync'' MsgRequestNext {}       = ["RequestNext"]
+    namesTChainSync'' MsgAwaitReply {}        = ["AwaitReply"]
+    namesTChainSync'' MsgRollForward {}       = ["RollForward"]
+    namesTChainSync'' MsgRollBackward {}      = ["RollBackward"]
+    namesTChainSync'' MsgFindIntersect {}     = ["FindIntersect"]
+    namesTChainSync'' MsgIntersectFound {}    = ["IntersectFound"]
+    namesTChainSync'' MsgIntersectNotFound {} = ["IntersectNotFound"]
+    namesTChainSync'' MsgDone {}              = ["Done"]

cardano-node/src/Cardano/TraceDispatcher/Network/Docu.hs

@@ -20,4 +20,80 @@ import           Ouroboros.Network.Protocol.ChainSync.Type (ChainSync)
 docTChainSync :: Documented (BlockFetch.TraceLabelPeer peer (TraceSendRecv
     (ChainSync (Serialised blk) (Point blk) (Tip blk))))
 docTChainSync = Documented [
+
   ]
+  --
+  -- -- | The messages in the chain sync protocol.
+  -- --
+  -- -- In this protocol the consumer always initiates things and the producer
+  -- -- replies.
+  -- --
+  -- data Message (ChainSync header point tip) from to where
+  --
+  --   -- | Request the next update from the producer. The response can be a roll
+  --   -- forward, a roll back or wait.
+  --   --
+  --   MsgRequestNext :: Message (ChainSync header point tip)
+  --                             StIdle (StNext StCanAwait)
+  --
+  --   -- | Acknowledge the request but require the consumer to wait for the next
+  --   -- update. This means that the consumer is synced with the producer, and
+  --   -- the producer is waiting for its own chain state to change.
+  --   --
+  --   MsgAwaitReply :: Message (ChainSync header point tip)
+  --                            (StNext StCanAwait) (StNext StMustReply)
+  --
+  --   -- | Tell the consumer to extend their chain with the given header.
+  --   --
+  --   -- The message also tells the consumer about the head point of the producer.
+  --   --
+  --   MsgRollForward :: header -> tip
+  --                  -> Message (ChainSync header point tip)
+  --                             (StNext any) StIdle
+  --
+  --   -- | Tell the consumer to roll back to a given point on their chain.
+  --   --
+  --   -- The message also tells the consumer about the head point of the producer.
+  --   --
+  --   MsgRollBackward :: point -> tip
+  --                   -> Message (ChainSync header point tip)
+  --                              (StNext any) StIdle
+  --
+  --   -- | Ask the producer to try to find an improved intersection point between
+  --   -- the consumer and producer's chains. The consumer sends a sequence of
+  --   -- points and it is up to the producer to find the first intersection point
+  --   -- on its chain and send it back to the consumer.
+  --   --
+  --   MsgFindIntersect :: [point]
+  --                    -> Message (ChainSync header point tip)
+  --                               StIdle StIntersect
+  --
+  --   -- | The reply to the consumer about an intersection found.
+  --   -- The consumer can decide weather to send more points.
+  --   --
+  --   -- The message also tells the consumer about the head point of the producer.
+  --   --
+  --   MsgIntersectFound  :: point -> tip
+  --                      -> Message (ChainSync header point tip)
+  --                                 StIntersect StIdle
+  --
+  --   -- | The reply to the consumer that no intersection was found: none of the
+  --   -- points the consumer supplied are on the producer chain.
+  --   --
+  --   -- The message also tells the consumer about the head point of the producer.
+  --   --
+  --   MsgIntersectNotFound :: tip
+  --                        -> Message (ChainSync header point tip)
+  --                                   StIntersect StIdle
+  --
+  --   -- | Terminating messages
+  --   --
+  --   MsgDone :: Message (ChainSync header point tip)
+  --                      StIdle StDone
+  --
+  -- -- | We have to explain to the framework what our states mean, in terms of
+  -- -- which party has agency in each state.
+  -- --
+  -- -- Idle states are where it is for the client to send a message,
+  -- -- busy states are where the server is expected to send a reply.
+  -- --

cardano-node/src/Cardano/TraceDispatcher/Network/Formatting.hs

@@ -12,18 +12,63 @@ module Cardano.TraceDispatcher.Network.Formatting
   (
   ) where
 
-import           Data.Aeson (ToJSON, Value (String), toJSON, (.=))
-import qualified Data.Text as Text
+import           Data.Aeson (Value (String), (.=))
+import           Data.Text (pack)
 import           Text.Show
 
+import           Cardano.TraceDispatcher.Common.Formatting ()
+
 import           Cardano.Logging
 import           Cardano.Prelude hiding (Show, show)
 
-import           Ouroboros.Network.Block (Serialised, Tip, Point)
-import qualified Ouroboros.Network.BlockFetch.ClientState as BlockFetch
 import           Ouroboros.Network.Driver.Simple (TraceSendRecv (..))
-import           Ouroboros.Network.Protocol.ChainSync.Type (ChainSync)
+import           Ouroboros.Network.Codec (AnyMessageAndAgency (..))
+import           Ouroboros.Network.Protocol.ChainSync.Type as ChainSync
+
+
+instance LogFormatting (AnyMessageAndAgency ps)
+      => LogFormatting (TraceSendRecv ps) where
+  forMachine dtal (TraceSendMsg m) = mkObject
+    [ "kind" .= String "Send" , "msg" .= forMachine dtal m ]
+  forMachine dtal (TraceRecvMsg m) = mkObject
+    [ "kind" .= String "Recv" , "msg" .= forMachine dtal m ]
+
+  forHuman (TraceSendMsg m) = "Send: " <> forHuman m
+  forHuman (TraceRecvMsg m) = "Receive: " <> forHuman m
+
+  asMetrics (TraceSendMsg m) = asMetrics m
+  asMetrics (TraceRecvMsg m) = asMetrics m
 
-instance LogFormatting (TraceSendRecv
-  (ChainSync (Serialised blk) (Point blk) (Tip blk))) where
-    forMachine _ _ = mempty
+instance LogFormatting (AnyMessageAndAgency (ChainSync blk pt tip)) where
+   forMachine _dtal (AnyMessageAndAgency stok ChainSync.MsgRequestNext{}) =
+     mkObject [ "kind" .= String "MsgRequestNext"
+              , "agency" .= String (pack $ show stok)
+              ]
+   forMachine _dtal (AnyMessageAndAgency stok ChainSync.MsgAwaitReply{}) =
+     mkObject [ "kind" .= String "MsgAwaitReply"
+              , "agency" .= String (pack $ show stok)
+              ]
+   forMachine _dtal (AnyMessageAndAgency stok ChainSync.MsgRollForward{}) =
+     mkObject [ "kind" .= String "MsgRollForward"
+              , "agency" .= String (pack $ show stok)
+              ]
+   forMachine _dtal (AnyMessageAndAgency stok ChainSync.MsgRollBackward{}) =
+     mkObject [ "kind" .= String "MsgRollBackward"
+              , "agency" .= String (pack $ show stok)
+              ]
+   forMachine _dtal (AnyMessageAndAgency stok ChainSync.MsgFindIntersect{}) =
+     mkObject [ "kind" .= String "MsgFindIntersect"
+              , "agency" .= String (pack $ show stok)
+              ]
+   forMachine _dtal (AnyMessageAndAgency stok ChainSync.MsgIntersectFound{}) =
+     mkObject [ "kind" .= String "MsgIntersectFound"
+              , "agency" .= String (pack $ show stok)
+              ]
+   forMachine _dtal (AnyMessageAndAgency stok ChainSync.MsgIntersectNotFound{}) =
+     mkObject [ "kind" .= String "MsgIntersectNotFound"
+              , "agency" .= String (pack $ show stok)
+              ]
+   forMachine _dtal (AnyMessageAndAgency stok ChainSync.MsgDone{}) =
+     mkObject [ "kind" .= String "MsgDone"
+              , "agency" .= String (pack $ show stok)
+              ]