[ADP-3350] Change chainSync to use Read.ChainPoint (#4550)

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

In order to keep the scope of this change limited, we add conversion
functions `fromWalletChainPoint` and `toWalletChainPoint` — otherwise,
we might have to propagate the change all the way to the database, which
I don't want to do here. This pull request focuses on changing the
`NetworkLayer`, not on changing the `Cardano.Wallet`.

### Comments

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

### Issue Number

ADP-3350

lib/benchmarks/exe/restore-bench.hs

@@ -204,11 +204,13 @@ import Cardano.Wallet.Primitive.Types
     , SortOrder (..)
     , WalletId (..)
     , WalletName (..)
-    , chainPointFromBlockHeader
     )
 import Cardano.Wallet.Primitive.Types.Address
     ( Address (..)
     )
+import Cardano.Wallet.Primitive.Types.Block
+    ( chainPointFromBlockHeader'
+    )
 import Cardano.Wallet.Primitive.Types.Coin
     ( Coin (..)
     )
@@ -788,7 +790,7 @@ bench_baseline_restoration
             , readChainPoints  = readTVarIO chainPointT
             , rollForward = \blocks ntip -> do
                 atomically $ writeTVar chainPointT
-                    [chainPointFromBlockHeader ntip]
+                    [chainPointFromBlockHeader' ntip]
                 let (ntxs, hss) = NE.unzip $
                         numberOfTransactionsInBlock <$> blocks
                     (heights, slots) = NE.unzip hss

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

@@ -52,7 +52,6 @@ import Cardano.Wallet.Primitive.SyncProgress
     )
 import Cardano.Wallet.Primitive.Types.Block
     ( BlockHeader
-    , ChainPoint (..)
     )
 import Cardano.Wallet.Primitive.Types.Checkpoints.Policy
     ( CheckpointPolicy
@@ -114,7 +113,7 @@ import qualified Internal.Cardano.Write.Tx as Write
 data NetworkLayer m block = NetworkLayer
     { chainSync
         :: Tracer IO ChainFollowLog
-        -> ChainFollower m ChainPoint BlockHeader (NonEmpty block)
+        -> ChainFollower m Read.ChainPoint BlockHeader (NonEmpty block)
         -> m ()
     -- ^ Connect to the node and run the ChainSync protocol.
     -- The callbacks provided in the 'ChainFollower' argument

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

@@ -85,7 +85,8 @@ import Cardano.Wallet.Network.Implementation.Ouroboros
     , send
     )
 import Cardano.Wallet.Network.Implementation.Types
-    ( fromOuroborosTip
+    ( fromOuroborosPoint
+    , fromOuroborosTip
     , toOuroborosPoint
     )
 import Cardano.Wallet.Network.Implementation.UnliftIO
@@ -98,11 +99,9 @@ import Cardano.Wallet.Primitive.Ledger.Read.Block.Header
     ( getBlockHeader
     )
 import Cardano.Wallet.Primitive.Ledger.Shelley
-    ( fromPoint
-    , fromTip'
+    ( fromTip'
     , nodeToClientVersions
     , toCardanoEra
-    , toPoint
     , unsealShelleyTx
     )
 import Cardano.Wallet.Primitive.Slotting
@@ -481,13 +480,19 @@ withNodeNetworkLayerBase
                                 (_syncProgress interpreterVar)
                     withStats $ \trChainSyncLog -> do
                         let mapB = getBlockHeader getGenesisBlockHash
-                            mapP = fromPoint
+                            mapP = fromOuroborosPoint
                         let blockHeader = fromTip' gp
                         let client =
                                 mkWalletClient
                                     (mapChainSyncLog mapB mapP >$< trChainSyncLog)
                                     pipeliningStrategy
-                                    (mapChainFollower toPoint mapP blockHeader id follower)
+                                    (mapChainFollower
+                                        toOuroborosPoint
+                                        mapP
+                                        blockHeader
+                                        id
+                                        follower
+                                    )
                                     cfg
                         traceWith trFollowLog MsgStartFollowing
                         let trChainSync = MsgConnectionStatus ClientChainSync >$< tr

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

@@ -44,7 +44,6 @@ import Cardano.Wallet.Primitive.SyncProgress
     )
 import Cardano.Wallet.Primitive.Types.Block
     ( BlockHeader
-    , ChainPoint (..)
     , slotNo
     )
 import Control.Concurrent.Class.MonadSTM
@@ -88,6 +87,7 @@ import UnliftIO.Concurrent
     ( threadDelay
     )
 
+import qualified Cardano.Wallet.Read as Read
 import qualified Data.List.NonEmpty as NE
 
 -- | Low-level logs of the ChainSync mini-protocol
@@ -114,14 +114,15 @@ mapChainSyncLog f g = \case
     MsgLocalTip point -> MsgLocalTip (g point)
     MsgTipDistance d -> MsgTipDistance d
 
-instance ToText (ChainSyncLog BlockHeader ChainPoint) where
+instance ToText (ChainSyncLog BlockHeader Read.ChainPoint) where
     toText = \case
         MsgChainFindIntersect cps ->
             mconcat
                 [ "Requesting intersection using "
                 , toText (length cps)
                 , " points"
-                , maybe "" ((", the latest being " <>) . pretty) (headMay cps)
+                , maybe "" ((", the latest being " <>) . Read.prettyChainPoint)
+                    (headMay cps)
                 ]
         MsgChainRollForward headers tip ->
             let buildRange (x :| []) = x
@@ -133,21 +134,21 @@ instance ToText (ChainSyncLog BlockHeader ChainPoint) where
                     , buildRange slots
                     , "]"
                     , ", tip is "
-                    , pretty tip
+                    , Read.prettyChainPoint tip
                     ]
         MsgChainRollBackward b 0 ->
-            "ChainSync roll backward: " <> pretty b
+            "ChainSync roll backward: " <> Read.prettyChainPoint b
         MsgChainRollBackward b bufferSize ->
             mconcat
                 [ "ChainSync roll backward: "
-                , pretty b
+                , Read.prettyChainPoint b
                 , ", handled inside pipeline buffer with remaining length "
                 , toText bufferSize
                 ]
         MsgChainTip tip ->
-            "Node tip is " <> pretty tip
+            "Node tip is " <> Read.prettyChainPoint tip
         MsgLocalTip point ->
-            "Synchronized with point: " <> pretty point
+            "Synchronized with point: " <> Read.prettyChainPoint point
         MsgTipDistance d -> "Distance to chain tip: " <> toText d <> " blocks"
 
 instance HasPrivacyAnnotation (ChainSyncLog block point)
@@ -164,7 +165,7 @@ instance HasSeverityAnnotation (ChainSyncLog block point) where
 -- | Higher level log of a chain follower.
 -- Includes computed statistics about synchronization progress.
 data ChainFollowLog
-    = MsgChainSync (ChainSyncLog BlockHeader ChainPoint)
+    = MsgChainSync (ChainSyncLog BlockHeader Read.ChainPoint)
     | MsgFollowStats (FollowStats Rearview)
     | MsgStartFollowing
     deriving (Show, Eq, Generic)
@@ -184,7 +185,7 @@ instance HasSeverityAnnotation ChainFollowLog where
 
 -- | Update the current statistics based on a new log message.
 updateStats
-    :: ChainSyncLog block ChainPoint
+    :: ChainSyncLog block Read.ChainPoint
     -> FollowStats Rearview
     -> FollowStats Rearview
 updateStats msg s = case msg of
@@ -206,7 +207,7 @@ updateStats msg s = case msg of
 withFollowStatsMonitoring
     :: Tracer IO ChainFollowLog
     -> (SlotNo -> IO SyncProgress)
-    -> (Tracer IO (ChainSyncLog BlockHeader ChainPoint) -> IO ())
+    -> (Tracer IO (ChainSyncLog BlockHeader Read.ChainPoint) -> IO ())
     -> IO ()
 withFollowStatsMonitoring tr calcSyncProgress act = do
     t0 <- getCurrentTime
@@ -216,7 +217,7 @@ withFollowStatsMonitoring tr calcSyncProgress act = do
                 s <- takeTMVar var
                 putTMVar var $! updateStats msg s
             pure $ MsgChainSync msg
-    traceWith trChainSyncLog $ MsgLocalTip ChainPointAtGenesis
+    traceWith trChainSyncLog $ MsgLocalTip Read.GenesisPoint
     race_
         (act trChainSyncLog)
         (loop var startupDelay)

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

@@ -29,9 +29,6 @@ import Cardano.Slotting.Slot
 import Cardano.Wallet.Primitive.SyncProgress
     ( SyncProgress (..)
     )
-import Cardano.Wallet.Primitive.Types.Block
-    ( ChainPoint (..)
-    )
 import Control.Concurrent.Class.MonadSTM
     ( atomically
     )
@@ -61,14 +58,16 @@ import NoThunks.Class
     , NoThunks (..)
     )
 
