Merge #653

653: CAD-650 trace block forge time r=CodiePP a=CodiePP Issue ----------- - measure and trace block forge time - This PR **does not result** in breaking changes to upstream dependencies. Checklist --------- - [x] This PR contains all the work required to resolve the linked issue. - [ ] The work contained has sufficient documentation to describe what it does and how to do it. - [ ] The work has sufficient tests and/or testing. - [x] I have committed clear and descriptive commits. Be considerate as somebody else will have to read these. - [x] I have added the appropriate labels to this PR. Co-authored-by: Alexander Diemand <[email protected]>
IntersectMBO · Mar 10, 2020 · fe46216 · fe46216
2 parents 9f6b59d + e664030
commit fe46216
Show file tree

Hide file tree

Showing 4 changed files with 91 additions and 91 deletions.
diff --git a/cabal.project b/cabal.project
@@ -138,50 +138,50 @@ source-repository-package
 source-repository-package
   type: git
   location: https://github.com/input-output-hk/iohk-monitoring-framework
-  tag: d6f760591bc6f54e8c333986cf6cf7fb737747df
-  --sha256: 1l4rrll76wss4xsil788r1ffcwb4hqgl74bc29hsjxlygdfv09yc
+  tag: 43a912b94498dcdeaaad71c37a6b58dceefaf1ca
+  --sha256: 0lnfqvrna4x5sqxq71m5717adrp0qfhzjc9g2wr0rflh6d1yb9ag
   subdir: iohk-monitoring
 
 source-repository-package
   type: git
   location: https://github.com/input-output-hk/iohk-monitoring-framework
-  tag: d6f760591bc6f54e8c333986cf6cf7fb737747df
-  --sha256: 1l4rrll76wss4xsil788r1ffcwb4hqgl74bc29hsjxlygdfv09yc
+  tag: 43a912b94498dcdeaaad71c37a6b58dceefaf1ca
+  --sha256: 0lnfqvrna4x5sqxq71m5717adrp0qfhzjc9g2wr0rflh6d1yb9ag
   subdir:   contra-tracer
 
 source-repository-package
   type: git
   location: https://github.com/input-output-hk/iohk-monitoring-framework
-  tag: d6f760591bc6f54e8c333986cf6cf7fb737747df
-  --sha256: 1l4rrll76wss4xsil788r1ffcwb4hqgl74bc29hsjxlygdfv09yc
+  tag: 43a912b94498dcdeaaad71c37a6b58dceefaf1ca
+  --sha256: 0lnfqvrna4x5sqxq71m5717adrp0qfhzjc9g2wr0rflh6d1yb9ag
   subdir:   plugins/scribe-systemd
 
 source-repository-package
   type: git
   location: https://github.com/input-output-hk/iohk-monitoring-framework
-  tag: d6f760591bc6f54e8c333986cf6cf7fb737747df
-  --sha256: 1l4rrll76wss4xsil788r1ffcwb4hqgl74bc29hsjxlygdfv09yc
+  tag: 43a912b94498dcdeaaad71c37a6b58dceefaf1ca
+  --sha256: 0lnfqvrna4x5sqxq71m5717adrp0qfhzjc9g2wr0rflh6d1yb9ag
   subdir:   plugins/backend-aggregation
 
 source-repository-package
   type: git
   location: https://github.com/input-output-hk/iohk-monitoring-framework
-  tag: d6f760591bc6f54e8c333986cf6cf7fb737747df
-  --sha256: 1l4rrll76wss4xsil788r1ffcwb4hqgl74bc29hsjxlygdfv09yc
+  tag: 43a912b94498dcdeaaad71c37a6b58dceefaf1ca
+  --sha256: 0lnfqvrna4x5sqxq71m5717adrp0qfhzjc9g2wr0rflh6d1yb9ag
   subdir:   plugins/backend-ekg
 
 source-repository-package
   type: git
   location: https://github.com/input-output-hk/iohk-monitoring-framework
-  tag: d6f760591bc6f54e8c333986cf6cf7fb737747df
-  --sha256: 1l4rrll76wss4xsil788r1ffcwb4hqgl74bc29hsjxlygdfv09yc
+  tag: 43a912b94498dcdeaaad71c37a6b58dceefaf1ca
+  --sha256: 0lnfqvrna4x5sqxq71m5717adrp0qfhzjc9g2wr0rflh6d1yb9ag
   subdir:   plugins/backend-monitoring
 
 source-repository-package
   type: git
   location: https://github.com/input-output-hk/iohk-monitoring-framework
