log: make cut logging more descriptive

Now we get a diff when the cut db has a new cut! See example:

current cut is now psY73l diff:
    13 @ M-plFQ (height 4810061) -> 13 @ OhqXKd (height 4810062)

Change-Id: If906446190bb2cf7cb6d88c4933a82711462f462

changes/2024-05-30T145052-0400.txt

@@ -0,0 +1 @@
+Cut pipeline logging is more descriptive

src/Chainweb/BlockHash.hs

@@ -39,6 +39,7 @@ module Chainweb.BlockHash
 , decodeBlockHash
 , nullBlockHash
 , blockHashToText
+, blockHashToTextShort
 , blockHashFromText
 
 -- * Block Hash Record
@@ -154,6 +155,9 @@ blockHashToText :: BlockHash_ a -> T.Text
 blockHashToText = encodeB64UrlNoPaddingText . runPutS . encodeBlockHash
 {-# INLINE blockHashToText #-}
 
+blockHashToTextShort :: BlockHash_ a -> T.Text
+blockHashToTextShort = T.take 6 . blockHashToText
+
 blockHashFromText
     :: MerkleHashAlgorithm a
     =>  MonadThrow m

src/Chainweb/BlockHeader.hs

@@ -89,6 +89,7 @@ module Chainweb.BlockHeader
 , decodeBlockHeaderWithoutHash
 , decodeBlockHeaderChecked
 , decodeBlockHeaderCheckedChainId
+, blockHeaderShortDescription
 , ObjectEncoded(..)
 
 , timeBetween
@@ -386,6 +387,18 @@ instance IsCasValue BlockHeader where
 
 type BlockHeaderCas tbl = Cas tbl BlockHeader
 
+-- | Used for quickly identifying "which block" this is.
+-- Example output:
+-- "0 @ bSQgL5 (height 4810062)"
+blockHeaderShortDescription :: BlockHeader -> T.Text
+blockHeaderShortDescription bh =
+    T.unwords
+        [ toText (_chainId bh)
+        , "@"
+        , blockHashToTextShort (_blockHash bh)
+        , "(height " <> sshow (getBlockHeight $ _blockHeight bh) <> ")"
+        ]
+
 makeLenses ''BlockHeader
 
 -- | During the first epoch after genesis there are 10 extra difficulty

src/Chainweb/Cut.hs

@@ -38,6 +38,8 @@
 --
 module Chainweb.Cut
 ( Cut
+, cutToTextShort
+, cutDiffToTextShort
 , _cutMap
 , cutMap
 , _cutHeight
@@ -106,9 +108,11 @@ import Data.Functor.Of
 import qualified Data.HashMap.Strict as HM
 import qualified Data.HashSet as HS
 import qualified Data.Heap as H
+import qualified Data.List as List
 import Data.Maybe (catMaybes, fromMaybe)
 import Data.Monoid
 import Data.Ord
+import Data.Text (Text)
 import qualified Data.Text as T
 import Data.These
 
@@ -898,3 +902,22 @@ forkDepth wdb a b = do
     maxDepth l u = maximum
         $ (\(_, x, y) -> _blockHeight y - _blockHeight x)
         <$> zipCuts l u
+
+cutToTextShort :: Cut -> [Text]
+cutToTextShort c =
+    [ blockHeaderShortDescription bh
+    | (_, bh) <- List.sortOn fst $ HM.toList (_cutHeaders c)
+    ]
+
+cutDiffToTextShort :: Cut -> Cut -> [Text]
+cutDiffToTextShort c c' =
+    [ T.unwords
+        [ maybe "No block" blockHeaderShortDescription bh
+        , "->"
+        , maybe "No block" blockHeaderShortDescription bh'
+        ]
+    | cid <- List.sort $ HM.keys $ HM.union (_cutHeaders c) (_cutHeaders c')
+    , let bh = HM.lookup cid (_cutHeaders c)
+    , let bh' = HM.lookup cid (_cutHeaders c')
+    , bh /= bh'
+    ]

src/Chainweb/CutDB.hs

@@ -433,7 +433,8 @@ startCutDb config logfun headerStore payloadStore cutHashesStore = mask_ $ do
             (Just $ over _1 succ $ casKey $ cutToCutHashes Nothing initialCut, Nothing)
     cutVar <- newTVarIO initialCut
     c <- readTVarIO cutVar
-    logg Info $ "got initial cut: " <> sshow c
+    logg Info $ T.unlines $
+        "got initial cut:" : ["    " <> block | block <- cutToTextShort c]
     queue <- newEmptyPQueue
     cutAsync <- asyncWithUnmask $ \u -> u $ processor queue cutVar
     logg Debug "CutDB started"
@@ -554,16 +555,16 @@ processCuts
 processCuts conf logFun headerStore payloadStore cutHashesStore queue cutVar = do
     rng <- Prob.createSystemRandom
     queueToStream
-        & S.chain (\c -> loggc Debug c "start processing")
+        & S.chain (\c -> loggCutId Debug c "start processing")
         & S.filterM (fmap not . isVeryOld)
         & S.filterM (fmap not . farAhead)
         & S.filterM (fmap not . isOld)
         & S.filterM (fmap not . isCurrent)
-        & S.chain (\c -> loggc Debug c "fetch all prerequesites")
+        & S.chain (\c -> loggCutId Info c "fetch all prerequesites")
         & S.mapM (cutHashesToBlockHeaderMap conf logFun headerStore payloadStore)
         & S.chain (either
-            (\(T2 hsid c) -> loggc Warn hsid $ "failed to get prerequesites for some blocks. Missing: " <> encodeToText c)
-            (\c -> loggc Info c "got all prerequesites")
+            (\(T2 hsid c) -> loggCutId Warn hsid $ "failed to get prerequesites for some blocks. Missing: " <> encodeToText c)
+            (\_ -> return ())
             )
         & S.concat
             -- ignore left values for now
@@ -577,14 +578,24 @@ processCuts conf logFun headerStore payloadStore cutHashesStore queue cutVar = d
                 $ joinIntoHeavier_ hdrStore (_cutMap curCut) newCut
             unless (_cutDbParamsReadOnly conf) $ do
                 maybePrune rng (cutAvgBlockHeight v curCut)
-                loggc Info newCut "writing cut"
+                loggCutId Debug newCut "writing cut"
                 casInsert cutHashesStore (cutToCutHashes Nothing resultCut)
             atomically $ writeTVar cutVar resultCut
-            loggc Info resultCut "published cut"
+            let cutDiff = cutDiffToTextShort curCut resultCut
+            let currentCutIdMsg = T.unwords
+                    [ "current cut is now"
+                    , cutIdToTextShort (_cutId resultCut) <> ","
+                    , "diff:"
+                    ]
+            let catOverflowing x xs =
+                    if length xs == 1
+                    then T.unwords (x : xs)
+                    else T.intercalate "\n" (x : (map ("    " <>) xs))
+            logFun @T.Text Info $ catOverflowing currentCutIdMsg cutDiff
             )
   where
-    loggc :: HasCutId c => LogLevel -> c -> T.Text -> IO ()
-    loggc l c msg = logFun @T.Text l $  "cut " <> cutIdToTextShort (_cutId c) <> ": " <> msg
+    loggCutId :: HasCutId c => LogLevel -> c -> T.Text -> IO ()
+    loggCutId l c msg = logFun @T.Text l $  "cut " <> cutIdToTextShort (_cutId c) <> ": " <> msg
 
     v = _chainwebVersion headerStore
 
@@ -615,7 +626,7 @@ processCuts conf logFun headerStore payloadStore cutHashesStore queue cutVar = d
         curMax <- maxChainHeight <$> readTVarIO cutVar
         let newMax = _cutHashesMaxHeight x
         let r = newMax >= curMax + farAheadThreshold
-        when r $ loggc Debug x
+        when r $ loggCutId Debug x
             $ "skip far ahead cut. Current maximum block height: " <> sshow curMax
             <> ", got: " <> sshow newMax
             -- log at debug level because this is a common case during catchup
@@ -635,7 +646,7 @@ processCuts conf logFun headerStore payloadStore cutHashesStore queue cutVar = d
         let diam = diameter $ chainGraphAt headerStore curMin
             newMin = _cutHashesMinHeight x
         let r = newMin + 2 * (1 + int diam) <= curMin
-        when r $ loggc Debug x "skip very old cut"
+        when r $ loggCutId Debug x "skip very old cut"
             -- log at debug level because this is a common case during catchup
         return r
 
@@ -644,13 +655,13 @@ processCuts conf logFun headerStore payloadStore cutHashesStore queue cutVar = d
     isOld x = do
         curHashes <- cutToCutHashes Nothing <$> readTVarIO cutVar
         let r = all (>= (0 :: Int)) $ (HM.unionWith (-) `on` (fmap (int . _bhwhHeight) . _cutHashes)) curHashes x
-        when r $ loggc Debug x "skip old cut"
+        when r $ loggCutId Debug x "skip old cut"
         return r
 
     isCurrent x = do
         curHashes <- cutToCutHashes Nothing <$> readTVarIO cutVar
         let r = _cutHashes curHashes == _cutHashes x
-        when r $ loggc Debug x "skip current cut"
+        when r $ loggCutId Debug x "skip current cut"
         return r
 
 -- | Stream of most recent cuts. This stream does not generally include the full