cardano- node: Adopting changes for trace-dispatcher bindings

IntersectMBO · Oct 21, 2021 · a2fde8c · a2fde8c
1 parent 0840b79
commit a2fde8c
Show file tree

Hide file tree

Showing 11 changed files with 377 additions and 112 deletions.
diff --git a/cardano-node/src/Cardano/TraceDispatcher/ChainDB/Combinators.hs b/cardano-node/src/Cardano/TraceDispatcher/ChainDB/Combinators.hs
@@ -170,7 +170,7 @@ namesForChainDBTraceEvents (ChainDB.TraceCopyToImmutableDBEvent
   (ChainDB.CopiedBlockToImmutableDB {})) =
       ["CopyToImmutableDBEvent", "CopiedBlockToImmutableDB"]
 namesForChainDBTraceEvents (ChainDB.TraceCopyToImmutableDBEvent
-  (ChainDB.NoBlocksToCopyToImmutableDB)) =
+  ChainDB.NoBlocksToCopyToImmutableDB) =
       ["CopyToImmutableDBEvent", "NoBlocksToCopyToImmutableDB"]
 namesForChainDBTraceEvents (ChainDB.TraceGCEvent
   (ChainDB.ScheduledGC {})) =

diff --git a/cardano-node/src/Cardano/TraceDispatcher/ChainDB/Docu.hs b/cardano-node/src/Cardano/TraceDispatcher/ChainDB/Docu.hs
@@ -276,7 +276,7 @@ docChainDBTraceEvent = Documented [
       "A block was successfully copied to the ImmDB."
   , DocMsg
       (ChainDB.TraceCopyToImmutableDBEvent
-        (ChainDB.NoBlocksToCopyToImmutableDB))
+        ChainDB.NoBlocksToCopyToImmutableDB)
       []
       "There are no block to copy to the ImmDB."
   , DocMsg
@@ -550,12 +550,12 @@ docChainDBTraceEvent = Documented [
 
   , DocMsg
       (ChainDB.TraceVolatileDBEvent
-        (VolDB.DBAlreadyClosed))
+        VolDB.DBAlreadyClosed)
       []
       "When closing the DB it was found itis closed already."
   , DocMsg
       (ChainDB.TraceVolatileDBEvent
-        (VolDB.DBAlreadyOpen))
+        VolDB.DBAlreadyOpen)
       []
       "TODO Doc"
   , DocMsg

diff --git a/cardano-node/src/Cardano/TraceDispatcher/Consensus/Combinators.hs b/cardano-node/src/Cardano/TraceDispatcher/Consensus/Combinators.hs
@@ -147,7 +147,7 @@ severityBlockFetchClient ::
 severityBlockFetchClient (BlockFetch.TraceLabelPeer _p bf) = severityBlockFetchClient' bf
 
 severityBlockFetchClient' ::
-     (BlockFetch.TraceFetchClientState header)
+     BlockFetch.TraceFetchClientState header
   -> SeverityS
 severityBlockFetchClient' BlockFetch.AddedFetchRequest {}        = Info
 severityBlockFetchClient' BlockFetch.AcknowledgedFetchRequest {} = Info
@@ -184,12 +184,12 @@ namesForBlockFetchClient' BlockFetch.ClientTerminating {} =
       ["ClientTerminating"]
 
 severityBlockFetchServer ::
-     (TraceBlockFetchServerEvent blk)
+     TraceBlockFetchServerEvent blk
   -> SeverityS
 severityBlockFetchServer _ = Info
 
 namesForBlockFetchServer ::
-     (TraceBlockFetchServerEvent blk)
+     TraceBlockFetchServerEvent blk
   -> [Text]
 namesForBlockFetchServer TraceBlockFetchServerSendBlock {} = ["SendBlock"]
 
@@ -248,17 +248,17 @@ namesForTxOutbound' TraceControlMessage {} =
     ["ControlMessage"]
 
 severityLocalTxSubmissionServer ::
-     (TraceLocalTxSubmissionServerEvent blk)
+     TraceLocalTxSubmissionServerEvent blk
   -> SeverityS
 severityLocalTxSubmissionServer _ = Info
 
 namesForLocalTxSubmissionServer ::
