start-leadership: trace drep count and map size

Update TraceStartLeadershipCheckPlus with fields to track the DRep
count and DRep map size. Update LedgerQueries with methods to extract
the information to fill TraceStartLeadershipCheckPlus with. Update
forgeTracerTransform to go about filling in all of the fields of
TraceStartLeadershipCheckPlus with all the results from the accessors.
DRep counts and map sizes get logged in the regularly-scheduled
periodic traces in the final result.

cardano-node/src/Cardano/Node/Queries.hs

@@ -231,10 +231,14 @@ instance All GetKESInfo xs => GetKESInfo (HardForkBlock xs) where
 class LedgerQueries blk where
   ledgerUtxoSize     :: LedgerState blk -> Int
   ledgerDelegMapSize :: LedgerState blk -> Int
+  ledgerDRepCount    :: LedgerState blk -> Int
+  ledgerDRepMapSize  :: LedgerState blk -> Int
 
 instance LedgerQueries Byron.ByronBlock where
   ledgerUtxoSize = Map.size . Byron.unUTxO . Byron.cvsUtxo . Byron.byronLedgerState
   ledgerDelegMapSize _ = 0
+  ledgerDRepCount    _ = 0
+  ledgerDRepMapSize  _ = 0
 
 instance LedgerQueries (Shelley.ShelleyBlock protocol era) where
   ledgerUtxoSize =
@@ -253,11 +257,30 @@ instance LedgerQueries (Shelley.ShelleyBlock protocol era) where
     . Shelley.esLState
     . Shelley.nesEs
     . Shelley.shelleyLedgerState
+  ledgerDRepCount =
+      Map.size
+    . Shelley.vsDReps
+    . Shelley.certVState
+    . Shelley.lsCertState
+    . Shelley.esLState
+    . Shelley.nesEs
+    . Shelley.shelleyLedgerState
+  ledgerDRepMapSize =
+      UM.size
+    . UM.DRepUView
+    . Shelley.dsUnified
+    . Shelley.certDState
+    . Shelley.lsCertState
+    . Shelley.esLState
+    . Shelley.nesEs
+    . Shelley.shelleyLedgerState
 
 instance (LedgerQueries x, NoHardForks x)
       => LedgerQueries (HardForkBlock '[x]) where
-  ledgerUtxoSize = ledgerUtxoSize . project
+  ledgerUtxoSize     = ledgerUtxoSize     . project
   ledgerDelegMapSize = ledgerDelegMapSize . project
+  ledgerDRepCount    = ledgerDRepCount    . project
+  ledgerDRepMapSize  = ledgerDRepMapSize  . project
 
 instance LedgerQueries (Cardano.CardanoBlock c) where
   ledgerUtxoSize = \case
@@ -276,6 +299,22 @@ instance LedgerQueries (Cardano.CardanoBlock c) where
     Cardano.LedgerStateAlonzo  ledgerAlonzo  -> ledgerDelegMapSize ledgerAlonzo
     Cardano.LedgerStateBabbage ledgerBabbage -> ledgerDelegMapSize ledgerBabbage
     Cardano.LedgerStateConway  ledgerConway  -> ledgerDelegMapSize ledgerConway
+  ledgerDRepCount = \case
+    Cardano.LedgerStateByron   ledgerByron   -> ledgerDRepCount ledgerByron
+    Cardano.LedgerStateShelley ledgerShelley -> ledgerDRepCount ledgerShelley
+    Cardano.LedgerStateAllegra ledgerAllegra -> ledgerDRepCount ledgerAllegra
+    Cardano.LedgerStateMary    ledgerMary    -> ledgerDRepCount ledgerMary
+    Cardano.LedgerStateAlonzo  ledgerAlonzo  -> ledgerDRepCount ledgerAlonzo
+    Cardano.LedgerStateBabbage ledgerBabbage -> ledgerDRepCount ledgerBabbage
+    Cardano.LedgerStateConway  ledgerConway  -> ledgerDRepCount ledgerConway
+  ledgerDRepMapSize = \case
+    Cardano.LedgerStateByron   ledgerByron   -> ledgerDRepMapSize ledgerByron
+    Cardano.LedgerStateShelley ledgerShelley -> ledgerDRepMapSize ledgerShelley
+    Cardano.LedgerStateAllegra ledgerAllegra -> ledgerDRepMapSize ledgerAllegra
+    Cardano.LedgerStateMary    ledgerMary    -> ledgerDRepMapSize ledgerMary
+    Cardano.LedgerStateAlonzo  ledgerAlonzo  -> ledgerDRepMapSize ledgerAlonzo
+    Cardano.LedgerStateBabbage ledgerBabbage -> ledgerDRepMapSize ledgerBabbage
+    Cardano.LedgerStateConway  ledgerConway  -> ledgerDRepMapSize ledgerConway
 
 --
 -- * Node kernel

cardano-node/src/Cardano/Node/Tracing/Tracers/Consensus.hs

@@ -1151,15 +1151,21 @@ instance LogFormatting TraceStartLeadershipCheckPlus where
                 , "utxoSize" .= Number (fromIntegral tsUtxoSize)
                 , "delegMapSize" .= Number (fromIntegral tsDelegMapSize)
                 , "chainDensity" .= Number (fromRational (toRational tsChainDensity))
+                , "dRepCount"    .= Number (fromIntegral tsDRepCount)
+                , "dRepMapSize"  .= Number (fromIntegral tsDRepMapSize)
                 ]
   forHuman TraceStartLeadershipCheckPlus {..} =
       "Checking for leadership in slot " <> showT (unSlotNo tsSlotNo)