+import qualified Cardano.Wallet.Read as Read
+
 -- | Statistics of interest from the follow-function.
 --
 -- The @f@ allows us to use 'Rearview' to keep track of both current and
 -- previously logged stats, and perform operations over it in a nice way.
 data FollowStats f = FollowStats
     { blocksApplied :: !(f Int)
     , rollbacks :: !(f Int)
-    , localTip :: !(f ChainPoint)
+    , localTip :: !(f Read.ChainPoint)
     , time :: !(f UTCTime)
     -- ^ NOTE: Current time is not updated until @flush@ is called.
     , prog :: !(f SyncProgress)
@@ -120,7 +119,7 @@ overCurrent :: (a -> a) -> Rearview a -> Rearview a
 overCurrent f (Rearview pas cur) = Rearview pas (f cur)
 
 emptyStats :: UTCTime -> FollowStats Rearview
-emptyStats t = FollowStats (f 0) (f 0) (f ChainPointAtGenesis) (f t) (f p)
+emptyStats t = FollowStats (f 0) (f 0) (f Read.GenesisPoint) (f t) (f p)
   where
     f = initRearview
     p = NotResponding -- Hijacked as an initial value for simplicity.
@@ -149,7 +148,8 @@ instance ToText (FollowStats Rearview) where
                 [ "Applied " <> pretty (using (-) b) <> " blocks, "
                 , pretty (using (-) r) <> " rollbacks "
                 , "in the last " <> pretty (using diffUTCTime t) <> ". "
-                , "Current tip is " <> pretty (current tip) <> "."
+                , "Current tip is "
+                    <> Read.prettyChainPoint (current tip) <> "."
                 ]
           where
             using f x = f (current x) (past x)
@@ -202,9 +202,9 @@ flushStats t calcSyncProgress var = do
     forgetPast (Rearview _past curr) = initRearview curr
 
 -- See NOTE [PointSlotNo]
-pseudoSlotNo :: ChainPoint -> SlotNo
-pseudoSlotNo ChainPointAtGenesis = SlotNo 0
-pseudoSlotNo (ChainPoint slot _) = slot
+pseudoSlotNo :: Read.ChainPoint -> SlotNo
+pseudoSlotNo Read.GenesisPoint = SlotNo 0
+pseudoSlotNo (Read.BlockPoint (Read.SlotNo slot) _) = fromIntegral slot
 
 {- NOTE [PointSlotNo]
 

lib/primitive/lib/Cardano/Wallet/Primitive/Ledger/Shelley.hs

@@ -44,8 +44,6 @@ module Cardano.Wallet.Primitive.Ledger.Shelley
       -- * Conversions
     , toCardanoHash
     , unsealShelleyTx
-    , toPoint
-    , fromPoint
     , toCardanoTxId
     , toCardanoTxIn
     , fromCardanoTxIn
@@ -185,9 +183,6 @@ import Cardano.Wallet.Primitive.Ledger.Read.Tx.Features.Outputs
     , fromShelleyAddress
     , fromShelleyTxOut
     )
-import Cardano.Wallet.Primitive.Types.Block
-    ( ChainPoint (..)
-    )
 import Cardano.Wallet.Primitive.Types.Certificates
     ( PoolCertificate
     , PoolRegistrationCertificate (..)
@@ -427,14 +422,6 @@ toCardanoHash :: W.Hash "BlockHeader" -> OneEraHash (CardanoEras sc)
 toCardanoHash (W.Hash bytes) =
     OneEraHash $ toShort bytes
 
-toPoint :: W.ChainPoint -> O.Point (CardanoBlock sc)
-toPoint ChainPointAtGenesis = O.GenesisPoint
-toPoint (ChainPoint slot h) = O.BlockPoint slot (toCardanoHash h)
-
-fromPoint :: O.Point (CardanoBlock sc) -> W.ChainPoint
-fromPoint O.GenesisPoint = ChainPointAtGenesis
-fromPoint (O.BlockPoint slot h) = ChainPoint slot (fromCardanoHash h)
-
 getProducer
     :: (Era era, EncCBORGroup (TxSeq era))
     => ShelleyBlock (Consensus.TPraos StandardCrypto) era -> PoolId

lib/unit/test/unit/Cardano/Wallet/NetworkSpec.hs

@@ -21,7 +21,6 @@ import Cardano.Wallet.Network
     )
 import Cardano.Wallet.Primitive.Types
     ( BlockHeader (..)
-    , ChainPoint (..)
     )
 import Data.Time.Clock
     ( getCurrentTime
@@ -42,6 +41,7 @@ import Test.QuickCheck
     , property
     )
 
+import qualified Cardano.Wallet.Read as Read
 import qualified Data.List.NonEmpty as NE
 
 spec :: Spec
@@ -51,7 +51,7 @@ spec = do
 
     describe "updateStats" $ do
         it "results in no unexpected thunks" $ property $
-          \(msg :: ChainSyncLog () ChainPoint) -> do
+          \(msg :: ChainSyncLog () Read.ChainPoint) -> do
             -- This test is not /fully/ fool-proof. Adding lots of nested types to
             -- LogState and logic in updateStats not covered by the generator
             -- might cause us to miss a thunk.
@@ -64,7 +64,7 @@ spec = do
                 Nothing -> return ()
                 Just x -> expectationFailure $ show x
 
-instance Arbitrary block => Arbitrary (ChainSyncLog block ChainPoint) where
+instance Arbitrary block => Arbitrary (ChainSyncLog block Read.ChainPoint) where
     arbitrary = oneof
         [ MsgChainRollForward <$> genNonEmpty <*> genChainPoint
         , MsgChainRollBackward <$> genChainPoint <*> arbitrary

lib/wallet/src/Cardano/Wallet.hs

@@ -431,6 +431,7 @@ import Cardano.Wallet.Network
     , ChainFollower (..)
     , ErrPostTx (..)
     , NetworkLayer (..)
+    , mapChainFollower
     )
 import Cardano.Wallet.Network.RestorationMode
     ( RestorationPoint (..)
@@ -522,6 +523,10 @@ import Cardano.Wallet.Primitive.Types.Address
 import Cardano.Wallet.Primitive.Types.AssetId
     ( AssetId
     )
+import Cardano.Wallet.Primitive.Types.Block
+    ( fromWalletChainPoint
+    , toWalletChainPoint
+    )
 import Cardano.Wallet.Primitive.Types.BlockSummary
     ( ChainEvents
     )
@@ -1264,8 +1269,14 @@ restoreWallet ctx = db & \DBLayer{..} ->
         rollBackward = rollbackBlocks ctx . toSlot
         rollForward' = restoreBlocks ctx (contramap MsgWalletFollow tr)
     in
-      catchFromIO $
-            chainSync nw (contramap MsgChainFollow tr) $ ChainFollower
+      catchFromIO
+        $ chainSync nw (contramap MsgChainFollow tr)
+        $ mapChainFollower
+            fromWalletChainPoint
+            toWalletChainPoint
+            id
+            id
+            ChainFollower
                 { checkpointPolicy
                 , readChainPoints
                 , rollForward = \blocks tip ->

lib/wallet/src/Cardano/Wallet/Gen.hs

@@ -47,9 +47,7 @@ import Cardano.Wallet.Address.Discovery.Shared
     ( retrieveAllCosigners
     )
 import Cardano.Wallet.Primitive.Types
-    ( BlockHeader (..)
-    , ChainPoint (..)
-    , Slot
+    ( Slot
     , SlotNo (..)
     , WalletId (..)
     , WithOrigin (..)
@@ -114,6 +112,7 @@ import Test.QuickCheck
     )
 
 import qualified Cardano.Byron.Codec.Cbor as CBOR
+import qualified Cardano.Wallet.Read as Read
 import qualified Codec.CBOR.Write as CBOR
 import qualified Data.ByteString as BS
 import qualified Data.Map as Map
@@ -170,13 +169,17 @@ genSlotNo = SlotNo . fromIntegral <$> arbitrary @Word32
 shrinkSlotNo :: SlotNo -> [SlotNo]
 shrinkSlotNo (SlotNo x) = map SlotNo $ shrink x
 
-genChainPoint :: Gen ChainPoint
+genChainPoint :: Gen Read.ChainPoint
 genChainPoint = frequency
-    [ ( 1, pure ChainPointAtGenesis)  -- "common" but not "very common"
-    , (40, toChainPoint <$> (genBlockHeader =<< genSlotNo))
+    [ ( 1, pure Read.GenesisPoint)  -- "common" but not "very common"
+    , (40, Read.BlockPoint <$> genReadSlotNo <*> genHeaderHash)
     ]
   where
-    toChainPoint (BlockHeader slot _ h _) = ChainPoint slot h
+    genReadSlotNo = Read.SlotNo . fromIntegral <$> arbitrary @Word32
+    genHeaderHash = elements mockHashes
+
+mockHashes :: [Read.RawHeaderHash]
+mockHashes = map Read.mockRawHeaderHash [0..2]
 
 genSlot :: Gen Slot
 genSlot = frequency