[ADP-3350] Change watchNodeTip to use Read.ChainTip (#4549)

This pull request changes the `watchNodeTip` function to use the data
type `ChainTip` from the `Cardano.Wallet.Read` hierarchy.

In order to make creation of mock hashes for testing easier, I have
added a function `mockRawHeaderHash`.

### Comments

* The goal is to eventually remove the legacy `primitive` types.

### Issue Number

ADP-3350

lib/benchmarks/exe/api-bench.hs

@@ -144,9 +144,6 @@ import Data.Aeson
     , genericToJSON
     , (.=)
     )
-import Data.Maybe
-    ( fromJust
-    )
 import Data.Quantity
     ( Quantity (..)
     )
@@ -183,10 +180,8 @@ import qualified Cardano.Wallet.DB.Layer as DB
 import qualified Cardano.Wallet.DB.Layer as Sqlite
 import qualified Cardano.Wallet.Primitive.Types.UTxOStatistics as UTxOStatistics
 import qualified Cardano.Wallet.Read as Read
-import qualified Cardano.Wallet.Read.Hash as Hash
 import qualified Cardano.Wallet.Transaction as Tx
 import qualified Data.Aeson as Aeson
-import qualified Data.ByteString.Char8 as B8
 import qualified Data.Map.Strict as Map
 import qualified Data.Text as T
 import qualified Internal.Cardano.Write.Tx as Write
@@ -554,7 +549,7 @@ mockNetworkLayer = dummyNetworkLayer
     }
 
 mockHash :: Read.RawHeaderHash
-mockHash = fromJust $ Hash.hashFromBytes (B8.replicate 32 'a')
+mockHash = Read.mockRawHeaderHash 0
 
 mockTimeInterpreter :: TimeInterpreter IO
 mockTimeInterpreter = dummyTimeInterpreter

lib/network-layer/src/Cardano/Wallet/Network.hs

@@ -145,7 +145,7 @@ data NetworkLayer m block = NetworkLayer
     -- ^ Get the last known slotting parameters. In principle, these can
     -- only change once per era.
     , watchNodeTip
-        :: (BlockHeader -> m ())
+        :: (Read.ChainTip -> m ())
         -> m ()
     -- ^ Register a callback for when the node tip changes.
     -- This function should never finish, unless the callback throws an

lib/network-layer/src/Cardano/Wallet/Network/Implementation.hs