-      <> " utxoSize " <> showT tsUtxoSize
+      <> " utxoSize "     <> showT tsUtxoSize
       <> " delegMapSize " <> showT tsDelegMapSize
       <> " chainDensity " <> showT tsChainDensity
+      <> " dRepCount "    <> showT tsDRepCount
+      <> " dRepMapSize "  <> showT tsDRepMapSize
   asMetrics TraceStartLeadershipCheckPlus {..} =
-    [IntM "Forge.UtxoSize" (fromIntegral tsUtxoSize),
-     IntM "Forge.DelegMapSize" (fromIntegral tsDelegMapSize)]
+    [IntM "Forge.UtxoSize"     (fromIntegral tsUtxoSize),
+     IntM "Forge.DelegMapSize" (fromIntegral tsDelegMapSize),
+     IntM "Forge.DRepCount"    (fromIntegral tsDRepCount),
+     IntM "Forge.DRepMapSize"  (fromIntegral tsDRepMapSize)]
 
 --------------------------------------------------------------------------------
 -- ForgeEvent Tracer

cardano-node/src/Cardano/Node/Tracing/Tracers/StartLeadershipCheck.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE BlockArguments #-}
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE FlexibleContexts #-}
@@ -20,13 +21,11 @@ import           Data.Word (Word64)
 
 import qualified Ouroboros.Network.AnchoredFragment as AF
 import           Ouroboros.Network.Block (BlockNo (..), blockNo, unBlockNo)
-import           Ouroboros.Network.NodeToClient (LocalConnectionId)
-import           Ouroboros.Network.NodeToNode (RemoteAddress)
 
 import           Ouroboros.Consensus.Block (SlotNo (..))
 import           Ouroboros.Consensus.HardFork.Combinator
 import           Ouroboros.Consensus.Ledger.Abstract (IsLedger)
-import           Ouroboros.Consensus.Ledger.Extended (ExtLedgerState, ledgerState)
+import           Ouroboros.Consensus.Ledger.Extended (ledgerState)
 import           Ouroboros.Consensus.Node (NodeKernel (..))
 import           Ouroboros.Consensus.Node.Tracers
 import qualified Ouroboros.Consensus.Storage.ChainDB as ChainDB
@@ -45,6 +44,8 @@ data TraceStartLeadershipCheckPlus =
         tsSlotNo       :: SlotNo
       , tsUtxoSize     :: Int
       , tsDelegMapSize :: Int
+      , tsDRepCount    :: Int
+      , tsDRepMapSize  :: Int
       , tsChainDensity :: Double
     }
 
@@ -58,47 +59,41 @@ forgeTracerTransform ::
   => NodeKernelData blk
   -> Trace IO (ForgeTracerType blk)
   -> IO (Trace IO (ForgeTracerType blk))