-  tag: d6f760591bc6f54e8c333986cf6cf7fb737747df
-  --sha256: 1l4rrll76wss4xsil788r1ffcwb4hqgl74bc29hsjxlygdfv09yc
+  tag: 43a912b94498dcdeaaad71c37a6b58dceefaf1ca
+  --sha256: 0lnfqvrna4x5sqxq71m5717adrp0qfhzjc9g2wr0rflh6d1yb9ag
   subdir:   tracer-transformers
 
 source-repository-package

diff --git a/cardano-node/src/Cardano/Tracing/MicroBenchmarking.hs b/cardano-node/src/Cardano/Tracing/MicroBenchmarking.hs
@@ -9,13 +9,12 @@
 {-# LANGUAGE TypeFamilies          #-}
 {-# LANGUAGE UndecidableInstances  #-}
 
+{-# OPTIONS_GHC -fno-warn-orphans  #-}
+
 module Cardano.Tracing.MicroBenchmarking
     ( MeasureTxs (..)
     , measureTxsStart
     , measureTxsEnd
-    , MeasureBlockForging (..)
-    , measureBlockForgeStart
-    , measureBlockForgeEnd
     -- * Re-exports so we localize the changes
     , Outcome (..)
     , OutcomeEnhancedTracer
@@ -24,15 +23,17 @@ module Cardano.Tracing.MicroBenchmarking
 
 import           Cardano.Prelude
 
-import           Control.Monad.Class.MonadTime (DiffTime, Time (..), diffTime,
-                                                getMonotonicTime)
+import           Control.Monad.Class.MonadTime (DiffTime, MonadTime, Time (..),
+                     diffTime, getMonotonicTime)
 
 import           Data.Aeson (Value (..), toJSON, (.=))
 import           Data.Time.Clock (diffTimeToPicoseconds)
 
+import           Cardano.BM.Data.LogItem (LOContent (..), LogObject (..),
+                   mkLOMeta)
 import           Cardano.BM.Data.Severity (Severity (..))
-import           Cardano.BM.Data.Trace
-import           Cardano.BM.Data.Tracer
+import           Cardano.BM.Tracing
+import           Cardano.BM.Data.Tracer (trStructured, emptyObject, mkObject)
 
 import           Control.Tracer.Transformers.ObserveOutcome
 
@@ -171,78 +172,74 @@ instance (Monad m, ApplyTx blk, HasTxId (GenTx blk)) => Outcome m (MeasureTxs bl
 -- Measure block forging time
 --------------------------------------------------------------------------------
 
--- | Definition of the measurement datatype for the block forge time.
-data MeasureBlockForging blk
-    = MeasureBlockTimeStart !SlotNo  !Time
-    | MeasureBlockTimeStop !SlotNo blk !MempoolSize !Time
-
-deriving instance (Eq blk, Eq (GenTx blk)) => Eq (MeasureBlockForging blk)
-deriving instance (Show blk, Show (GenTx blk)) => Show (MeasureBlockForging blk)
-
-instance Transformable Text IO (MeasureBlockForging blk) where
-  trTransformer _ verb tr = trStructured verb tr
-
-instance DefinePrivacyAnnotation (MeasureBlockForging blk)
-instance DefineSeverity (MeasureBlockForging blk) where
-  defineSeverity _ = Info
-
-instance ToObject (MeasureBlockForging blk) where
-  toObject _verb (MeasureBlockTimeStart slotNo (Time time)) =
-    mkObject
-      [ "kind"              .= String "MeasureBlockTimeStart"
-      , "slot"              .= toJSON (unSlotNo slotNo)
-      , "time(ps)"          .= toJSON (diffTimeToPicoseconds time)
-      ]
-  toObject _verb (MeasureBlockTimeStop slotNo _blk mempoolSize (Time time)) =
-    mkObject
-      [ "kind"              .= String "MeasureBlockTimeStop"
-      , "slot"              .= toJSON (unSlotNo slotNo)
-      , "mempoolNumTxs"     .= toJSON (msNumTxs mempoolSize)
-      , "mempoolNumBytes"   .= toJSON (msNumBytes mempoolSize)
-      , "time(ps)"          .= toJSON (diffTimeToPicoseconds time)
-      ]
-
--- | Transformer for the start of the block forge, when the current slot is the slot of the
--- node and the protocol starts.
-measureBlockForgeStart :: Trace IO Text -> Tracer IO (TraceForgeEvent blk (GenTx blk))
-measureBlockForgeStart tracer = measureBlockForgeStartInter $ toLogObject tracer
-  where
-    measureBlockForgeStartInter :: Tracer IO (MeasureBlockForging blk) -> Tracer IO (TraceForgeEvent blk (GenTx blk))
-    measureBlockForgeStartInter tracer' = Tracer $ \case
-        TraceNodeIsLeader slotNo
-            -> traceWith tracer' =<< (MeasureBlockTimeStart slotNo <$> getMonotonicTime)
-        _ -> pure ()
-
--- | Transformer for the end of the block forge, when the block was created/forged.
-measureBlockForgeEnd :: Trace IO Text -> Tracer IO (TraceForgeEvent blk (GenTx blk))
-measureBlockForgeEnd tracer = measureTxsEndInter $ toLogObject tracer
-  where
-    measureTxsEndInter :: Tracer IO (MeasureBlockForging blk) -> Tracer IO (TraceForgeEvent blk (GenTx blk))
-    measureTxsEndInter tracer' = Tracer $ \case
-        TraceForgedBlock slotNo _ blk mempoolSize
-            -> traceWith tracer' =<< (MeasureBlockTimeStop slotNo blk mempoolSize <$> getMonotonicTime)
-        _   -> pure ()
-
-
--- | The outcome for the block forging time. It's a @Maybe@ since
--- the slot number might not be equal from when we start the measurement.
-instance (Monad m) => Outcome m (MeasureBlockForging blk) where
-    type IntermediateValue  (MeasureBlockForging blk)    = (SlotNo, Time, MempoolSize)
-    type OutcomeMetric      (MeasureBlockForging blk)    = Maybe (SlotNo, DiffTime, MempoolSize)
+instance (Monad m, MonadTime m) => Outcome m (TraceForgeEvent blk (GenTx blk)) where
+    type IntermediateValue  (TraceForgeEvent blk (GenTx blk))    = (SlotNo, Time, MempoolSize)
+    type OutcomeMetric      (TraceForgeEvent blk (GenTx blk))    = Maybe (SlotNo, DiffTime, MempoolSize)
 
     --classifyObservable     :: a -> m OutcomeProgressionStatus
     classifyObservable = pure . \case
-      MeasureBlockTimeStart {}    -> OutcomeStarts
-      MeasureBlockTimeStop  {}    -> OutcomeEnds
+      TraceNodeIsLeader {}    -> OutcomeStarts
+      TraceForgedBlock  {}    -> OutcomeEnds
+      _                       -> OutcomeOther
 
     --captureObservableValue :: a -> m (IntermediateValue a)
-    captureObservableValue (MeasureBlockTimeStart slotNo time) =
+    captureObservableValue (TraceNodeIsLeader slotNo) = do
+        time <- getMonotonicTime
         pure (slotNo, time, mempty)
 
-    captureObservableValue (MeasureBlockTimeStop slotNo _blk mempoolSize time) =
+    captureObservableValue (TraceForgedBlock slotNo _ _blk mempoolSize) = do
+        time <- getMonotonicTime
         pure (slotNo, time, mempoolSize)
 
+    -- will never be called, just to make the pattern match complete
+    captureObservableValue _ = do
+        time <- getMonotonicTime
+        pure (0, time, mempty)
+
+
     --computeOutcomeMetric   :: a -> IntermediateValue a -> IntermediateValue a -> m (OutcomeMetric a)
     computeOutcomeMetric _ (startSlot, absTimeStart, _) (stopSlot, absTimeStop, mempoolSize)
         | startSlot == stopSlot = pure $ Just (startSlot, (diffTime absTimeStop absTimeStart), mempoolSize)
         | otherwise             = pure Nothing
+
+instance DefinePrivacyAnnotation (Either
+                             (TraceForgeEvent blk (GenTx blk))
+                             (OutcomeFidelity
+                                (Maybe
+                                   (SlotNo, DiffTime, MempoolSize))))
+instance DefineSeverity (Either
+                             (TraceForgeEvent blk (GenTx blk))
+                             (OutcomeFidelity
+                                (Maybe
+                                   (SlotNo, DiffTime, MempoolSize)))) where
+  defineSeverity _ = Info
+
+instance Transformable Text IO
+                        (Either
+                             (TraceForgeEvent blk (GenTx blk))
+                             (OutcomeFidelity
+                                (Maybe
+                                   (SlotNo, DiffTime, MempoolSize)))) where
+  trTransformer StructuredLogging verb tr = trStructured verb tr
+  trTransformer _ _verb tr = Tracer $ \ev -> do
+    meta <- mkLOMeta (defineSeverity ev) (definePrivacyAnnotation ev)
+    traceWith tr (mempty, LogObject mempty meta (LogMessage "Outcome of TraceForgeEvent"))
+
+instance ToObject
+                        (Either
+                             (TraceForgeEvent blk (GenTx blk))
+                             (OutcomeFidelity
+                                (Maybe
+                                   (SlotNo, DiffTime, MempoolSize)))) where
+  toObject _verb (Left _ev) = emptyObject
+  toObject _verb (Right EndsBeforeStarted) = emptyObject
+  toObject _verb (Right (ProgressedNormally (Just (slotno, difftime, mpsize)))) =
+      mkObject
+        [ "kind"         .= String "OutcomeTraceForgeEvent"
+        , "slot"         .= toJSON (unSlotNo slotno)
+        , "difftime"     .= toJSON (diffTimeToPicoseconds difftime)
+        , "mempoolnumtx" .= toJSON (msNumTxs mpsize)
+        , "mempoolbytes" .= toJSON (msNumBytes mpsize)
+        ]
+  toObject _verb (Right _) = emptyObject
+
diff --git a/cardano-node/src/Cardano/Tracing/Tracers.hs b/cardano-node/src/Cardano/Tracing/Tracers.hs
@@ -186,7 +186,7 @@ mkTracers traceOptions tracer = do
   -- for measuring the time it takes a transaction to get into
   -- a block.
   --txsOutcomeExtractor <- mkOutcomeExtractor @_ @(MeasureTxs blk)
-  --blockForgeOutcomeExtractor <- mkOutcomeExtractor @_ @(MeasureBlockForging blk)
+  blockForgeOutcomeExtractor <- mkOutcomeExtractor
 
   elided <- newstate  -- for eliding messages in ChainDB tracer
 
@@ -198,7 +198,7 @@ mkTracers traceOptions tracer = do
           $ appendName "ChainDB"
           $ tracer
     , consensusTracers
-        = mkConsensusTracers forgeTracers traceOptions
+        = mkConsensusTracers blockForgeOutcomeExtractor forgeTracers traceOptions
     , protocolTracers
         = mkProtocolTracers traceOptions
     , ipSubscriptionTracer
@@ -349,8 +349,6 @@ mkTracers traceOptions tracer = do
         -> Tracer IO (Consensus.TraceForgeEvent blk (GenTx blk))
     forgeTracer forgeTracers traceOpts = Tracer $ \ev -> do
         traceWith (measureTxsEnd tracer) ev
-        traceWith (measureBlockForgeStart tracer) ev
-        traceWith (measureBlockForgeEnd tracer) ev
         traceWith (consensusForgeTracer) ev
       where
         -- The consensus tracer.
@@ -415,8 +413,9 @@ mkTracers traceOptions tracer = do
               LogValue "nodeIsLeader" $ PureI $ fromIntegral $ unSlotNo slot
 
     mkConsensusTracers
-        :: ForgeTracers -> TraceOptions -> Consensus.Tracers' peer blk (Tracer IO)
-    mkConsensusTracers forgeTracers traceOpts = Consensus.Tracers
+        :: (OutcomeEnhancedTracer IO (Consensus.TraceForgeEvent blk (GenTx blk)) -> Tracer IO (Consensus.TraceForgeEvent blk (GenTx blk)))
+        -> ForgeTracers -> TraceOptions -> Consensus.Tracers' peer blk (Tracer IO)
+    mkConsensusTracers measureBlockForging forgeTracers traceOpts = Consensus.Tracers
       { Consensus.chainSyncClientTracer
         = tracerOnOff (traceChainSyncClient traceOpts)
           $ toLogObject' StructuredLogging tracingVerbosity
@@ -457,7 +456,11 @@ mkTracers traceOptions tracer = do
       , Consensus.mempoolTracer
         = tracerOnOff (traceMempool traceOpts) $ mempoolTracer
       , Consensus.forgeTracer
-        = forgeTracer forgeTracers traceOpts
+        = Tracer $ \ev -> do
+            traceWith (forgeTracer forgeTracers traceOpts) ev
+            traceWith ( measureBlockForging
+                      $ toLogObject' StructuredLogging tracingVerbosity
+                      $ appendName "ForgeTime" tracer) ev
       , Consensus.blockchainTimeTracer
         = Tracer $ \ev ->
             traceWith (toLogObject tracer) (readableTraceBlockchainTimeEvent ev)

diff --git a/stack.yaml b/stack.yaml
@@ -99,7 +99,7 @@ extra-deps:
 
     # iohk-monitoring-framework currently not pinned to a release
   - git: https://github.com/input-output-hk/iohk-monitoring-framework
-    commit: d6f760591bc6f54e8c333986cf6cf7fb737747df
+    commit: 43a912b94498dcdeaaad71c37a6b58dceefaf1ca
     subdirs:
       - contra-tracer
       - iohk-monitoring