@@ -99,7 +99,6 @@ import Cardano.Wallet.Primitive.Ledger.Read.Block.Header
     )
 import Cardano.Wallet.Primitive.Ledger.Shelley
     ( fromPoint
-    , fromTip
     , fromTip'
     , nodeToClientVersions
     , toCardanoEra
@@ -385,6 +384,7 @@ import qualified Cardano.Wallet.Primitive.SyncProgress as SP
 import qualified Cardano.Wallet.Primitive.Types.Coin as W
 import qualified Cardano.Wallet.Primitive.Types.RewardAccount as W
 import qualified Cardano.Wallet.Primitive.Types.Tx as W
+import qualified Cardano.Wallet.Read as Read
 import qualified Codec.CBOR.Term as CBOR
 import qualified Data.Map as Map
 import qualified Data.Set as Set
@@ -654,10 +654,11 @@ withNodeNetworkLayerBase
                     return res
                 Nothing -> pure $ StakePoolsSummary 0 mempty mempty
 
-        _watchNodeTip readTip cb = do
+        _watchNodeTip readTip callback = do
             observeForever readTip $ \tip -> do
-                let header = fromTip getGenesisBlockHash tip
-                bracketTracer (contramap (MsgWatcherUpdate header) tr) $ cb header
+                let tip' = fromOuroborosTip tip
+                bracketTracer (contramap (MsgWatcherUpdate tip') tr)
+                    $ callback tip'
 
         -- TODO(#2042): Make wallets call manually, with matching stopObserving.
         _getCachedRewardAccountBalance rewardsObserver k = do
@@ -1356,7 +1357,7 @@ data Log where
         -> Log
         -- ^ Number of pools in stake distribution, and rewards map,
         -- respectively.
-    MsgWatcherUpdate :: BlockHeader -> BracketLog -> Log
+    MsgWatcherUpdate :: Read.ChainTip -> BracketLog -> Log
     MsgInterpreter :: CardanoInterpreter StandardCrypto -> Log
     -- TODO: Combine ^^ and vv
     MsgInterpreterLog :: TimeInterpreterLog -> Log
@@ -1428,7 +1429,7 @@ instance ToText Log where
                 ]
         MsgWatcherUpdate tip b ->
             "Update watcher with tip: "
-                <> pretty tip
+                <> Read.prettyChainTip tip
                 <> ". Callback "
                 <> toText b
                 <> "."

lib/read/lib/Cardano/Wallet/Read/Block.hs

@@ -33,6 +33,7 @@ import Cardano.Wallet.Read.Block.HeaderHash
     , getEraHeaderHash
     , getEraPrevHeaderHash
     , getRawHeaderHash
+    , mockRawHeaderHash
     )
 import Cardano.Wallet.Read.Block.SlotNo
     ( SlotNo (..)

lib/read/lib/Cardano/Wallet/Read/Block/HeaderHash.hs

@@ -16,6 +16,9 @@ module Cardano.Wallet.Read.Block.HeaderHash
     , PrevHeaderHash (..)
     , PrevHeaderHashT
     , getEraPrevHeaderHash
+
+    -- * Testing utilities
+    , mockRawHeaderHash
     )
 where
 
@@ -81,6 +84,8 @@ import Ouroboros.Consensus.Shelley.Protocol.TPraos
 import qualified Cardano.Crypto.Hashing as Byron
 import qualified Cardano.Ledger.Api as L
 import qualified Cardano.Ledger.Shelley.API as Shelley
+import qualified Cardano.Wallet.Read.Hash as Hash
+import qualified Data.ByteString.Char8 as B8
 import qualified Ouroboros.Consensus.Shelley.Ledger.Block as O
 import qualified Ouroboros.Consensus.Shelley.Protocol.Abstract as Shelley
 import qualified Ouroboros.Network.Block as O
@@ -131,6 +136,11 @@ data BHeader
 -- | Raw hash digest for a block header.
 type RawHeaderHash = Hash Blake2b_256 BHeader
 
+-- | Construct a 'RawHeaderHash' that is good enough for testing.
+mockRawHeaderHash :: Integer -> RawHeaderHash
+mockRawHeaderHash n =
+    Hash.hashWith (\_ -> B8.pack $ show n) (error "undefined :: BHeader")
+
 {-# INLINABLE getRawHeaderHash #-}
 getRawHeaderHash :: forall era. IsEra era => HeaderHash era -> RawHeaderHash
 getRawHeaderHash = case theEra @era of

lib/unit/test/unit/Cardano/Wallet/Api/ServerSpec.hs

@@ -74,8 +74,7 @@ import Data.Either
     ( isLeft
     )
 import Data.Maybe
-    ( fromJust
-    , isJust
+    ( isJust
     , isNothing
     )
 import Data.SOP.Counting
@@ -143,7 +142,6 @@ import UnliftIO.Concurrent
 
 import qualified Cardano.Wallet.Primitive.SyncProgress as S
 import qualified Cardano.Wallet.Read as Read
-import qualified Cardano.Wallet.Read.Hash as Hash
 import qualified Data.ByteString.Char8 as B8
 import qualified Data.ByteString.Lazy as BL
 import qualified Ouroboros.Consensus.HardFork.History.EraParams as HF
@@ -278,7 +276,7 @@ networkInfoSpec = describe "getNetworkInformation" $ do
             }
       where
         mockHash :: Read.RawHeaderHash
-        mockHash = fromJust $ Hash.hashFromBytes $ B8.replicate 32 'a'
+        mockHash = Read.mockRawHeaderHash 0
 
     forkInterpreter startTime =
         let

lib/unit/test/unit/Cardano/WalletSpec.hs

@@ -125,7 +125,6 @@ import Cardano.Wallet.Primitive.Passphrase.Current
     )
 import Cardano.Wallet.Primitive.Types
     ( ActiveSlotCoefficient (..)
-    , BlockHeader (BlockHeader)
     , NetworkParameters (..)
     , SlotNo (..)
     , SlottingParameters (..)
@@ -1002,13 +1001,20 @@ prop_localTxSubmission tc = monadicIO $ do
         , watchNodeTip = mockNodeTip (numSlots tc) 0
         }
 
-    mockNodeTip end sl cb
-        | sl < end = do
-            let h = Hash ""
-            void $ cb $ BlockHeader (SlotNo sl) (Quantity (fromIntegral sl)) h (Just h)
-            mockNodeTip end (sl + 1) cb
+    mockNodeTip end slot callback
+        | slot < end = do
+            let tip = Read.BlockTip
+                    { slotNo = Read.SlotNo $ fromIntegral slot
+                    , headerHash = mockHash
+                    , blockNo = Read.BlockNo $ fromIntegral slot
+                    }
+            void $ callback tip
+            mockNodeTip end (slot + 1) callback
         | otherwise = pure ()
 
+    mockHash :: Read.RawHeaderHash
+    mockHash = Read.mockRawHeaderHash 0
+
     stash :: MVar [a] -> a -> TxRetryTestM ()
     stash var x = modifyMVar_ var (\xs -> pure (x:xs))
 

lib/wallet/src/Cardano/Wallet.hs

@@ -1651,8 +1651,8 @@ manageRewardBalance
     -> DBLayer IO (SeqState n ShelleyKey)
     -> IO ()
 manageRewardBalance tr' netLayer db = do
-    watchNodeTip netLayer $ \bh -> do
-         traceWith tr $ MsgRewardBalanceQuery bh
+    watchNodeTip netLayer $ \nodeTip -> do
+         traceWith tr $ MsgRewardBalanceQuery nodeTip
          query <- do
             (acct, _, _) <- readRewardAccount db
             liftIO $ getCachedRewardAccountBalance netLayer acct
@@ -1695,8 +1695,8 @@ manageSharedRewardBalance
     -> DBLayer IO (SharedState n SharedKey)
     -> IO ()
 manageSharedRewardBalance tr' netLayer db = do
-    watchNodeTip netLayer $ \bh -> do
-         traceWith tr $ MsgRewardBalanceQuery bh
+    watchNodeTip netLayer $ \nodeTip -> do
+         traceWith tr $ MsgRewardBalanceQuery nodeTip
          query <- runExceptT $ do
             (acct, _, _) <-
                 lift $ readRewardAccount @(SharedState n SharedKey) db
@@ -2804,10 +2804,13 @@ runLocalTxSubmissionPool
     -> WalletLayer m s
     -> m ()
 runLocalTxSubmissionPool cfg ctx = db & \DBLayer{..} -> do
-    submitPending <- rateLimited $ \bh -> bracketTracer trBracket $ do
+    submitPending <- rateLimited $ \nodeTip -> bracketTracer trBracket $ do
         sp <- currentSlottingParameters nw
         pending <- readLocalTxSubmissionPending ctx
-        let sl = bh ^. #slotNo
+        let sl = case nodeTip of
+                Read.GenesisTip -> SlotNo 0
+                Read.BlockTip{slotNo} ->
+                    SlotNo $ fromIntegral $ Read.unSlotNo slotNo
             pendingOldStyle = pending >>= mkLocalTxSubmission
         -- Re-submit transactions due, ignore errors
         forM_ (filter (isScheduled sp sl) pendingOldStyle) $ \st -> do
@@ -3856,7 +3859,7 @@ data WalletFollowLog
 data WalletLog
     = MsgMigrationUTxOBefore UTxOStatistics
     | MsgMigrationUTxOAfter UTxOStatistics
-    | MsgRewardBalanceQuery BlockHeader
+    | MsgRewardBalanceQuery Read.ChainTip
     | MsgRewardBalanceResult (Either ErrFetchRewards Coin)
     | MsgRewardBalanceExited
     | MsgTxSubmit TxSubmitLog
@@ -3906,8 +3909,9 @@ instance ToText WalletLog where
             "About to migrate the following distribution: \n" <> pretty summary
         MsgMigrationUTxOAfter summary ->
             "Expected distribution after complete migration: \n" <> pretty summary
-        MsgRewardBalanceQuery bh ->
-            "Updating the reward balance for block " <> pretty bh
+        MsgRewardBalanceQuery nodeTip ->
+            "Updating the reward balance for block "
+            <> Read.prettyChainTip nodeTip
         MsgRewardBalanceResult (Right amt) ->
             "The reward balance is " <> pretty amt
         MsgRewardBalanceResult (Left err) ->