Refactor chain following

lib/core/src/Cardano/Wallet.hs

@@ -887,7 +887,8 @@ restoreWallet
     :: forall ctx s k.
         ( HasNetworkLayer IO ctx
         , HasDBLayer IO s k ctx
-        , HasLogger IO WalletWorkerLog ctx
+        , HasGenesisData ctx
+        , HasLogger WalletWorkerLog ctx
         , IsOurs s Address
         , IsOurs s RewardAccount
         )
@@ -896,8 +897,8 @@ restoreWallet
     -> ExceptT ErrNoSuchWallet IO ()
 restoreWallet ctx wid = db & \DBLayer{..} -> do
     liftIO $ chainSync nw (contramap MsgChainFollow tr) $ ChainFollower
-        { readLocalTip =
-            liftIO $ atomically $ map toChainPoint <$> listCheckpoints wid
+        { readLocalTip = liftIO $ atomically $
+            map (toChainPoint block0) <$> listCheckpoints wid
         , rollForward = \blocks tip -> throwInIO $
             restoreBlocks @ctx @s @k
                 ctx (contramap MsgWalletFollow tr) wid blocks tip
@@ -908,6 +909,7 @@ restoreWallet ctx wid = db & \DBLayer{..} -> do
     db = ctx ^. dbLayer @IO @s @k
     nw = ctx ^. networkLayer @IO
     tr = ctx ^. logger @WalletWorkerLog
+    (block0, _, _) = ctx ^. genesisData
 
     throwInIO :: ExceptT ErrNoSuchWallet IO a -> IO a
     throwInIO x = runExceptT x >>= \case
@@ -917,23 +919,32 @@ restoreWallet ctx wid = db & \DBLayer{..} -> do
 -- | Rewind the UTxO snapshots, transaction history and other information to a
 -- the earliest point in the past that is before or is the point of rollback.
 rollbackBlocks
-    :: forall ctx s k. (HasDBLayer IO s k ctx)
+    :: forall ctx s k.
+        ( HasDBLayer IO s k ctx
+        , HasGenesisData ctx
+        )
     => ctx
     -> WalletId
     -> ChainPoint
     -> ExceptT ErrNoSuchWallet IO ChainPoint
 rollbackBlocks ctx wid point = db & \DBLayer{..} -> do
-    mapExceptT atomically $ toChainPoint <$> rollbackTo wid (pseudoPointSlot point)
+    mapExceptT atomically $ (toChainPoint block0)
+        <$> rollbackTo wid (pseudoPointSlot point)
   where
     db = ctx ^. dbLayer @IO @s @k
+    (block0, _, _) = ctx ^. genesisData
 
--- See NOTE [PointSlotNo]
-pseudoPointSlot :: ChainPoint -> SlotNo
-pseudoPointSlot ChainPointAtGenesis = W.SlotNo 0
-pseudoPointSlot (ChainPoint slot _) = slot
+    -- See NOTE [PointSlotNo]
+    pseudoPointSlot :: ChainPoint -> SlotNo
+    pseudoPointSlot ChainPointAtGenesis = W.SlotNo 0
+    pseudoPointSlot (ChainPoint slot _) = slot
 
-toChainPoint :: W.BlockHeader -> ChainPoint
-toChainPoint (BlockHeader slot _ h _) = ChainPoint slot h
+toChainPoint :: W.Block -> W.BlockHeader -> ChainPoint
+toChainPoint genesisBlock (BlockHeader slot _ h _)
+    | slot == 0 && h == genesisHash = ChainPointAtGenesis
+    | otherwise                     = ChainPoint slot h
+  where
+    genesisHash = genesisBlock ^. (#header . #headerHash)
 
 {- NOTE [PointSlotNo] 
 

lib/core/src/Cardano/Wallet/Network.hs

@@ -450,7 +450,7 @@ instance ToText (FollowStats Rearview) where
             [ "Applied " <> pretty (using (-) b) <> " blocks, "
             , pretty (using (-) r) <> " rollbacks "
             , "in the last " <> pretty (using diffUTCTime t) <> ". "
-            , "Currently tip is" <> pretty (current tip) <> "."
+            , "Current tip is " <> pretty (current tip) <> "."
             ]
           where
             using f x = f (current x) (past x)

lib/core/src/Ouroboros/Network/Client/Wallet.hs

@@ -61,7 +61,7 @@ import Control.Monad.Class.MonadSTM
     , writeTQueue
     )
 import Control.Monad.Class.MonadThrow
-    ( MonadThrow )
+    ( Exception, MonadThrow, throwIO )
 import Control.Monad.IO.Class
     ( MonadIO )
 import Data.Functor
@@ -219,7 +219,6 @@ chainSyncFollowTip toCardanoEra onTipUpdate =
 type RequestNextStrategy m n block
     = P.ClientPipelinedStIdle n block (Point block) (Tip block) m Void
 
-
 -- | Helper type for the different ways we handle rollbacks.
 --
 -- Helps remove some boilerplate.
@@ -271,7 +270,7 @@ data LocalRollbackResult block
 --      *------*
 --
 chainSyncWithBlocks
-    :: forall m block. (Monad m, MonadSTM m, HasHeader block)
+    :: forall m block. (Monad m, MonadSTM m, MonadThrow m, HasHeader block)
     => Tracer m (ChainSyncLog block (Point block))
     -> ChainFollower m (Point block) (Tip block) block
     -> ChainSyncClientPipelined block (Point block) (Tip block) m Void
@@ -321,9 +320,21 @@ chainSyncWithBlocks tr chainFollower =
             --
             -- See also
             -- https://input-output-rnd.slack.com/archives/CDA6LUXAQ/p1634644689103100
-            pure clientStIntersect
+            clientStNegotiateGenesis
             }
 
+    -- Explictly negotiate the genesis point
+    clientStNegotiateGenesis
+        :: m (P.ClientPipelinedStIdle 'Z block (Point block) (Tip block) m Void)
+    clientStNegotiateGenesis = do
+        let genesis = [Point Origin]
+        traceWith tr $ MsgChainFindIntersect genesis
+        pure $ P.SendMsgFindIntersect genesis $
+            clientStIntersect
+                { P.recvMsgIntersectNotFound = \_tip ->
+                    throwIO ErrChainSyncNoIntersectGenesis
+                }
+
     clientStIdle
         :: RequestNextStrategy m 'Z block
         -> m (P.ClientPipelinedStIdle 'Z block (Point block) (Tip block) m Void)
@@ -659,3 +670,15 @@ send queue cmd = do
     tvar <- newEmptyTMVarIO
     atomically $ writeTQueue queue (cmd (atomically . putTMVar tvar))
     atomically $ takeTMVar tvar
+
+{-------------------------------------------------------------------------------
+    Errors
+-------------------------------------------------------------------------------}
+data ErrChainSync
+    = ErrChainSyncNoIntersectGenesis
+    -- ^ The node does not give us genesis when we request it with a
+    -- 'MsgFindIntersect' message in the ChainSync protocol.
+    -- This should not happen.
+    deriving (Eq, Show)
+
+instance Exception ErrChainSync

lib/core/test/unit/Cardano/Wallet/DB/StateMachine.hs

@@ -535,7 +535,7 @@ runIO db@DBLayer{..} = fmap Resp . go
         ReadDelegationRewardBalance wid -> Right . DelegationRewardBalance <$>
             atomically (readDelegationRewardBalance wid)
         RollbackTo wid sl -> catchNoSuchWallet Point $
-            mapExceptT atomically $ fmap slotNo $ rollbackTo wid sl
+            mapExceptT atomically (slotNo <$> rollbackTo wid sl)
 
     catchWalletAlreadyExists f =
         fmap (bimap errWalletAlreadyExists f) . runExceptT

lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs

@@ -550,7 +550,8 @@ monitorStakePools tr (NetworkParameters gp sp _pp) nl DBLayer{..} =
             pseudoPointSlot (ChainPoint slot _) = slot
 
             toChainPoint :: BlockHeader -> ChainPoint
-            toChainPoint (BlockHeader slot _ h _) = ChainPoint slot h
+            toChainPoint (BlockHeader  0 _ _ _) = ChainPointAtGenesis
+            toChainPoint (BlockHeader sl _ h _) = ChainPoint sl h
 
         chainSync nl (contramap MsgChainMonitoring tr) $ ChainFollower
             { readLocalTip = map toChainPoint <$> initCursor