-forgeTracerTransform nodeKern (Trace tr) =
-    contramapM (Trace tr)
-      (\case
-          (lc, Right (Left slc@(TraceStartLeadershipCheck slotNo))) -> do
-            query <- mapNodeKernelDataIO
-                        (\nk ->
-                          (,,)
-                            <$> nkQueryLedger (ledgerUtxoSize . ledgerState) nk
-                            <*> nkQueryLedger (ledgerDelegMapSize . ledgerState) nk
-                            <*> nkQueryChain fragmentChainDensity nk)
-                        nodeKern
-            case query of
-              SNothing -> pure (lc, Right (Left slc))
-              SJust (utxoSize, delegMapSize, chainDensity) ->
-                    let msg = TraceStartLeadershipCheckPlus
-                                slotNo
-                                utxoSize
-                                delegMapSize
-                                (fromRational chainDensity)
-                    in pure (lc, Right (Right msg))
-          (lc, Right a) ->
-              pure (lc, Right a)
-          (lc, Left control) ->
-              pure (lc, Left control))
-
-nkQueryLedger ::
-     IsLedger (LedgerState blk)
-  => (ExtLedgerState blk -> a)
-  -> NodeKernel IO RemoteAddress LocalConnectionId blk
-  -> IO a
-nkQueryLedger f NodeKernel{getChainDB} =
-  f <$> atomically (ChainDB.getCurrentLedger getChainDB)
+forgeTracerTransform (NodeKernelData ref) (Trace tr) =
+  let secondM f (x, y) = do -- avoiding new dep on extra pkg
+        y' <- f y
+        pure (x, y')
+  in contramapM (Trace tr) $ secondM
+      \case
+          Right (Left slc@(TraceStartLeadershipCheck tsSlotNo)) -> do
+            query <- readIORef ref >>= traverse
+                        \NodeKernel{getChainDB} -> do
+                               ledger <- fmap ledgerState . atomically $
+                                           ChainDB.getCurrentLedger getChainDB
+                               chain  <- atomically $ ChainDB.getCurrentChain getChainDB
+                               pure TraceStartLeadershipCheckPlus {
+                                   tsSlotNo
+                                 , tsUtxoSize     = ledgerUtxoSize       ledger
+                                 , tsDelegMapSize = ledgerDelegMapSize   ledger
+                                 , tsDRepCount    = ledgerDRepCount      ledger
+                                 , tsDRepMapSize  = ledgerDRepMapSize    ledger
+                                 , tsChainDensity = fragmentChainDensity chain }
+            pure . Right $ case query of
+              SNothing    -> Left slc
+              SJust tslcp -> Right tslcp
+          Right a ->
+              pure $ Right a
+          Left control ->
+              pure $ Left control
 
 fragmentChainDensity ::
 #if __GLASGOW_HASKELL__ >= 906
   (AF.HasHeader blk, AF.HasHeader (Header blk))
 #else
   AF.HasHeader (Header blk)
 #endif
-  => AF.AnchoredFragment (Header blk) -> Rational
-fragmentChainDensity frag = calcDensity blockD slotD
+  => AF.AnchoredFragment (Header blk) -> Double
+fragmentChainDensity frag = fromRational $ calcDensity blockD slotD
   where
     calcDensity :: Word64 -> Word64 -> Rational
     calcDensity bl sl
@@ -119,18 +114,3 @@ fragmentChainDensity frag = calcDensity blockD slotD
       -- don't let it contribute to the number of blocks
       Right 0 -> 1
       Right b -> b
-
-nkQueryChain ::
-     (AF.AnchoredFragment (Header blk) -> a)
-  -> NodeKernel IO RemoteAddress LocalConnectionId blk
-  -> IO a
-nkQueryChain f NodeKernel{getChainDB} =
-  f <$> atomically (ChainDB.getCurrentChain getChainDB)
-
-
-mapNodeKernelDataIO ::
-  (NodeKernel IO RemoteAddress LocalConnectionId blk -> IO a)
-  -> NodeKernelData blk
-  -> IO (StrictMaybe a)
-mapNodeKernelDataIO f (NodeKernelData ref) =
-  readIORef ref >>= traverse f