-  (TraceLocalTxSubmissionServerEvent blk)
+  TraceLocalTxSubmissionServerEvent blk
   -> [Text]
 namesForLocalTxSubmissionServer TraceReceivedTx {} = ["ReceivedTx"]
 
 severityMempool ::
-     (TraceEventMempool blk)
+     TraceEventMempool blk
   -> SeverityS
 severityMempool _ = Info
 

diff --git a/cardano-node/src/Cardano/TraceDispatcher/Consensus/ForgingThreadStats.hs b/cardano-node/src/Cardano/TraceDispatcher/Consensus/ForgingThreadStats.hs
@@ -1,7 +1,6 @@
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE NamedFieldPuns    #-}
 {-# LANGUAGE RecordWildCards   #-}
-{-# LANGUAGE TupleSections     #-}
 
 module Cardano.TraceDispatcher.Consensus.ForgingThreadStats
   ( ForgingStats (..)

diff --git a/cardano-node/src/Cardano/TraceDispatcher/Consensus/Formatting.hs b/cardano-node/src/Cardano/TraceDispatcher/Consensus/Formatting.hs
@@ -67,7 +67,7 @@ import           Ouroboros.Consensus.Node.Run (SerialiseNodeToNodeConstraints,
                      estimateBlockSize)
 import           Ouroboros.Consensus.Node.Tracers
 
-import           Ouroboros.Network.Block
+import           Ouroboros.Network.Block hiding (blockPrevHash)
 import           Ouroboros.Network.BlockFetch.ClientState (TraceLabelPeer (..))
 import qualified Ouroboros.Network.BlockFetch.ClientState as BlockFetch
 import           Ouroboros.Network.BlockFetch.Decision
@@ -141,6 +141,19 @@ instance (LogFormatting (LedgerUpdate blk), LogFormatting (LedgerWarning blk))
     LedgerUpdate  update  -> forMachine dtal update
     LedgerWarning warning -> forMachine dtal warning
 
+tipToObject :: forall blk. ConvertRawHash blk => Tip blk -> [(Text, Value)]
+tipToObject = \case
+  TipGenesis ->
+    [ "slot"    .= toJSON (0 :: Int)
+    , "block"   .= String "genesis"
+    , "blockNo" .= toJSON ((-1) :: Int)
+    ]
+  Tip slot hash blockno ->
+    [ "slot"    .= slot
+    , "block"   .= String (renderHeaderHash (Proxy @blk) hash)
+    , "blockNo" .= blockno
+    ]
+
 instance (Show (Header blk), ConvertRawHash blk, LedgerSupportsProtocol blk)
       => LogFormatting (TraceChainSyncClientEvent blk) where
   forHuman (TraceDownloadedHeader pt) =
@@ -158,9 +171,10 @@ instance (Show (Header blk), ConvertRawHash blk, LedgerSupportsProtocol blk)
   forHuman (TraceTermination res) =
       "The client has terminated. " <> showT res
 
-  forMachine dtal (TraceDownloadedHeader pt) =
-      mkObject [ "kind" .= String "DownloadedHeader"
-               , "block" .= forMachine dtal (headerPoint pt) ]
+  forMachine _dtal (TraceDownloadedHeader h) =
+      mkObject $
+               [ "kind" .= String "DownloadedHeader"
+               ] <> tipToObject (tipFromHeader h)
   forMachine dtal (TraceRolledBack tip) =
       mkObject [ "kind" .= String "RolledBack"
                , "tip" .= forMachine dtal tip ]
@@ -175,40 +189,35 @@ instance (Show (Header blk), ConvertRawHash blk, LedgerSupportsProtocol blk)
 
 instance ConvertRawHash blk
       => LogFormatting (TraceChainSyncServerEvent blk) where
-  forMachine dtal (TraceChainSyncServerRead tip (AddBlock hdr)) =
-      mkObject [ "kind" .= String "ChainSyncServerRead.AddBlock"
-               , "tip" .= String (renderTipForDetails dtal tip)
-               , "addedBlock" .= String (renderPointForDetails dtal hdr)
-               ]
-  forMachine dtal (TraceChainSyncServerRead tip (RollBack pt)) =
-      mkObject [ "kind" .= String "ChainSyncServerRead.RollBack"
-               , "tip" .= String (renderTipForDetails dtal tip)
-               , "rolledBackBlock" .= String (renderPointForDetails dtal pt)
-               ]
-  forMachine dtal (TraceChainSyncServerReadBlocked tip (AddBlock hdr)) =
-      mkObject [ "kind" .= String "ChainSyncServerReadBlocked.RollForward"
-               , "tip" .= String (renderTipForDetails dtal tip)
-               , "addedBlock" .= String (renderPointForDetails dtal hdr)
-               ]
-  forMachine dtal (TraceChainSyncServerReadBlocked tip (RollBack pt)) =
-      mkObject [ "kind" .= String "ChainSyncServerReadBlocked.RollBack"
-               , "tip" .= String (renderTipForDetails dtal tip)
-               , "rolledBackBlock" .= String (renderPointForDetails dtal pt)
-               ]
+  forMachine _dtal (TraceChainSyncServerRead tip (AddBlock _hdr)) =
+      mkObject $
+               [ "kind" .= String "ChainSyncServerRead.AddBlock"
+               ] <> tipToObject tip
+  forMachine _dtal (TraceChainSyncServerRead tip (RollBack _pt)) =
+      mkObject $
+               [ "kind" .= String "ChainSyncServerRead.RollBack"
+               ] <> tipToObject tip
+  forMachine _dtal (TraceChainSyncServerReadBlocked tip (AddBlock _hdr)) =
+      mkObject $
+               [ "kind" .= String "ChainSyncServerReadBlocked.AddBlock"
+               ] <> tipToObject tip
+  forMachine _dtal (TraceChainSyncServerReadBlocked tip (RollBack _pt)) =
+      mkObject $
+               [ "kind" .= String "ChainSyncServerReadBlocked.RollBack"
+               ] <> tipToObject tip
   forMachine dtal (TraceChainSyncRollForward point) =
-      mkObject [ "kind" .= String "ChainSyncRollForward"
+      mkObject [ "kind" .= String "ChainSyncServerRead.RollForward"
                , "point" .= forMachine dtal point
                ]
   forMachine dtal (TraceChainSyncRollBackward point) =
-      mkObject [ "kind" .= String "ChainSyncRollBackward"
+      mkObject [ "kind" .= String "ChainSyncServerRead.ChainSyncRollBackward"
                , "point" .= forMachine dtal point
                ]
 
   asMetrics (TraceChainSyncRollForward _point) =
       [CounterM "ChainSync.RollForward" Nothing]
   asMetrics _ = []
 
-
 instance (LogFormatting peer, Show peer)
       => LogFormatting [TraceLabelPeer peer (FetchDecision [Point header])] where
   forMachine DMinimal _ = emptyObject
@@ -257,9 +266,13 @@ instance LogFormatting (BlockFetch.TraceFetchClientState header) where
   forMachine _dtal BlockFetch.ClientTerminating {} =
     mkObject [ "kind" .= String "ClientTerminating" ]
 
-instance LogFormatting (TraceBlockFetchServerEvent blk) where
-  forMachine _dtal (TraceBlockFetchServerSendBlock _p) =
-    mkObject [ "kind" .= String "BlockFetchServer" ]
+instance ConvertRawHash blk => LogFormatting (TraceBlockFetchServerEvent blk) where
+  forMachine _dtal (TraceBlockFetchServerSendBlock blk) =
+    mkObject [ "kind" .= String "BlockFetchServer"
+             , "block" .= String (renderChainHash
+                                    @blk
+                                    (renderHeaderHash (Proxy @blk))
+                                    $ pointHash blk)]
 
   asMetrics (TraceBlockFetchServerSendBlock _p) =
     [CounterM "served.block.count" Nothing]
@@ -493,10 +506,16 @@ instance ( tx ~ GenTx blk
       [ "kind" .= String "TraceNodeIsLeader"
       , "slot" .= toJSON (unSlotNo slotNo)
       ]
-  forMachine _dtal (TraceForgedBlock slotNo _ _ _) =
+  forMachine _dtal (TraceForgedBlock slotNo _ blk _) =
     mkObject
       [ "kind" .= String "TraceForgedBlock"
       , "slot" .= toJSON (unSlotNo slotNo)
+      , "block"     .= String (renderHeaderHash (Proxy @blk) $ blockHash blk)
+      , "blockNo"   .= toJSON (unBlockNo $ blockNo blk)
+      , "blockPrev" .= String (renderChainHash
+                                @blk
+                                (renderHeaderHash (Proxy @blk))
+                                $ blockPrevHash blk)
       ]
   forMachine _dtal (TraceDidntAdoptBlock slotNo _) =
     mkObject

diff --git a/cardano-node/src/Cardano/TraceDispatcher/Consensus/StartLeadershipCheck.hs b/cardano-node/src/Cardano/TraceDispatcher/Consensus/StartLeadershipCheck.hs
@@ -4,7 +4,6 @@
 {-# LANGUAGE LambdaCase        #-}
 {-# LANGUAGE NamedFieldPuns    #-}
 {-# LANGUAGE PackageImports    #-}
-{-# LANGUAGE RecordWildCards   #-}
 
 module Cardano.TraceDispatcher.Consensus.StartLeadershipCheck
   (

diff --git a/cardano-node/src/Cardano/TraceDispatcher/Consensus/StateInfo.hs b/cardano-node/src/Cardano/TraceDispatcher/Consensus/StateInfo.hs
@@ -1,9 +1,7 @@
 {-# LANGUAGE FlexibleContexts     #-}
 {-# LANGUAGE FlexibleInstances    #-}
 {-# LANGUAGE ScopedTypeVariables  #-}
-{-# LANGUAGE TypeApplications     #-}
 {-# LANGUAGE TypeFamilies         #-}
-{-# LANGUAGE TypeSynonymInstances #-}
 {-# LANGUAGE UndecidableInstances #-}
 
 {-# OPTIONS_GHC -Wno-orphans  #-}
@@ -32,18 +30,18 @@ import qualified Ouroboros.Consensus.Shelley.Protocol.HotKey as HotKey
 traceAsKESInfo
   :: forall m blk . (GetKESInfoX blk, MonadIO m)
   => Proxy blk
-  -> Trace m (TraceLabelCreds (HotKey.KESInfo))
+  -> Trace m (TraceLabelCreds HotKey.KESInfo)
   -> Trace m (TraceLabelCreds (ForgeStateInfo blk))
 traceAsKESInfo pr tr = traceAsMaybeKESInfo pr (filterTraceMaybe tr)
 
 traceAsMaybeKESInfo
   :: forall m blk . (GetKESInfoX blk, MonadIO m)
   => Proxy blk
-  -> Trace m (Maybe (TraceLabelCreds (HotKey.KESInfo)))
+  -> Trace m (Maybe (TraceLabelCreds HotKey.KESInfo))
   -> Trace m (TraceLabelCreds (ForgeStateInfo blk))
 traceAsMaybeKESInfo pr (Trace tr) = Trace $
   contramap
-        (\(lc, mbC, (TraceLabelCreds c e)) ->
+        (\(lc, mbC, TraceLabelCreds c e) ->
             case getKESInfoFromStateInfoX pr e of
               Just kesi -> (lc, mbC, Just (TraceLabelCreds c kesi))
               Nothing   -> (lc, mbC, Nothing))

diff --git a/cardano-node/src/Cardano/TraceDispatcher/Era/HardFork.hs b/cardano-node/src/Cardano/TraceDispatcher/Era/HardFork.hs
@@ -1,13 +1,10 @@
-{-# LANGUAGE DeriveAnyClass             #-}
 {-# LANGUAGE DerivingStrategies         #-}
 {-# LANGUAGE FlexibleContexts           #-}
 {-# LANGUAGE FlexibleInstances          #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE MultiParamTypeClasses      #-}
 {-# LANGUAGE NamedFieldPuns             #-}
 {-# LANGUAGE OverloadedStrings          #-}
 {-# LANGUAGE ScopedTypeVariables        #-}
-{-# LANGUAGE StandaloneDeriving         #-}
 {-# LANGUAGE TypeApplications           #-}
 {-# LANGUAGE TypeFamilies               #-}
 {-# LANGUAGE TypeOperators              #-}
@@ -56,11 +53,10 @@ import           Ouroboros.Consensus.Util.Condense (Condense (..))
 
 
 --
--- instances for hashes
+-- instances for hashes -- TODO ROL : put here 
 --
-
 -- instance Condense (OneEraHash xs) where
---     condense = condense . Crypto.UnsafeHash . getOneEraHash
+--     condense = condense . Base16.encode . SBS.fromShort . getOneEraHash
 
 --
 -- instances for Header HardForkBlock