From f0296ef2a8d8d0c6d036f2166cf99e9786d9f97a Mon Sep 17 00:00:00 2001
From: Heinrich Apfelmus <heinrich.apfelmus@iohk.io>
Date: Mon, 18 Oct 2021 18:17:07 +0200
Subject: [PATCH 01/10] Reorganize "Cardano.Wallet.Shelley.Network"

* Group existing functions into logical sections
* Refactor `connectCardanoApiClient` to be more general and to compete directly with `connectClient`
* Add `mkLocalTxSubmissionClient` to follow the existing pattern for creating protocol clients.
---
 .../src/Cardano/Wallet/Shelley/Network.hs     | 373 +++++++++---------
 1 file changed, 193 insertions(+), 180 deletions(-)

diff --git a/lib/shelley/src/Cardano/Wallet/Shelley/Network.hs b/lib/shelley/src/Cardano/Wallet/Shelley/Network.hs
index 2a1c18cd93c..9f3815c90c0 100644
--- a/lib/shelley/src/Cardano/Wallet/Shelley/Network.hs
+++ b/lib/shelley/src/Cardano/Wallet/Shelley/Network.hs
@@ -49,6 +49,7 @@ import Cardano.Api
     , CardanoMode
     , LocalChainSyncClient (NoLocalChainSyncClient)
     , LocalNodeClientProtocols (..)
+    , LocalNodeClientProtocolsInMode
     , LocalNodeConnectInfo (..)
     , NodeToClientVersion (..)
     , SlotNo (..)
@@ -293,7 +294,11 @@ data instance Cursor = Cursor
     (Point (CardanoBlock StandardCrypto))
     (TQueue IO (ChainSyncCmd (CardanoBlock StandardCrypto) IO))
 
--- | Create an instance of the network layer
+{-------------------------------------------------------------------------------
+    Create/Initialize a NetworkLayer
+-------------------------------------------------------------------------------}
+
+-- | Create an instance of 'NetworkLayer' by connecting to a local node.
 withNetworkLayer
     :: HasCallStack
     => Tracer IO NetworkLayerLog
@@ -389,12 +394,6 @@ withNetworkLayerBase tr net np conn versionData tol action = do
     connectInfo = localNodeConnectInfo sp net conn
     cfg = codecConfig sp
 
-    -- Put if empty, replace if not empty.
-    repsertTMVar var x = do
-        e <- isEmptyTMVar var
-        unless e $ void $ takeTMVar var
-        putTMVar var x
-
     connectNodeTipClient
         :: HasCallStack
         => RetryHandlers
@@ -423,7 +422,8 @@ withNetworkLayerBase tr net np conn versionData tol action = do
               )
     connectLocalTxSubmissionClient handlers = do
         q <- atomically newTQueue
-        link =<< async (connectCardanoApiClient tr handlers connectInfo q)
+        let client = mkLocalTxSubmissionClient tr q
+        link =<< async (connectCardanoApiClient tr handlers connectInfo client)
         pure q
 
     connectDelegationRewardsClient
@@ -432,10 +432,10 @@ withNetworkLayerBase tr net np conn versionData tol action = do
         -> IO (TQueue IO
                 (LocalStateQueryCmd (CardanoBlock StandardCrypto) IO))
     connectDelegationRewardsClient handlers = do
-        cmdQ <- atomically newTQueue
-        let cl = mkDelegationRewardsClient tr cfg cmdQ
-        link =<< async (connectClient tr handlers cl versionData conn)
-        pure cmdQ
+        q <- atomically newTQueue
+        let client = mkDelegationRewardsClient tr cfg q
+        link =<< async (connectClient tr handlers client versionData conn)
+        pure q
 
     _initCursor :: HasCallStack => [W.BlockHeader] -> IO Cursor
     _initCursor headers = do
@@ -585,9 +585,16 @@ withNetworkLayerBase tr net np conn versionData tol action = do
                     Left _pastHorizon -> return NotResponding
                     Right p -> return p
 
---------------------------------------------------------------------------------
---
--- Network Client
+{-------------------------------------------------------------------------------
+    NetworkClient
+    Node-to-client mini-protocol descriptions
+-------------------------------------------------------------------------------}
+-- | A protocol client that will never leave the initial state.
+doNothingProtocol
+    :: MonadTimer m => RunMiniProtocol 'InitiatorMode ByteString m a Void
+doNothingProtocol =
+    InitiatorProtocolOnly $ MuxPeerRaw $
+    const $ forever $ threadDelay 1e6
 
 -- | Type representing a network client running two mini-protocols to sync
 -- from the chain and, submit transactions.
@@ -672,47 +679,6 @@ mkDelegationRewardsClient tr cfg queryRewardQ v =
     tr' = contramap (MsgLocalStateQuery DelegationRewardsClient) tr
     codec = cStateQueryCodec (serialisedCodecs v cfg)
 
-{-------------------------------------------------------------------------------
-                                     Codecs
--------------------------------------------------------------------------------}
-
-codecVersion
-    :: NodeToClientVersion
-    -> BlockNodeToClientVersion (CardanoBlock StandardCrypto)
-codecVersion version = verMap ! version
-    where verMap = supportedNodeToClientVersions (Proxy @(CardanoBlock StandardCrypto))
-
-codecConfig :: W.SlottingParameters -> CodecConfig (CardanoBlock c)
-codecConfig sp = CardanoCodecConfig
-    (byronCodecConfig sp)
-    ShelleyCodecConfig
-    ShelleyCodecConfig
-    ShelleyCodecConfig
-    ShelleyCodecConfig
-
-
--- | A group of codecs which will deserialise block data.
-codecs
-    :: MonadST m
-    => NodeToClientVersion
-    -> CodecConfig (CardanoBlock StandardCrypto)
-    -> ClientCodecs (CardanoBlock StandardCrypto) m
-codecs nodeToClientVersion cfg =
-    clientCodecs cfg (codecVersion nodeToClientVersion) nodeToClientVersion
-
--- | A group of codecs which won't deserialise block data. Often only the block
--- headers are needed. It's more efficient and easier not to deserialise.
-serialisedCodecs
-    :: MonadST m
-    => NodeToClientVersion
-    -> CodecConfig (CardanoBlock StandardCrypto)
-    -> DefaultCodecs (CardanoBlock StandardCrypto) m
-serialisedCodecs nodeToClientVersion cfg =
-    defaultCodecs cfg (codecVersion nodeToClientVersion) nodeToClientVersion
-
-{-------------------------------------------------------------------------------
-                                     Tip sync
--------------------------------------------------------------------------------}
 
 type CardanoInterpreter sc = Interpreter (CardanoEras sc)
 
@@ -827,48 +793,25 @@ mkTipSyncClient tr np onPParamsUpdate onInterpreterUpdate onEraUpdate = do
     return (client, snd <$> readTVar tipVar)
     -- FIXME: We can remove the era from the tip sync client now.
 
--- | Construct a network client with the given communication channel, for the
--- purpose of submitting transactions.
-connectCardanoApiClient
+mkLocalTxSubmissionClient
     :: Tracer IO NetworkLayerLog
-        -- ^ Base trace for underlying protocols
-    -> RetryHandlers
-    -> LocalNodeConnectInfo CardanoMode
-    -> TQueue IO
-        (LocalTxSubmissionCmd
+    -> TQueue IO (LocalTxSubmissionCmd
             (Cardano.TxInMode CardanoMode)
             (Cardano.TxValidationErrorInMode CardanoMode)
-            IO)
-        -- ^ Communication channel with the LocalTxSubmission client
-    -> IO ()
-connectCardanoApiClient tr handlers info localTxSubmissionQ =
-    recoveringNodeConnection tr handlers $
-        connectToLocalNode info proto
-  where
-    proto = LocalNodeClientProtocols
-            { localChainSyncClient = NoLocalChainSyncClient
-            , localTxSubmissionClient = Just client
-            , localStateQueryClient = Nothing
-            }
-    client = localTxSubmission localTxSubmissionQ
-    -- fixme: put back tracing of messages
-    -- tr' = contramap MsgTxSubmission tr
-
--- Reward Account Balances
-
--- | Monitors values for keys, and allows clients to @query@ them.
---
--- Designed to be used for observing reward balances, where we want to cache the
--- balances of /all/ the wallets' accounts on tip change, and allow wallet
--- workers to @query@ the cache later, often, and whenever they want.
---
--- NOTE: One could imagine replacing @query@ getter with a push-based approach.
-data Observer m key value = Observer
-    { startObserving :: key -> m ()
-    , stopObserving :: key -> m ()
-    , query :: key -> m (Maybe value)
+            IO )
+    -> LocalNodeClientProtocolsInMode CardanoMode
+mkLocalTxSubmissionClient _tr localTxSubmissionQ = LocalNodeClientProtocols
+    { localChainSyncClient = NoLocalChainSyncClient
+    , localTxSubmissionClient = Just $ localTxSubmission localTxSubmissionQ
+    , localStateQueryClient = Nothing
     }
+    -- FIXME: Put back logging for local Tx Submission.
+    -- tr' = contramap MsgTxSubmission tr
 
+{-------------------------------------------------------------------------------
+    Thread for observing
+    Reward Account Balance
+-------------------------------------------------------------------------------}
 newRewardBalanceFetcher
     :: Tracer IO NetworkLayerLog
     -- ^ Used to convert tips for logging
@@ -938,36 +881,18 @@ fetchRewardAccounts tr queryRewardQ accounts = do
         , [MsgAccountDelegationAndRewards deleg rewardAccounts]
         )
 
-data ObserverLog key value
-    = MsgWillFetch (Set key)
-    | MsgDidFetch (Map key value)
-    | MsgDidChange (Map key value)
-    | MsgAddedObserver key
-    | MsgRemovedObserver key
-    deriving (Eq, Show)
-
-instance (Ord key, Buildable key, Buildable value)
-    => ToText (ObserverLog key value) where
-    toText (MsgWillFetch keys) = mconcat
-        [ "Will fetch values for keys "
-        , fmt $ listF keys
-        ]
-    toText (MsgDidFetch m) = mconcat
-        [ "Did fetch values "
-        , fmt $ mapF m
-        ]
-    toText (MsgDidChange m) = mconcat
-        [ "New values: "
-        , fmt $ mapF m
-        ]
-    toText (MsgAddedObserver key) = mconcat
-        [ "Started observing values for key "
-        , pretty key
-        ]
-    toText (MsgRemovedObserver key) = mconcat
-        [ "Stopped observing values for key "
-        , pretty key
-        ]
+-- | Monitors values for keys, and allows clients to @query@ them.
+--
+-- Designed to be used for observing reward balances, where we want to cache the
+-- balances of /all/ the wallets' accounts on tip change, and allow wallet
+-- workers to @query@ the cache later, often, and whenever they want.
+--
+-- NOTE: One could imagine replacing @query@ getter with a push-based approach.
+data Observer m key value = Observer
+    { startObserving :: key -> m ()
+    , stopObserving :: key -> m ()
+    , query :: key -> m (Maybe value)
+    }
 
 -- | Given a way to fetch values for a set of keys, create:
 -- 1. An @Observer@ for consuming values
@@ -1029,48 +954,60 @@ newObserver tr fetch = do
                     traceWith tr $ MsgDidChange values
                 atomically $ writeTVar cacheVar values
 
--- | Return a function to run an action only if its single parameter has changed
--- since the previous time it was called.
-debounce :: (Eq a, MonadSTM m) => (a -> m ()) -> m (a -> m ())
-debounce action = do
-    mvar <- newTMVarIO Nothing
-    pure $ \cur -> do
-        prev <- atomically $ takeTMVar mvar
-        unless (Just cur == prev) $ action cur
-        atomically $ putTMVar mvar (Just cur)
+{-------------------------------------------------------------------------------
+    Codecs
+-------------------------------------------------------------------------------}
 
--- | Convenience function to trace around a local state query.
--- See 'addTimings'.
-bracketQuery
-    :: MonadUnliftIO m
-    => String
-    -> Tracer m NetworkLayerLog
-    -> m a
-    -> m a
-bracketQuery label tr = bracketTracer (contramap (MsgQuery label) tr)
+codecVersion
+    :: NodeToClientVersion
+    -> BlockNodeToClientVersion (CardanoBlock StandardCrypto)
+codecVersion version = verMap ! version
+    where verMap = supportedNodeToClientVersions (Proxy @(CardanoBlock StandardCrypto))
 
--- | A tracer transformer which processes 'MsgQuery' logs to make new
--- 'MsgQueryTime' logs, so that we can get logs like:
---
--- >>> Query getAccountBalance took 51.664463s
-traceQueryTimings :: Tracer IO NetworkLayerLog -> IO (Tracer IO NetworkLayerLog)
-traceQueryTimings tr = produceTimings msgQuery trDiffTime
-  where
-    trDiffTime = contramap (uncurry MsgQueryTime) tr
-    msgQuery = \case
-        MsgQuery l b -> Just (l, b)
-        _ -> Nothing
+codecConfig :: W.SlottingParameters -> CodecConfig (CardanoBlock c)
+codecConfig sp = CardanoCodecConfig
+    (byronCodecConfig sp)
+    ShelleyCodecConfig
+    ShelleyCodecConfig
+    ShelleyCodecConfig
+    ShelleyCodecConfig
 
--- | Consider a "slow query" to be something that takes 200ms or more.
-isSlowQuery :: String -> DiffTime -> Bool
-isSlowQuery _label = (>= 0.2)
+-- | A group of codecs which will deserialise block data.
+codecs
+    :: MonadST m
+    => NodeToClientVersion
+    -> CodecConfig (CardanoBlock StandardCrypto)
+    -> ClientCodecs (CardanoBlock StandardCrypto) m
+codecs nodeToClientVersion cfg =
+    clientCodecs cfg (codecVersion nodeToClientVersion) nodeToClientVersion
 
--- | A protocol client that will never leave the initial state.
-doNothingProtocol
-    :: MonadTimer m => RunMiniProtocol 'InitiatorMode ByteString m a Void
-doNothingProtocol =
-    InitiatorProtocolOnly $ MuxPeerRaw $
-    const $ forever $ threadDelay 1e6
+-- | A group of codecs which won't deserialise block data. Often only the block
+-- headers are needed. It's more efficient and easier not to deserialise.
+serialisedCodecs
+    :: MonadST m
+    => NodeToClientVersion
+    -> CodecConfig (CardanoBlock StandardCrypto)
+    -> DefaultCodecs (CardanoBlock StandardCrypto) m
+serialisedCodecs nodeToClientVersion cfg =
+    defaultCodecs cfg (codecVersion nodeToClientVersion) nodeToClientVersion
+
+{-------------------------------------------------------------------------------
+    I/O -- Connect to the cardano-node process.
+-------------------------------------------------------------------------------}
+-- | Construct a network client with the given protocols.
+--
+-- FIXME: This functions overlaps with 'connectClient'.
+-- However, it is more modern in that is uses 'Cardano.Api'.
+-- We may or may not want to switch 'Cardano.Api' in the future.
+connectCardanoApiClient
+    :: Tracer IO NetworkLayerLog
+        -- ^ Base trace for underlying protocols
+    -> RetryHandlers
+    -> LocalNodeConnectInfo CardanoMode
+    -> LocalNodeClientProtocolsInMode CardanoMode
+    -> IO ()
+connectCardanoApiClient tr handlers info =
+    recoveringNodeConnection tr handlers . connectToLocalNode info
 
 -- Connect a client to a network, see `mkWalletClient` to construct a network
 -- client interface.
@@ -1093,8 +1030,9 @@ connectClient tr handlers client vData conn = withIOManager $ \iocp -> do
             , nctHandshakeTracer = contramap MsgHandshakeTracer tr
             }
     let socket = localSnocket iocp (nodeSocketFile conn)
-    recoveringNodeConnection tr handlers $
-        connectTo socket tracers versions (nodeSocketFile conn)
+    flip withException (print @SomeException) $
+        recoveringNodeConnection tr handlers $
+            connectTo socket tracers versions (nodeSocketFile conn)
 
 recoveringNodeConnection
     :: Tracer IO NetworkLayerLog
@@ -1182,10 +1120,70 @@ handleMuxError tr onResourceVanished = pure . errorType >=> \case
         pure onResourceVanished
     MuxBlockedOnCompletionVar _ -> pure False -- TODO: Is this correct?
 
+{-------------------------------------------------------------------------------
+    Helper functions of the Control.* and STM variety
+-------------------------------------------------------------------------------}
+-- | Return a function to run an action only if its single parameter has changed
+-- since the previous time it was called.
+debounce :: (Eq a, MonadSTM m) => (a -> m ()) -> m (a -> m ())
+debounce action = do
+    mvar <- newTMVarIO Nothing
+    pure $ \cur -> do
+        prev <- atomically $ takeTMVar mvar
+        unless (Just cur == prev) $ action cur
+        atomically $ putTMVar mvar (Just cur)
+
+-- | Trigger an action initially, and when the value changes.
+--
+-- There's no guarantee that we will see every intermediate value.
+observeForever :: (MonadSTM m, Eq a) => STM m a -> (a -> m ()) -> m ()
+observeForever readVal action = go Nothing
+  where
+    go old = do
+        new <- atomically $ do
+            new <- readVal
+            guard (old /= Just new)
+            return new
+        action new
+        go (Just new)
+
+-- | Put if empty, replace if not empty.
+repsertTMVar :: TMVar IO a -> a -> STM IO ()
+repsertTMVar var x = do
+    e <- isEmptyTMVar var
+    unless e $ void $ takeTMVar var
+    putTMVar var x
+
 {-------------------------------------------------------------------------------
                                     Logging
 -------------------------------------------------------------------------------}
 
+-- | Convenience function to trace around a local state query.
+-- See 'addTimings'.
+bracketQuery
+    :: MonadUnliftIO m
+    => String
+    -> Tracer m NetworkLayerLog
+    -> m a
+    -> m a
+bracketQuery label tr = bracketTracer (contramap (MsgQuery label) tr)
+
+-- | A tracer transformer which processes 'MsgQuery' logs to make new
+-- 'MsgQueryTime' logs, so that we can get logs like:
+--
+-- >>> Query getAccountBalance took 51.664463s
+traceQueryTimings :: Tracer IO NetworkLayerLog -> IO (Tracer IO NetworkLayerLog)
+traceQueryTimings tr = produceTimings msgQuery trDiffTime
+  where
+    trDiffTime = contramap (uncurry MsgQueryTime) tr
+    msgQuery = \case
+        MsgQuery l b -> Just (l, b)
+        _ -> Nothing
+
+-- | Consider a "slow query" to be something that takes 200ms or more.
+isSlowQuery :: String -> DiffTime -> Bool
+isSlowQuery _label = (>= 0.2)
+
 data NetworkLayerLog where
     MsgCouldntConnect :: Int -> NetworkLayerLog
     MsgConnectionLost :: Maybe IOException -> NetworkLayerLog
@@ -1359,25 +1357,40 @@ instance HasSeverityAnnotation NetworkLayerLog where
         MsgObserverLog (MsgDidChange _)    -> Notice
         MsgObserverLog{}                   -> Debug
 
+data ObserverLog key value
+    = MsgWillFetch (Set key)
+    | MsgDidFetch (Map key value)
+    | MsgDidChange (Map key value)
+    | MsgAddedObserver key
+    | MsgRemovedObserver key
+    deriving (Eq, Show)
 
+instance (Ord key, Buildable key, Buildable value)
+    => ToText (ObserverLog key value) where
+    toText (MsgWillFetch keys) = mconcat
+        [ "Will fetch values for keys "
+        , fmt $ listF keys
+        ]
+    toText (MsgDidFetch m) = mconcat
+        [ "Did fetch values "
+        , fmt $ mapF m
+        ]
+    toText (MsgDidChange m) = mconcat
+        [ "New values: "
+        , fmt $ mapF m
+        ]
+    toText (MsgAddedObserver key) = mconcat
+        [ "Started observing values for key "
+        , pretty key
+        ]
+    toText (MsgRemovedObserver key) = mconcat
+        [ "Stopped observing values for key "
+        , pretty key
+        ]
 
--- | Trigger an action initially, and when the value changes.
---
--- There's no guarantee that we will see every intermediate value.
-observeForever :: (MonadSTM m, Eq a) => STM m a -> (a -> m ()) -> m ()
-observeForever readVal action = go Nothing
-  where
-    go old = do
-        new <- atomically $ do
-            new <- readVal
-            guard (old /= Just new)
-            return new
-        action new
-        go (Just new)
-
---
--- LSQ Helpers
---
+{-------------------------------------------------------------------------------
+    Local State Query Helpers
+-------------------------------------------------------------------------------}
 
 byronOrShelleyBased
     :: LSQ Byron.ByronBlock m a

From 925981bdd5ea919c6158db894bb42a9c65e3f7ba Mon Sep 17 00:00:00 2001
From: Johannes Lund <johannes.lund@iohk.io>
Date: Wed, 30 Jun 2021 12:40:23 +0200
Subject: [PATCH 02/10] Handle node disconnections for Local State Query

1. Ensure follow catches asyncronous exceptions from connectClient,
such that it can restart with a new connection and cursor.

2. Keep Local State Queries and to-be-submitted Txs queued until their
requests finish, not just when they start. If a query is interrupted by
the node being disconnected, it will block until a connection is
re-established, and then retry.
---
 lib/core/src/Cardano/Wallet/Network.hs        | 31 +++---
 .../src/Ouroboros/Network/Client/Wallet.hs    | 99 ++++++++++++-------
 .../src/Cardano/Wallet/Shelley/Network.hs     |  2 +-
 3 files changed, 85 insertions(+), 47 deletions(-)

diff --git a/lib/core/src/Cardano/Wallet/Network.hs b/lib/core/src/Cardano/Wallet/Network.hs
index 727c0c55bc7..fdd1478bddf 100644
--- a/lib/core/src/Cardano/Wallet/Network.hs
+++ b/lib/core/src/Cardano/Wallet/Network.hs
@@ -103,7 +103,7 @@ import UnliftIO.Async
 import UnliftIO.Concurrent
     ( threadDelay )
 import UnliftIO.Exception
-    ( SomeException, bracket, handle )
+    ( SomeException, bracket, handleSyncOrAsync )
 
 import qualified Cardano.Api.Shelley as Node
 import qualified Data.List.NonEmpty as NE
@@ -364,26 +364,33 @@ follow'
     -- ^ Getter on the abstract 'block' type
     -> IO FollowExit
 follow' nl tr cps yield header =
-    bracket (initCursor nl cps) (destroyCursor nl) (sleep 0 False)
+    bracket
+        (initCursor nl cps)
+        (destroyCursor nl)
+        (handleExceptions . sleep 0 False)
   where
     innerTr = contramap MsgFollowLog tr
     delay0 :: Int
     delay0 = 500*1000 -- 500ms
 
+    handleExceptions :: IO FollowExit -> IO FollowExit
+    handleExceptions =
+        -- Node disconnections are seen as async exceptions from here. By
+        -- catching them, `follow` will try to establish a new connection
+        -- depending on the `FollowExceptionRecovery`.
+        handleSyncOrAsync (traceException *> const (pure FollowFailure))
+      where
+        traceException :: SomeException -> IO ()
+        traceException e = do
+            traceWith tr $ MsgUnhandledException $ T.pack $ show e
+
     -- | Wait a short delay before querying for blocks again. We also take this
     -- opportunity to refresh the chain tip as it has probably increased in
     -- order to refine our syncing status.
     sleep :: Int -> Bool -> Cursor -> IO FollowExit
-    sleep delay hasRolledForward cursor = handle exitOnAnyException $ do
-        when (delay > 0) (threadDelay delay)
-        step hasRolledForward cursor
-      where
-        -- Any unhandled synchronous exception should be logged and cause the
-        -- chain follower to exit.
-        exitOnAnyException :: SomeException -> IO FollowExit
-        exitOnAnyException e = do
-            traceWith tr $ MsgUnhandledException $ T.pack $ show e
-            pure FollowFailure
+    sleep delay hasRolledForward cursor = do
+            when (delay > 0) (threadDelay delay)
+            step hasRolledForward cursor
 
     step :: Bool -> Cursor -> IO FollowExit
     step hasRolledForward cursor = nextBlocks nl cursor >>= \case
diff --git a/lib/core/src/Ouroboros/Network/Client/Wallet.hs b/lib/core/src/Ouroboros/Network/Client/Wallet.hs
index 781da97b0a1..c5dda12a60b 100644
--- a/lib/core/src/Ouroboros/Network/Client/Wallet.hs
+++ b/lib/core/src/Ouroboros/Network/Client/Wallet.hs
@@ -61,6 +61,7 @@ import Control.Monad.Class.MonadSTM
     , atomically
     , isEmptyTQueue
     , newEmptyTMVarIO
+    , peekTQueue
     , putTMVar
     , readTQueue
     , takeTMVar
@@ -443,7 +444,7 @@ chainSyncWithBlocks tr fromTip queue responseBuffer =
 --
 -- LocalStateQuery
 
----- | Command to send to the localStateQuery client. See also 'ChainSyncCmd'.
+-- | Type of commands that are stored in a queue for local state queries.
 data LocalStateQueryCmd block m = forall a. SomeLSQ
     (LSQ block m a)
     (a -> m ())
@@ -504,12 +505,28 @@ localStateQuery queue =
     clientStAcquired
         :: LocalStateQueryCmd block m
         -> m (LSQ.ClientStAcquired block (Point block) (Query block) m Void)
-    clientStAcquired (SomeLSQ cmd respond) = pure $ go cmd $ \res -> do
-        LSQ.SendMsgRelease (respond res >> clientStIdle)
-            -- We /could/ read all LocalStateQueryCmds from the TQueue, and run
-            -- them against the same tip, if re-acquiring takes a long time. As
-            -- of Jan 2021, it seems like queries themselves take significantly
-            -- longer than the acquiring.
+    clientStAcquired (SomeLSQ cmd respond) = pure $ go cmd $ \res ->
+        -- We currently release the handle to the node state after
+        -- each query in the queue. This allows the node to release
+        -- resources (such as a stake distribution snapshot) after
+        -- each query.
+        -- 
+        -- However, we /could/ read all LocalStateQueryCmds from the TQueue,
+        -- and run them against the same tip, if re-acquiring takes a long time.
+        -- As of Jan 2021, it seems like queries themselves take significantly
+        -- longer than the acquiring.
+        LSQ.SendMsgRelease $ do
+            -- In order to remove the query from the queue as soon as possible,
+            -- @respond@ should return quickly and not throw any synchronous
+            -- exception.
+            -- In practice, we only use the 'send' helper here, so that works.
+            --
+            -- (Asynchronous exceptions are fine, as the connection to the node
+            -- will not attempt to recover from that, and it doesn't matter
+            -- whether a command is left in the queue or not.)
+            respond res
+            finalizeCmd
+            clientStIdle
       where
           go
               :: forall a. LSQ block m a
@@ -517,18 +534,34 @@ localStateQuery queue =
               -> (LSQ.ClientStAcquired block (Point block) (Query block) m Void)
           go (LSQPure a) cont = cont a
           go (LSQry qry) cont = LSQ.SendMsgQuery (BlockQuery qry)
-            -- NOTE: We only need to support queries of the type `BlockQuery`
-            -- type.
+            -- We only need to support queries of the type `BlockQuery`.
             $ LSQ.ClientStQuerying $ \res -> do
                   pure $ cont res
                   -- It would be nice to trace the time it takes to run the
                   -- queries. We don't have a good opportunity to run IO after a
                   -- point is acquired, but before the query is send, however.
+                  -- Heinrich: Actually, this can be done by adding a 'Tracer m'
+                  -- to the scope and using it here. However, I believe that we
+                  -- already have sufficiently good logging of execution times
+                  -- in Cardano.Wallet.Shelley.Network .
           go (LSQBind ma f) cont = go ma $ \a -> do
               go (f a) $ \b -> cont b
 
+    -- | Note that we for LSQ and TxSubmission use peekTQueue when starting the
+    -- request, and only remove the command from the queue after we have
+    -- processed the response from the node.
+    --
+    -- If the connection to the node drops, this makes cancelled commands
+    -- automatically retry on reconnection.
+    --
+    -- IMPORTANT: callers must also `finalizeCmd`, because of the above.
     awaitNextCmd :: m (LocalStateQueryCmd block m)
-    awaitNextCmd = atomically $ readTQueue queue
+    awaitNextCmd = atomically $ peekTQueue queue
+
+    finalizeCmd :: m ()
+    finalizeCmd = atomically $ tryReadTQueue queue >>= \case
+        Just _ -> return ()
+        Nothing -> error "finalizeCmd: queue is not empty"
 
 -- | Monad for composing local state queries for the node /tip/.
 --
@@ -557,7 +590,7 @@ instance Monad (LSQ block m) where
 -- LocalTxSubmission
 
 
--- | Sending command to the localTxSubmission client. See also 'ChainSyncCmd'.
+-- | Type of commands that are stored in a queue for localTxSubmission.
 data LocalTxSubmissionCmd tx err (m :: Type -> Type)
     = CmdSubmitTx tx (SubmitResult err -> m ())
 
@@ -591,31 +624,29 @@ localTxSubmission
 localTxSubmission queue = LocalTxSubmissionClient clientStIdle
   where
     clientStIdle
-        :: m (LocalTxClientStIdle tx err m ())
-    clientStIdle = atomically (readTQueue queue) <&> \case
+        :: m (LocalTxClientStIdle tx err m Void)
+    clientStIdle = atomically (peekTQueue queue) <&> \case
         CmdSubmitTx tx respond ->
-            SendMsgSubmitTx tx (\e -> respond e >> clientStIdle)
-
---------------------------------------------------------------------------------
---
--- Helpers
-
-flush :: (MonadSTM m) => TQueue m a -> m ()
-flush queue =
-    atomically $ dropUntil isNothing queue
-  where
-    dropUntil predicate q = do
-        done <- predicate <$> tryReadTQueue q
-        unless done $ dropUntil predicate q
-
--- | Helper function to easily send commands to the node's client and read
--- responses back.
---
--- >>> queue `send` CmdNextBlocks
--- RollForward cursor nodeTip blocks
+            SendMsgSubmitTx tx $ \res -> do
+                respond res
+                -- Same note about peekTQueue from `localStateQuery` applies
+                -- here.
+                _processedCmd <- atomically (readTQueue queue)
+                clientStIdle
+
+{-------------------------------------------------------------------------------
+    Helpers
+-------------------------------------------------------------------------------}
+
+-- | Helper function to send commands to the node via a 'TQueue'
+-- and receive results.
 --
--- >>> queue `send` CmdNextBlocks
--- AwaitReply
+-- One of the main purposes of this functions is to handle an existentially
+-- quantified type.
+-- In typical use, the @cmd m@ involves existential quantification over
+-- the type @a@, so that the 'TQueue' has elements with a monomorphic type.
+-- However, the type signature of `send` allows us to retrive this particular
+-- type @a@ for later use again.
 send
     :: MonadSTM m
     => TQueue m (cmd m)
diff --git a/lib/shelley/src/Cardano/Wallet/Shelley/Network.hs b/lib/shelley/src/Cardano/Wallet/Shelley/Network.hs
index 9f3815c90c0..6f1b4fbe72c 100644
--- a/lib/shelley/src/Cardano/Wallet/Shelley/Network.hs
+++ b/lib/shelley/src/Cardano/Wallet/Shelley/Network.hs
@@ -490,7 +490,7 @@ withNetworkLayerBase tr net np conn versionData tol action = do
                 stakeDistr
 
         mres <- bracketQuery "stakePoolsSummary" tr $
-            queue `send` (SomeLSQ qry )
+            queue `send` (SomeLSQ qry)
 
         -- The result will be Nothing if query occurs during the byron era
         traceWith tr $ MsgFetchStakePoolsData mres

From 7fa865ae83b6462106d94affab25c05c188f435f Mon Sep 17 00:00:00 2001
From: Johannes Lund <johannes.lund@iohk.io>
Date: Thu, 1 Jul 2021 16:29:10 +0200
Subject: [PATCH 03/10] Refactor ChainSync protocol

New type `ChainFollower` provides callbacks that are used to drive and respond to the node-to-client messages.
---
 lib/core/src/Cardano/Wallet.hs                |  35 +-
 lib/core/src/Cardano/Wallet/Api.hs            |   2 +-
 lib/core/src/Cardano/Wallet/DB.hs             |   4 +
 lib/core/src/Cardano/Wallet/Network.hs        | 435 +++++++-----------
 .../src/Ouroboros/Network/Client/Wallet.hs    | 328 ++++++-------
 .../Wallet/DummyTarget/Primitive/Types.hs     |   5 +-
 .../src/Cardano/Wallet/Shelley/Network.hs     | 154 +++----
 .../src/Cardano/Wallet/Shelley/Pools.hs       |  24 +-
 8 files changed, 399 insertions(+), 588 deletions(-)

diff --git a/lib/core/src/Cardano/Wallet.hs b/lib/core/src/Cardano/Wallet.hs
index dba914f1705..2309c762ce9 100644
--- a/lib/core/src/Cardano/Wallet.hs
+++ b/lib/core/src/Cardano/Wallet.hs
@@ -231,13 +231,7 @@ import Cardano.Wallet.Logging
     , unliftIOTracer
     )
 import Cardano.Wallet.Network
-    ( ErrPostTx (..)
-    , FollowAction (..)
-    , FollowExceptionRecovery (..)
-    , FollowLog (..)
-    , NetworkLayer (..)
-    , follow
-    )
+    ( ChainFollower (..), ErrPostTx (..), FollowLog (..), NetworkLayer (..) )
 import Cardano.Wallet.Primitive.AddressDerivation
     ( DelegationAddress (..)
     , Depth (..)
@@ -532,7 +526,7 @@ import Statistics.Quantile
 import Type.Reflection
     ( Typeable, typeRep )
 import UnliftIO.Exception
-    ( Exception )
+    ( Exception, throwIO )
 import UnliftIO.MVar
     ( modifyMVar_, newMVar )
 
@@ -896,18 +890,25 @@ restoreWallet
     -> WalletId
     -> ExceptT ErrNoSuchWallet IO ()
 restoreWallet ctx wid = db & \DBLayer{..} -> do
-    let readCps = liftIO $ atomically $ listCheckpoints wid
-    let forward bs h innerTr = run $ do
-            restoreBlocks @ctx @s @k ctx innerTr wid bs h
-    let backward = runExceptT . rollbackBlocks @ctx @s @k ctx wid
-    liftIO $ follow nw tr readCps forward backward RetryOnExceptions (view #header)
+    liftIO $ chainSync nw tr' $ ChainFollower
+        { readLocalTip =
+            liftIO $ atomically $ listCheckpoints wid
+        , rollForward = \tip blocks -> throwInIO $
+            restoreBlocks @ctx @s @k
+                ctx (contramap MsgFollowLog tr') wid blocks tip
+        , rollBackward =
+            throwInIO . rollbackBlocks @ctx @s @k ctx wid
+        }
+    --liftIO $ follow nw tr readCps forward backward RetryOnExceptions (view #header)
   where
     db = ctx ^. dbLayer @IO @s @k
-    nw = ctx ^. networkLayer
-    tr = contramap MsgFollow (ctx ^. logger @_ @WalletWorkerLog)
+    nw = ctx ^. networkLayer @IO
+    tr' = contramap MsgFollow (ctx ^. logger @WalletWorkerLog)
 
-    run :: ExceptT ErrNoSuchWallet IO () -> IO (FollowAction ErrNoSuchWallet)
-    run = fmap (either ExitWith (const Continue)) . runExceptT
+    throwInIO :: ExceptT ErrNoSuchWallet IO a -> IO a
+    throwInIO x = runExceptT x >>= \case
+        Right a -> pure a
+        Left e -> throwIO e
 
 -- | 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.
diff --git a/lib/core/src/Cardano/Wallet/Api.hs b/lib/core/src/Cardano/Wallet/Api.hs
index c6a0f1f6c1e..84de5130a25 100644
--- a/lib/core/src/Cardano/Wallet/Api.hs
+++ b/lib/core/src/Cardano/Wallet/Api.hs
@@ -1084,7 +1084,7 @@ data ApiLayer s (k :: Depth -> Type -> Type)
         (Tracer IO TxSubmitLog)
         (Tracer IO (WorkerLog WalletId WalletWorkerLog))
         (Block, NetworkParameters, SyncTolerance)
-        (NetworkLayer IO (Block))
+        (NetworkLayer IO Block)
         (TransactionLayer k SealedTx)
         (DBFactory IO s k)
         (WorkerRegistry WalletId (DBLayer IO s k))
diff --git a/lib/core/src/Cardano/Wallet/DB.hs b/lib/core/src/Cardano/Wallet/DB.hs
index 0663d73f45a..88a87e7da3d 100644
--- a/lib/core/src/Cardano/Wallet/DB.hs
+++ b/lib/core/src/Cardano/Wallet/DB.hs
@@ -63,6 +63,8 @@ import Cardano.Wallet.Primitive.Types.Tx
     , TxMeta
     , TxStatus
     )
+import Control.Exception
+    ( Exception )
 import Control.Monad.IO.Class
     ( MonadIO )
 import Control.Monad.Trans.Except
@@ -329,6 +331,8 @@ newtype ErrNoSuchWallet
     = ErrNoSuchWallet WalletId -- Wallet is gone or doesn't exist yet
     deriving (Eq, Show)
 
+instance Exception ErrNoSuchWallet
+
 -- | Can't add a transaction to the local tx submission pool.
 data ErrPutLocalTxSubmission
     = ErrPutLocalTxSubmissionNoSuchWallet ErrNoSuchWallet
diff --git a/lib/core/src/Cardano/Wallet/Network.hs b/lib/core/src/Cardano/Wallet/Network.hs
index fdd1478bddf..4f202f7ae87 100644
--- a/lib/core/src/Cardano/Wallet/Network.hs
+++ b/lib/core/src/Cardano/Wallet/Network.hs
@@ -18,19 +18,18 @@ module Cardano.Wallet.Network
     (
     -- * Interface
       NetworkLayer (..)
-    , NextBlocksResult (..)
-    , mapCursor
-    , Cursor
-    , follow
-    , FollowAction (..)
-    , FollowExit (..)
-    , FollowExceptionRecovery (..)
 
     -- * Errors
     , ErrPostTx (..)
 
-    -- * Logging
+    -- * Chain following
+    , ChainFollower (..)
+    , mapChainFollower
     , FollowLog (..)
+    , ChainSyncLog (..)
+    , mapChainSyncLog
+    , withFollowStatsMonitoring
+    , addFollowerLogging
 
     -- * Logging (for testing)
     , FollowStats (..)
@@ -46,7 +45,7 @@ import Cardano.Api
 import Cardano.BM.Data.Severity
     ( Severity (..) )
 import Cardano.BM.Data.Tracer
-    ( HasPrivacyAnnotation (..), HasSeverityAnnotation (..), contramap )
+    ( HasPrivacyAnnotation (..), HasSeverityAnnotation (..) )
 import Cardano.Wallet.Primitive.Slotting
     ( PastHorizonException, TimeInterpreter )
 import Cardano.Wallet.Primitive.SyncProgress
@@ -64,8 +63,6 @@ import Cardano.Wallet.Primitive.Types.RewardAccount
     ( RewardAccount (..) )
 import Cardano.Wallet.Primitive.Types.Tx
     ( SealedTx )
-import Control.Monad
-    ( when )
 import Control.Monad.Class.MonadSTM
     ( atomically )
 import Control.Monad.Class.MonadSTM.Strict
@@ -74,8 +71,6 @@ import Control.Monad.Trans.Except
     ( ExceptT (..) )
 import Control.Tracer
     ( Tracer, contramapM, traceWith )
-import Data.Functor
-    ( ($>) )
 import Data.List.NonEmpty
     ( NonEmpty (..) )
 import Data.Map
@@ -96,47 +91,31 @@ import GHC.Generics
     ( Generic )
 import NoThunks.Class
     ( AllowThunksIn (..), NoThunks (..) )
+import Numeric.Natural
+    ( Natural )
 import Safe
     ( lastMay )
 import UnliftIO.Async
     ( race_ )
 import UnliftIO.Concurrent
     ( threadDelay )
-import UnliftIO.Exception
-    ( SomeException, bracket, handleSyncOrAsync )
 
 import qualified Cardano.Api.Shelley as Node
 import qualified Data.List.NonEmpty as NE
 import qualified Data.Text as T
 
+{-------------------------------------------------------------------------------
+    ChainSync
+-------------------------------------------------------------------------------}
+-- | Interface for network capabilities.
 data NetworkLayer m block = NetworkLayer
-    { nextBlocks
-        :: Cursor
-        -> IO (NextBlocksResult Cursor block)
-        -- ^ Starting from the given 'Cursor', fetches a contiguous sequence of
-        -- blocks from the node, if they are available. An updated cursor will
-        -- be returned with a 'RollFoward' result.
-        --
-        -- Blocks are returned in ascending slot order, without skipping blocks.
-        --
-        -- If the node does not have any blocks after the specified cursor
-        -- point, it will return 'AwaitReply'.
-        --
-        -- If the node has adopted an alternate fork of the chain, it will
-        -- return 'RollBackward' with a new cursor.
-
-    , initCursor
-        :: [BlockHeader] -> m Cursor
-        -- ^ Creates a cursor from the given block header so that 'nextBlocks'
-        -- can be used to fetch blocks.
-
-    , destroyCursor
-        :: Cursor -> m ()
-        -- ^ Cleanup network connection once we're done with them.
-
-    , cursorSlotNo
-        :: Cursor -> SlotNo
-        -- ^ Get the slot corresponding to a cursor.
+    { chainSync
+        :: forall msg. Tracer IO (FollowLog msg)
+        -> ChainFollower m
+            BlockHeader
+            BlockHeader
+            block
+        -> m ()
 
     , currentNodeTip
         :: m BlockHeader
@@ -199,11 +178,81 @@ data NetworkLayer m block = NetworkLayer
 
 instance Functor m => Functor (NetworkLayer m) where
     fmap f nl = nl
-        { nextBlocks = fmap (fmap f) . nextBlocks nl
+        { chainSync = \tr follower ->
+            chainSync nl tr (mapChainFollower id id id f follower)
         }
 
+-- | A collection of callbacks to use with the 'chainSync' function.
+data ChainFollower m point tip block = ChainFollower
+    { readLocalTip :: m [point]
+        -- ^ Callback for reading the local tip. Used to negotiate the
+        -- intersection with the node.
+        --
+        -- A response of [] is interpreted as `Origin` -- i.e. the chain will be
+        -- served from genesis.
+        --
+        -- TODO: Could be named readCheckpoints?
+    , rollForward :: tip -> NonEmpty block -> m ()
+        -- ^ Callback for rolling forward.
+        --
+        -- Implementors _may_ delete old checkpoints while rolling forward.
+
+    , rollBackward :: SlotNo -> m SlotNo
+        -- ^ Roll back to the requested slot, or further, and return the point
+        -- actually rolled back to.
+        --
+        -- TODO: `SlotNo` cannot represent the genesis point `Origin`.
+        --
+        -- __Example 1:__
+        --
+        -- If the follower stores checkpoints for all blocks, we can always roll
+        -- back to the requested point exactly.
+        --
+        -- @
+        -- -- If
+        -- knownSlots follower `shouldReturn` [0,1,2,3]
+        -- let requested = SlotNo 2
+        -- -- Then
+        -- actual <- rollBackward follower requested
+        -- knownSlots follower shouldReturn` [0,1,2]
+        -- actual `shouldBe` SlotNo 2
+        -- @
+        --
+        -- Note that the slotNos are unlikely to be consecutive in real life,
+        -- but this doesn't matter, as ouroboros-network asks us to rollback to
+        -- points, corresponding to blocks.
+        --
+        -- __Example 2:__
+        --
+        -- @
+        -- -- If
+        -- knownSlots follower `shouldReturn` [0,9,10]
+        -- let requested = SlotNo 2
+        -- -- Then
+        -- actual <- rollBackward follower requested
+        -- knownSlots follower shouldReturn` [0]
+        -- actual `shouldBe` SlotNo 0
+        -- @
+        --
+    }
+
+mapChainFollower
+    :: Functor m
+    => (point1 -> point2) -- ^ Covariant
+    -> (tip2 -> tip1) -- ^ Contravariant
+    -> (block2 -> block1) -- ^ Contravariant
+    -> ChainFollower m point1 tip1 block1
+    -> ChainFollower m point2 tip2 block2
+mapChainFollower fpoint ftip fblock cf =
+    ChainFollower
+        { readLocalTip = map fpoint <$> readLocalTip cf
+        , rollForward = \t bs -> rollForward cf (ftip t) (fmap fblock bs)
+        , rollBackward = rollBackward cf
+        }
+
+
 {-------------------------------------------------------------------------------
-                                  Errors
+    Errors
 -------------------------------------------------------------------------------}
 
 -- | Error while trying to send a transaction
@@ -215,245 +264,53 @@ instance ToText ErrPostTx where
         ErrPostTxValidationError msg -> msg
 
 {-------------------------------------------------------------------------------
-                                Chain Sync
+    Logging
 -------------------------------------------------------------------------------}
 
---- | A cursor is local state kept by the chain consumer to use as the starting
---- position for 'nextBlocks'. The actual type is opaque and determined by the
---- backend target.
-data family Cursor
-
--- | The result of 'nextBlocks', which is instructions for what the chain
--- consumer should do next.
-data NextBlocksResult cursor block
-    = RollForward cursor BlockHeader [block]
-        -- ^ Apply the given contiguous non-empty sequence of blocks. Use the
-        -- updated cursor to get the next batch. The given block header is the
-        -- current tip of the node.
-    | RollBackward cursor
-        -- ^ The chain consumer must roll back its state, then use the cursor to
-        -- get the next batch of blocks.
-
-instance Functor (NextBlocksResult cursor) where
-    fmap f = \case
-        RollForward cur bh bs -> RollForward cur bh (fmap f bs)
-        RollBackward cur -> RollBackward cur
-
-mapCursor :: (a -> b) -> NextBlocksResult a block -> NextBlocksResult b block
-mapCursor fn = \case
-    RollForward cur bh bs -> RollForward (fn cur) bh bs
-    RollBackward cur -> RollBackward (fn cur)
-
--- | @FollowAction@ enables the callback of @follow@ to signal if the
--- chain-following should @ExitWith@, @Continue@, or if the current callback
--- should be forgotten and retried (@Retry@).
-data FollowAction err
-    = ExitWith err
-      -- ^ Stop following the chain.
-    | Continue
-      -- ^ Continue following the chain.
-    deriving (Eq, Show, Functor)
-
--- | Possibly scenarios that would cause 'follow' to exit so that client code
--- can decide what to do.
-data FollowExit
-    = FollowRollback SlotNo
-    | FollowFailure
-    | FollowDone
-    deriving (Eq, Show)
-
-data FollowExceptionRecovery
-    = RetryOnExceptions
-    | AbortOnExceptions
-
--- | Subscribe to a blockchain and get called with new block (in order)!
---
--- Exits when the node switches to a different chain with the greatest known
--- common tip between the follower and the node. This makes it easier for client
--- to re-start following from a different point if they have, for instance,
--- rolled back to a point further in the past. If this occurs, clients will need
--- to restart the chain follower from a known list of headers, re-initializing
--- the cursor.
---
--- Exits with 'Nothing' in case of error.
-follow
-    :: forall block msg e. (Show e)
-    => NetworkLayer IO block
-    -- ^ The @NetworkLayer@ used to poll for new blocks.
-    -> Tracer IO (FollowLog msg)
-    -- ^ Logger trace
-    -> IO [BlockHeader]
-    -- ^ A way to get a list of known tips to start from.
-    -- Blocks /after/ the tip will be yielded.
-    -> (NE.NonEmpty block
-        -> BlockHeader
-        -> Tracer IO msg
-        -> IO (FollowAction e))
-    -- ^ Callback with blocks and the current tip of the /node/.
-    -- @follow@ stops polling and terminates if the callback errors.
-    -> (SlotNo -> IO (Either e SlotNo))
-    -- ^ Callback with blocks and the current tip of the /node/.
-    -- @follow@ stops polling and terminates if the callback errors.
-    -> FollowExceptionRecovery
-    -- ^ Whether to recover from exceptions or not.
-    -> (block -> BlockHeader)
-    -- ^ Getter on the abstract 'block' type
-    -> IO ()
-follow nl tr' readCursor forward' backward recovery header =
-    withFollowStatsMonitoring tr' (syncProgress nl) $ \tr -> do
-        loop tr True
-  where
-    loop tr firstTime = do
-        cursor <- readCursor
-        when firstTime $ traceWith tr $ MsgStartFollowing cursor
 
-        -- Trace the sync progress based on the last "local checkpoint".
-        --
-        -- It appears that @forward@ doesn't get called if we are already
-        -- in-sync. So if we want the @LogState@ to update, we need to trace
-        -- something here.
-        case lastMay cursor of
-            Just c -> traceWith tr . MsgFollowerTip $ Just c
-            Nothing -> traceWith tr . MsgFollowerTip $ Nothing
-
-        let forward blocks tip innerTr = do
-                res <- forward' blocks tip innerTr
-                traceWith tr . MsgFollowerTip . Just $ header $ NE.last blocks
-                return res
-
-        (follow' nl tr cursor forward header) >>= \act -> do
-            case act of
-                FollowFailure ->
-                    -- NOTE: follow' is tracing the error, so we don't have to
-                    -- here
-                    case recovery of
-                        RetryOnExceptions -> loop tr False
-                        AbortOnExceptions -> return ()
-                FollowRollback requestedSlot -> do
-                    -- NOTE: follow' is tracing MsgWillRollback
-                    backward requestedSlot >>= \case
-                        Left e -> do
-                            traceWith tr $ MsgFailedRollingBack $ T.pack (show e)
-                        Right actualSlot -> do
-                            traceWith tr $ MsgDidRollback requestedSlot actualSlot
-                    loop tr False
-                FollowDone ->
-                    -- TODO: Pool used to log MsgHaltMonitoring
-                    return ()
-
--- | A new, more convenient, wrapping @follow@ function was added above.
---
--- This is the old one. It was kept for now to minimise changes and potential
--- mistakes, as it is pretty intricate.
-follow'
-    :: forall block msg e. (Show e)
-    => NetworkLayer IO block
-    -- ^ The @NetworkLayer@ used to poll for new blocks.
-    -> Tracer IO (FollowLog msg)
-    -- ^ Logger trace
-    -> [BlockHeader]
-    -- ^ A list of known tips to start from.
-    -- Blocks /after/ the tip will be yielded.
-    -> (NE.NonEmpty block
-        -> BlockHeader
-        -> Tracer IO msg
-        -> IO (FollowAction e))
-    -- ^ Callback with blocks and the current tip of the /node/.
-    -- @follow@ stops polling and terminates if the callback errors.
-    -> (block -> BlockHeader)
-    -- ^ Getter on the abstract 'block' type
-    -> IO FollowExit
-follow' nl tr cps yield header =
-    bracket
-        (initCursor nl cps)
-        (destroyCursor nl)
-        (handleExceptions . sleep 0 False)
-  where
-    innerTr = contramap MsgFollowLog tr
-    delay0 :: Int
-    delay0 = 500*1000 -- 500ms
-
-    handleExceptions :: IO FollowExit -> IO FollowExit
-    handleExceptions =
-        -- Node disconnections are seen as async exceptions from here. By
-        -- catching them, `follow` will try to establish a new connection
-        -- depending on the `FollowExceptionRecovery`.
-        handleSyncOrAsync (traceException *> const (pure FollowFailure))
-      where
-        traceException :: SomeException -> IO ()
-        traceException e = do
-            traceWith tr $ MsgUnhandledException $ T.pack $ show e
-
-    -- | Wait a short delay before querying for blocks again. We also take this
-    -- opportunity to refresh the chain tip as it has probably increased in
-    -- order to refine our syncing status.
-    sleep :: Int -> Bool -> Cursor -> IO FollowExit
-    sleep delay hasRolledForward cursor = do
-            when (delay > 0) (threadDelay delay)
-            step hasRolledForward cursor
-
-    step :: Bool -> Cursor -> IO FollowExit
-    step hasRolledForward cursor = nextBlocks nl cursor >>= \case
-        RollForward cursor' _ [] -> do
-            -- FIXME Make RollForward return NE
-            -- This case seems to never happen.
-            sleep delay0 hasRolledForward cursor'
-
-        RollForward cursor' tip (blockFirst : blocksRest) -> do
-            let blocks = blockFirst :| blocksRest
-            traceWith tr $ MsgApplyBlocks tip (header <$> blocks)
-            action <- yield blocks tip innerTr
-            traceWith tr $ MsgFollowAction (fmap show action)
-            continueWith cursor' True action
-
-        RollBackward cursor' ->
-            -- After negotiating a tip, the node asks us to rollback to the
-            -- intersection. We may have to rollback to our /current/ tip.
-            --
-            -- This would do nothing, but @follow@ handles rollback by exiting
-            -- such that a new negotiation is required, leading to an infinite
-            -- loop.
-            --
-            -- So this becomes a bit intricate:
-
-            case (cursorSlotNo nl cursor', cps, hasRolledForward) of
-                (sl, [], False) -> do
-                    -- The following started from @Origin@.
-                    -- This is the initial rollback.
-                    -- We can infer that we are asked to rollback to Origin, and
-                    -- we can ignore it.
-                    traceWith tr $ MsgWillIgnoreRollback sl "initial rollback, \
-                        \cps=[]"
-                    step hasRolledForward cursor'
-                (sl, _:_, False) | sl == slotNo (last cps) -> do
-                    traceWith tr $ MsgWillIgnoreRollback sl "initial rollback, \
-                        \rollback point equals the last checkpoint"
-                    step hasRolledForward cursor'
-                (sl, _, _) -> do
-                    traceWith tr $ MsgWillRollback sl
-                    destroyCursor nl cursor' $> FollowRollback sl
-            -- Some alternative solutions would be to:
-            -- 1. Make sure we have a @BlockHeader@/@SlotNo@ for @Origin@
-            -- 2. Stop forcing @follow@ to quit on rollback
-    continueWith
-        :: Cursor
-        -> Bool
-        -> FollowAction e
-        -> IO FollowExit
-    continueWith cursor' hrf = \case
-        ExitWith _ -> -- NOTE error logged as part of `MsgFollowAction`
-            return FollowDone
-        Continue ->
-            step hrf cursor'
+-- | Low-level logs for chain-sync
+data ChainSyncLog block point
+    = MsgChainRollForward block point
+    | MsgChainRollBackward point Int
+    | MsgTipDistance Natural
+    deriving (Show, Eq, Generic)
 
-{-------------------------------------------------------------------------------
-                                    Logging
--------------------------------------------------------------------------------}
+mapChainSyncLog
+    :: (b1 -> b2)
+    -> (p1 -> p2)
+    -> ChainSyncLog b1 p1
+    -> ChainSyncLog b2 p2
+mapChainSyncLog f g = \case
+    MsgChainRollForward block point -> MsgChainRollForward (f block) (g point)
+    MsgChainRollBackward point n -> MsgChainRollBackward (g point) n
+    MsgTipDistance d -> MsgTipDistance d
+
+instance (ToText block, ToText point)
+    => ToText (ChainSyncLog block point) where
+    toText = \case
+        MsgChainRollForward b tip ->
+            "ChainSync roll forward: " <> toText b <> " tip is " <> toText tip
+        MsgChainRollBackward b 0 ->
+            "ChainSync roll backward: " <> toText b
+        MsgChainRollBackward b bufferSize -> mconcat
+            [ "ChainSync roll backward: "
+            , toText b
+            , ", handled inside buffer with remaining length "
+            , toText bufferSize
+            ]
+        MsgTipDistance d -> "Tip distance: " <> toText d
+
+instance HasPrivacyAnnotation (ChainSyncLog block point)
+
+instance HasSeverityAnnotation (ChainSyncLog block point) where
+    getSeverityAnnotation = \case
+        MsgChainRollForward{} -> Debug
+        MsgChainRollBackward{} -> Debug
+        MsgTipDistance{} -> Debug
 
 data FollowLog msg
     = MsgStartFollowing [BlockHeader]
     | MsgHaltMonitoring
-    | MsgFollowAction (FollowAction String)
     | MsgUnhandledException Text
     | MsgFollowerTip (Maybe BlockHeader)
     | MsgFollowStats (FollowStats LogState)
@@ -463,6 +320,7 @@ data FollowLog msg
     | MsgDidRollback SlotNo SlotNo
     | MsgFailedRollingBack Text -- Reason
     | MsgWillIgnoreRollback SlotNo Text -- Reason
+    | MsgChainSync (ChainSyncLog Text Text)
     deriving (Show, Eq, Generic)
 
 instance ToText msg => ToText (FollowLog msg) where
@@ -475,9 +333,6 @@ instance ToText msg => ToText (FollowLog msg) where
             ]
         MsgHaltMonitoring ->
             "Stopping following as requested."
-        MsgFollowAction action -> case action of
-            ExitWith e -> "Failed to roll forward: " <> T.pack e
-            _ -> T.pack $ "Follower says " <> show action
         MsgUnhandledException err ->
             "Unexpected error following the chain: " <> err
         MsgFollowerTip p -> "Tip" <> pretty p
@@ -506,6 +361,7 @@ instance ToText msg => ToText (FollowLog msg) where
         MsgFailedRollingBack reason -> "Failed rolling back: " <>
             reason
         MsgFollowLog msg -> toText msg
+        MsgChainSync msg -> toText msg
 
 instance HasPrivacyAnnotation (FollowLog msg)
 instance HasSeverityAnnotation msg => HasSeverityAnnotation (FollowLog msg) where
@@ -514,8 +370,6 @@ instance HasSeverityAnnotation msg => HasSeverityAnnotation (FollowLog msg) wher
         MsgHaltMonitoring -> Info
         MsgFollowStats s -> getSeverityAnnotation s
         MsgFollowerTip _ -> Debug
-        MsgFollowAction (ExitWith _) -> Error
-        MsgFollowAction _ -> Debug
         MsgUnhandledException _ -> Error
         MsgApplyBlocks _ _ -> Debug
         MsgFollowLog msg -> getSeverityAnnotation msg
@@ -523,6 +377,8 @@ instance HasSeverityAnnotation msg => HasSeverityAnnotation (FollowLog msg) wher
         MsgDidRollback _ _ -> Debug
         MsgFailedRollingBack _ -> Error
         MsgWillIgnoreRollback _ _ -> Debug
+        MsgChainSync msg -> getSeverityAnnotation msg
+
 
 --
 -- Log aggregation
@@ -676,6 +532,24 @@ explainedSeverityAnnotation s
 instance HasSeverityAnnotation (FollowStats LogState) where
     getSeverityAnnotation = fst . explainedSeverityAnnotation
 
+addFollowerLogging
+    :: Monad m
+    => Tracer m (FollowLog msg)
+    -> ChainFollower m point BlockHeader block
+    -> ChainFollower m point BlockHeader block
+addFollowerLogging tr cf = ChainFollower
+    { readLocalTip = do
+        readLocalTip cf
+    , rollForward = \tip blocks -> do
+        traceWith tr $ MsgApplyBlocks tip (fromBlock <$> blocks)
+        traceWith tr $ MsgFollowerTip (Just tip)
+        rollForward cf tip blocks
+    , rollBackward = \slot -> do
+        slot' <- rollBackward cf slot
+        traceWith tr $ MsgDidRollback slot slot'
+        return slot'
+    }
+
 -- | Starts a new thread for monitoring health and statistics from
 -- the returned @FollowLog msg@.
 withFollowStatsMonitoring
@@ -691,6 +565,7 @@ withFollowStatsMonitoring tr calcSyncProgress act = do
                 s <- takeTMVar var
                 putTMVar var $! updateStats msg s
             pure msg
+    traceWith tr' $ MsgFollowerTip Nothing
     race_
         (act tr')
         (loop var startupDelay)
diff --git a/lib/core/src/Ouroboros/Network/Client/Wallet.hs b/lib/core/src/Ouroboros/Network/Client/Wallet.hs
index c5dda12a60b..f16cb5557ce 100644
--- a/lib/core/src/Ouroboros/Network/Client/Wallet.hs
+++ b/lib/core/src/Ouroboros/Network/Client/Wallet.hs
@@ -23,7 +23,6 @@ module Ouroboros.Network.Client.Wallet
       chainSyncFollowTip
 
       -- * ChainSyncWithBlocks
-    , ChainSyncCmd (..)
     , chainSyncWithBlocks
 
       -- * LocalTxSubmission
@@ -37,29 +36,22 @@ module Ouroboros.Network.Client.Wallet
 
       -- * Helpers
     , send
-
-      -- * Logs
-    , ChainSyncLog (..)
-    , mapChainSyncLog
     ) where
 
 import Prelude
 
-import Cardano.BM.Data.Severity
-    ( Severity (..) )
 import Cardano.BM.Data.Tracer
-    ( HasPrivacyAnnotation (..), HasSeverityAnnotation (..) )
+    ( Tracer, traceWith )
 import Cardano.Slotting.Slot
     ( WithOrigin (..) )
 import Cardano.Wallet.Network
-    ( NextBlocksResult (..) )
+    ( ChainFollower (..), ChainSyncLog (..) )
 import Control.Monad
-    ( ap, liftM, unless )
+    ( ap, liftM )
 import Control.Monad.Class.MonadSTM
     ( MonadSTM
     , TQueue
     , atomically
-    , isEmptyTQueue
     , newEmptyTMVarIO
     , peekTQueue
     , putTMVar
@@ -72,16 +64,12 @@ import Control.Monad.Class.MonadThrow
     ( MonadThrow )
 import Control.Monad.IO.Class
     ( MonadIO )
-import Control.Tracer
-    ( Tracer, traceWith )
 import Data.Functor
     ( (<&>) )
 import Data.Kind
     ( Type )
-import Data.Maybe
-    ( isNothing )
-import Data.Text.Class
-    ( ToText (..) )
+import Data.List.NonEmpty
+    ( NonEmpty (..) )
 import Data.Void
     ( Void )
 import Network.TypedProtocol.Pipelined
@@ -98,7 +86,6 @@ import Ouroboros.Network.Block
     , Point (..)
     , Tip (..)
     , blockNo
-    , blockPoint
     , blockSlot
     , castTip
     , getTipPoint
@@ -120,6 +107,7 @@ import Ouroboros.Network.Protocol.LocalTxSubmission.Type
     ( SubmitResult (..) )
 
 import qualified Cardano.Wallet.Primitive.Types as W
+import qualified Data.List.NonEmpty as NE
 import qualified Ouroboros.Network.Protocol.ChainSync.ClientPipelined as P
 import qualified Ouroboros.Network.Protocol.LocalStateQuery.Client as LSQ
 
@@ -226,17 +214,25 @@ chainSyncFollowTip toCardanoEra onTipUpdate =
 -- callback.
 --
 -- See also 'send' for invoking commands.
-data ChainSyncCmd block (m :: Type -> Type)
-    = CmdFindIntersection
-        [Point block]
-        (Maybe (Point block) -> m ())
-    | CmdNextBlocks
-        (NextBlocksResult (Point block) block -> m ())
 
 -- | A little type-alias to ease signatures in 'chainSyncWithBlocks'
 type RequestNextStrategy m n block
-    =  (NextBlocksResult (Point block) block -> m ())
-    -> P.ClientPipelinedStIdle n block (Point block) (Tip block) m Void
+    = P.ClientPipelinedStIdle n block (Point block) (Tip block) m Void
+
+
+-- | Helper type for the different ways we handle rollbacks.
+--
+-- Helps remove some boilerplate.
+data LocalRollbackResult block
+    = Buffer [block]
+    -- ^ The rollback could be handled by filtering the buffer. (The `[block]`
+    -- corresponds to the new, filtered buffer.)
+    | FollowerExact
+    -- ^ `ChainFollower` was asked to rollback, and rolled back to the requested
+    -- point exactly.
+    | FollowerNeedToReNegotiate
+    -- ^ The `ChainFollower` was asked to rollback, but rolled back further than
+    -- requested. We must re-negotiate the intersection with the node.
 
 -- | Client for the 'Chain Sync' mini-protocol.
 --
@@ -277,26 +273,10 @@ type RequestNextStrategy m n block
 chainSyncWithBlocks
     :: forall m block. (Monad m, MonadSTM m, HasHeader block)
     => Tracer m (ChainSyncLog block (Point block))
-    -> (Tip block -> W.BlockHeader)
-        -- ^ Convert an abstract tip to a concrete 'BlockHeader'
-        --
-        -- TODO: We probably need a better type for representing Tip as well!
-
-    -> TQueue m (ChainSyncCmd block m)
-        -- ^ We use a 'TQueue' as a communication channel to drive queries from
-        -- outside of the network client to the client itself.
-        -- Requests are pushed to the queue which are then transformed into
-        -- messages to keep the state-machine moving.
-
-    -> TQueue m (NextBlocksResult (Point block) block)
-        -- ^ An internal queue used for buffering responses collected while
-        -- pipelining. As argument to simplify code below. Responses are first
-        -- poped from this buffer if not empty, otherwise they'll simply trigger
-        -- an exchange with the node.
-
+    -> ChainFollower m (Point block) (Tip block) block
     -> ChainSyncClientPipelined block (Point block) (Tip block) m Void
-chainSyncWithBlocks tr fromTip queue responseBuffer =
-    ChainSyncClientPipelined $ clientStIdle oneByOne
+chainSyncWithBlocks tr chainFollower =
+    ChainSyncClientPipelined clientStNegotiateIntersection
   where
     -- Return the _number of slots between two tips.
     tipDistance :: BlockNo -> Tip block -> Natural
@@ -307,51 +287,53 @@ chainSyncWithBlocks tr fromTip queue responseBuffer =
 
     -- | Keep only blocks from the list that are before or exactly at the given
     -- point.
-    rollback :: Point block -> [block] -> [block]
-    rollback pt = filter (\b -> At (blockSlot b) <= pointSlot pt)
+    rollbackBuffer :: Point block -> [block] -> [block]
+    rollbackBuffer pt = filter (\b -> At (blockSlot b) <= pointSlot pt)
+
+    clientStNegotiateIntersection
+        :: m (P.ClientPipelinedStIdle 'Z block (Point block) (Tip block) m Void)
+    clientStNegotiateIntersection = do
+        points <- readLocalTip chainFollower
+        if null points
+        then clientStIdle oneByOne
+        else pure $ P.SendMsgFindIntersect
+            points
+            clientStIntersect
+      where
+        clientStIntersect
+            :: P.ClientPipelinedStIntersect block (Point block) (Tip block) m Void
+        clientStIntersect = P.ClientPipelinedStIntersect
+            { recvMsgIntersectFound = \_point _tip -> do
+                -- Here, the node tells us which  point  from the possible
+                -- intersections is the latest point on the chain.
+                -- However, we do not have to roll back to this point here;
+                -- when we send a MsgRequestNext message, the node will reply
+                -- with a MsgRollBackward message to this point first.
+                --
+                -- This behavior is not in the network specification yet, but see
+                -- https://input-output-rnd.slack.com/archives/CDA6LUXAQ/p1623322238039900
+                clientStIdle oneByOne
+
+            , recvMsgIntersectNotFound = \_tip -> do
+                -- Same as above, the node will (usually) reply to us with a
+                -- MsgRollBackward message later (here to the genesis point)
+                --
+                -- There is a weird corner case when the original MsgFindIntersect
+                -- message contains an empty list. See
+                -- https://input-output-rnd.slack.com/archives/CDA6LUXAQ/p1634644689103100
+                clientStIdle oneByOne
+            }
 
-    -- Client in the state 'Idle'. We wait for requests / commands on an
-    -- 'TQueue'. Commands start a chain of messages and state transitions
-    -- before finally returning to 'Idle', waiting for the next command.
     clientStIdle
         :: RequestNextStrategy m 'Z block
         -> m (P.ClientPipelinedStIdle 'Z block (Point block) (Tip block) m Void)
-    clientStIdle strategy = atomically (readTQueue queue) >>= \case
-        CmdFindIntersection points respond -> pure $
-            P.SendMsgFindIntersect points (clientStIntersect respond)
-        CmdNextBlocks respond ->
-            -- We are the only consumer & producer of this queue, so it's fine
-            -- to run 'isEmpty' and 'read' in two separate atomatic operations.
-            atomically (isEmptyTQueue responseBuffer) >>= \case
-                True  ->
-                    pure $ strategy respond
-                False -> do
-                    atomically (readTQueue responseBuffer) >>= respond
-                    clientStIdle strategy
-
-    -- When the client intersect, we are effectively starting "a new session",
-    -- so any buffered responses no longer apply and must be discarded.
-    clientStIntersect
-        :: (Maybe (Point block) -> m ())
-        -> P.ClientPipelinedStIntersect block (Point block) (Tip block) m Void
-    clientStIntersect respond = P.ClientPipelinedStIntersect
-        { recvMsgIntersectFound = \intersection _tip -> do
-            respond (Just intersection)
-            flush responseBuffer
-            clientStIdle oneByOne
-
-        , recvMsgIntersectNotFound = \_tip -> do
-            respond Nothing
-            flush responseBuffer
-            clientStIdle oneByOne
-        }
+    clientStIdle strategy = pure strategy
 
     -- Simple strategy that sends a request and waits for an answer.
-    oneByOne
-        :: RequestNextStrategy m 'Z block
-    oneByOne respond = P.SendMsgRequestNext
-        (collectResponses respond [] Zero)
-        (pure $ collectResponses respond [] Zero)
+    oneByOne :: RequestNextStrategy m 'Z block
+    oneByOne = P.SendMsgRequestNext
+        (collectResponses [] Zero)
+        (pure $ collectResponses [] Zero)
 
     -- We only pipeline requests when we are far from the tip. As soon as we
     -- reach the tip however, there's no point pipelining anymore, so we start
@@ -364,23 +346,20 @@ chainSyncWithBlocks tr fromTip queue responseBuffer =
         :: Int
         -> Nat n
         -> RequestNextStrategy m n block
-    pipeline goal (Succ n) respond | natToInt (Succ n) == goal =
-        P.CollectResponse Nothing $ collectResponses respond [] n
-    pipeline goal n respond =
-        P.SendMsgRequestNextPipelined $ pipeline goal (Succ n) respond
+    pipeline goal (Succ n) | natToInt (Succ n) == goal =
+        P.CollectResponse Nothing $ collectResponses [] n
+    pipeline goal n =
+        P.SendMsgRequestNextPipelined $ pipeline goal (Succ n)
 
     collectResponses
-        :: (NextBlocksResult (Point block) block -> m ())
-        -> [block]
+        :: [block]
         -> Nat n
         -> P.ClientStNext n block (Point block) (Tip block) m Void
-    collectResponses respond blocks Zero = P.ClientStNext
+    collectResponses blocks Zero = P.ClientStNext
         { P.recvMsgRollForward = \block tip -> do
             traceWith tr $ MsgChainRollForward block (getTipPoint tip)
-            let cursor' = blockPoint block
-            let blocks' = reverse (block:blocks)
-            let tip'    = fromTip tip
-            respond (RollForward cursor' tip' blocks')
+            let blocks' = NE.reverse (block :| blocks)
+            rollForward chainFollower tip blocks'
             let distance = tipDistance (blockNo block) tip
             traceWith tr $ MsgTipDistance distance
             let strategy = if distance <= 1
@@ -388,57 +367,90 @@ chainSyncWithBlocks tr fromTip queue responseBuffer =
                     else pipeline (fromIntegral $ min distance 1000) Zero
             clientStIdle strategy
 
-        -- When the last message we receive is a request to rollback, we have
-        -- two possibilities:
-        --
-        -- a) Either, we are asked to rollback to a point that is within the
-        -- blocks we have just collected. So it suffices to remove blocks from
-        -- the list, and apply the remaining portion.
-        --
-        -- b) We are asked to rollback even further and discard all the blocks
-        -- we just collected. In which case, we simply discard all blocks and
-        -- rollback to that point as if nothing happened.
         , P.recvMsgRollBackward = \point tip -> do
-            case rollback point blocks of
-                [] -> do -- b)
-                    traceWith tr $ MsgChainRollBackward point 0
-                    respond (RollBackward point)
-                    clientStIdle oneByOne
-
-                xs -> do -- a)
+            r <- handleRollback blocks point tip
+            case r of
+                Buffer xs -> do
                     traceWith tr $ MsgChainRollBackward point (length xs)
-                    let cursor' = blockPoint $ head xs
-                    let blocks' = reverse xs
-                    let tip'    = fromTip tip
-                    respond (RollForward cursor' tip' blocks')
+                    case reverse xs of
+                        []          -> pure ()
+                        (b:blocks') -> rollForward chainFollower tip (b :| blocks')
+                    clientStIdle oneByOne
+                FollowerExact ->
                     clientStIdle oneByOne
+                FollowerNeedToReNegotiate ->
+                    clientStNegotiateIntersection
         }
 
-    collectResponses respond blocks (Succ n) = P.ClientStNext
+    collectResponses blocks (Succ n) = P.ClientStNext
         { P.recvMsgRollForward = \block _tip ->
-        pure $ P.CollectResponse Nothing $ collectResponses respond (block:blocks) n
-
-        -- This scenario is slightly more complicated than for the 'Zero' case.
-        -- Again, there are two possibilities:
-        --
-        -- a) Either we rollback to a point we have just collected, so it
-        -- suffices to discard blocks from the list and continue.
-        --
-        -- b) Or, we need to reply immediately, but we still have to collect the
-        -- remaining responses. BUT, we can only reply once to a given command.
-        -- So instead, we buffer all the remaining responses in a queue and, upon
-        -- receiving future requests, we'll simply read them from the buffer!
-        , P.recvMsgRollBackward = \point _tip ->
-            case rollback point blocks of
-                [] -> do -- b)
-                    let save = atomically . writeTQueue responseBuffer
-                    respond (RollBackward point)
-                    pure $ P.CollectResponse Nothing $ collectResponses save [] n
-                xs -> do -- a)
-                    pure $ P.CollectResponse Nothing $ collectResponses respond xs n
+            pure $ P.CollectResponse Nothing $ collectResponses (block:blocks) n
+
+        , P.recvMsgRollBackward = \point tip -> do
+            r <- handleRollback blocks point tip
+            pure $ P.CollectResponse Nothing $ case r of
+                Buffer xs -> collectResponses xs n
+                FollowerExact -> collectResponses [] n
+                FollowerNeedToReNegotiate -> dropResponsesAndRenegotiate n
         }
 
+    handleRollback
+        :: [block]
+        -> Point block
+        -> Tip block
+        -> m (LocalRollbackResult block)
+    handleRollback buffer point _tip =
+        case rollbackBuffer point buffer of
+            [] -> do
+                traceWith tr $ MsgChainRollBackward point 0
+                actual <- rollBackward chainFollower point
+                if actual == point
+                then pure FollowerExact
+                else do
+                    pure FollowerNeedToReNegotiate
+            xs -> pure $ Buffer xs
+
+    -- | Discards the in-flight requests, and re-negotiates the intersection
+    -- afterwards.
+    dropResponsesAndRenegotiate
+        :: Nat n
+        -> P.ClientStNext n block (Point block) (Tip block) m Void
+    dropResponsesAndRenegotiate (Succ n) =
+        P.ClientStNext
+            { P.recvMsgRollForward = \_block _tip ->
+                pure $ P.CollectResponse Nothing $ dropResponsesAndRenegotiate n
+            , P.recvMsgRollBackward = \_point _tip ->
+                pure $ P.CollectResponse Nothing $ dropResponsesAndRenegotiate n
+            }
+    dropResponsesAndRenegotiate Zero =
+        P.ClientStNext
+            { P.recvMsgRollForward = \_block _tip ->
+                clientStNegotiateIntersection
+            , P.recvMsgRollBackward = \_point _tip ->
+                clientStNegotiateIntersection
+            }
 
+    -- Historical hack. Our DB layers can't represent `Origin` when rolling
+    -- back, so we map `Origin` to `SlotNo 0`, which is wrong.
+    --
+    -- Rolling back to SlotNo 0 instead of Origin is fine for followers starting
+    -- from genesis (which should be the majority of cases). Other, non-trivial
+    -- rollbacks to genesis cannot occur on mainnet (genesis is years within
+    -- stable part, and there were no rollbacks in byron).
+    --
+    -- Could possibly be problematic in the beginning of a testnet without a
+    -- byron era. /Perhaps/ this is what is happening in the
+    -- >>> [cardano-wallet.pools-engine:Error:1293] [2020-11-24 10:02:04.00 UTC]
+    -- >>> Couldn't store production for given block before it conflicts with
+    -- >>> another block. Conflicting block header is:
+    -- >>> 5bde7e7b<-[f1b35b98-4290#2008]
+    -- errors observed in the integration tests.
+    --
+    -- FIXME: Fix should be relatively straight-forward, so we should probably
+    -- do it.
+    pseudoPointSlot p = case pointSlot p of
+        Origin -> W.SlotNo 0
+        At slot -> slot
 
 --------------------------------------------------------------------------------
 --
@@ -624,7 +636,7 @@ localTxSubmission
 localTxSubmission queue = LocalTxSubmissionClient clientStIdle
   where
     clientStIdle
-        :: m (LocalTxClientStIdle tx err m Void)
+        :: m (LocalTxClientStIdle tx err m ())
     clientStIdle = atomically (peekTQueue queue) <&> \case
         CmdSubmitTx tx respond ->
             SendMsgSubmitTx tx $ \res -> do
@@ -656,43 +668,3 @@ send queue cmd = do
     tvar <- newEmptyTMVarIO
     atomically $ writeTQueue queue (cmd (atomically . putTMVar tvar))
     atomically $ takeTMVar tvar
-
--- Tracing
-
-data ChainSyncLog block point
-    = MsgChainRollForward block point
-    | MsgChainRollBackward point Int
-    | MsgTipDistance Natural
-
-mapChainSyncLog
-    :: (b1 -> b2)
-    -> (p1 -> p2)
-    -> ChainSyncLog b1 p1
-    -> ChainSyncLog b2 p2
-mapChainSyncLog f g = \case
-    MsgChainRollForward block point -> MsgChainRollForward (f block) (g point)
-    MsgChainRollBackward point n -> MsgChainRollBackward (g point) n
-    MsgTipDistance d -> MsgTipDistance d
-
-instance (ToText block, ToText point)
-    => ToText (ChainSyncLog block point) where
-    toText = \case
-        MsgChainRollForward b tip ->
-            "ChainSync roll forward: " <> toText b <> " tip is " <> toText tip
-        MsgChainRollBackward b 0 ->
-            "ChainSync roll backward: " <> toText b
-        MsgChainRollBackward b bufferSize -> mconcat
-            [ "ChainSync roll backward: "
-            , toText b
-            , ", handled inside buffer with remaining length "
-            , toText bufferSize
-            ]
-        MsgTipDistance d -> "Tip distance: " <> toText d
-
-instance HasPrivacyAnnotation (ChainSyncLog block point)
-
-instance HasSeverityAnnotation (ChainSyncLog block point) where
-    getSeverityAnnotation = \case
-        MsgChainRollForward{} -> Debug
-        MsgChainRollBackward{} -> Debug
-        MsgTipDistance{} -> Debug
diff --git a/lib/core/test-common/Cardano/Wallet/DummyTarget/Primitive/Types.hs b/lib/core/test-common/Cardano/Wallet/DummyTarget/Primitive/Types.hs
index 1bcba89ef67..7a6cb7cdb26 100644
--- a/lib/core/test-common/Cardano/Wallet/DummyTarget/Primitive/Types.hs
+++ b/lib/core/test-common/Cardano/Wallet/DummyTarget/Primitive/Types.hs
@@ -164,10 +164,7 @@ mkTxId ins outs wdrls md = mockHash (ins, outs, wdrls, md)
 
 dummyNetworkLayer :: NetworkLayer m a
 dummyNetworkLayer = NetworkLayer
-    { nextBlocks = error "nextBlocks: not implemented"
-    , initCursor = error "initCursor: not implemented"
-    , destroyCursor = error "destroyCursor: not implemented"
-    , cursorSlotNo = error "cursorSlotNo: not implemented"
+    { chainSync = error "chainSync: not implemented"
     , currentNodeEra = error "currentNodeEra: not implemented"
     , currentNodeTip = error "currentNodeTip: not implemented"
     , watchNodeTip = error "watchNodeTip: not implemented"
diff --git a/lib/shelley/src/Cardano/Wallet/Shelley/Network.hs b/lib/shelley/src/Cardano/Wallet/Shelley/Network.hs
index 6f1b4fbe72c..d8683515539 100644
--- a/lib/shelley/src/Cardano/Wallet/Shelley/Network.hs
+++ b/lib/shelley/src/Cardano/Wallet/Shelley/Network.hs
@@ -30,8 +30,7 @@
 --     - In particular sections 4.1, 4.2, 4.6 and 4.8
 module Cardano.Wallet.Shelley.Network
     ( -- * Top-Level Interface
-      pattern Cursor
-    , withNetworkLayer
+      withNetworkLayer
 
     , Observer (query,startObserving,stopObserving)
     , newObserver
@@ -66,7 +65,15 @@ import Cardano.Wallet.Byron.Compatibility
 import Cardano.Wallet.Logging
     ( BracketLog, bracketTracer, produceTimings )
 import Cardano.Wallet.Network
-    ( Cursor, ErrPostTx (..), NetworkLayer (..), mapCursor )
+    ( ChainFollower (..)
+    , ErrPostTx (..)
+    , FollowLog (..)
+    , NetworkLayer (..)
+    , addFollowerLogging
+    , mapChainFollower
+    , mapChainSyncLog
+    , withFollowStatsMonitoring
+    )
 import Cardano.Wallet.Primitive.Slotting
     ( TimeInterpreter
     , TimeInterpreterLog
@@ -81,7 +88,6 @@ import Cardano.Wallet.Shelley.Compatibility
     ( StandardCrypto
     , fromAlonzoPParams
     , fromCardanoHash
-    , fromChainHash
     , fromLedgerPParams
     , fromNonMyopicMemberRewards
     , fromPoolDistr
@@ -94,6 +100,7 @@ import Cardano.Wallet.Shelley.Compatibility
     , nodeToClientVersions
     , optimumNumberOfPools
     , slottingParametersFromGenesis
+    , toCardanoBlockHeader
     , toCardanoEra
     , toPoint
     , toShelleyCoin
@@ -200,25 +207,15 @@ import Ouroboros.Consensus.Node.NetworkProtocolVersion
 import Ouroboros.Consensus.Shelley.Ledger.Config
     ( CodecConfig (..), getCompactGenesis )
 import Ouroboros.Network.Block
-    ( Point
-    , Tip (..)
-    , blockPoint
-    , genesisPoint
-    , getPoint
-    , pointHash
-    , pointSlot
-    )
+    ( Point, Tip (..), blockPoint, getPoint )
 import Ouroboros.Network.Client.Wallet
-    ( ChainSyncCmd (..)
-    , ChainSyncLog (..)
-    , LSQ (..)
+    ( LSQ (..)
     , LocalStateQueryCmd (..)
     , LocalTxSubmissionCmd (..)
     , chainSyncFollowTip
     , chainSyncWithBlocks
     , localStateQuery
     , localTxSubmission
-    , mapChainSyncLog
     , send
     )
 import Ouroboros.Network.Driver.Simple
@@ -242,7 +239,7 @@ import Ouroboros.Network.NodeToClient
     , withIOManager
     )
 import Ouroboros.Network.Point
-    ( WithOrigin (..), fromWithOrigin )
+    ( WithOrigin (..) )
 import Ouroboros.Network.Protocol.ChainSync.Client
     ( chainSyncClientPeer )
 import Ouroboros.Network.Protocol.ChainSync.ClientPipelined
@@ -258,13 +255,13 @@ import Ouroboros.Network.Protocol.LocalTxSubmission.Type
 import System.IO.Error
     ( isDoesNotExistError )
 import UnliftIO.Async
-    ( Async, async, asyncThreadId, cancel, link )
+    ( async, link )
 import UnliftIO.Compat
     ( coerceHandlers )
 import UnliftIO.Concurrent
     ( ThreadId )
 import UnliftIO.Exception
-    ( Handler (..), IOException )
+    ( Handler (..), IOException, SomeException, withException )
 
 import qualified Cardano.Api as Cardano
 import qualified Cardano.Api.Shelley as Cardano
@@ -287,12 +284,9 @@ import qualified Ouroboros.Network.Point as Point
 import qualified Shelley.Spec.Ledger.API as SL
 import qualified Shelley.Spec.Ledger.LedgerState as SL
 
--- | Network layer cursor for Shelley. Mostly useless since the protocol itself is
--- stateful and the node's keep track of the associated connection's cursor.
-data instance Cursor = Cursor
-    (Async ())
-    (Point (CardanoBlock StandardCrypto))
-    (TQueue IO (ChainSyncCmd (CardanoBlock StandardCrypto) IO))
+{- HLINT ignore "Use readTVarIO" -}
+{- HLINT ignore "Use newTVarIO" -}
+{- HLINT ignore "Use newEmptyTMVarIO" -}
 
 {-------------------------------------------------------------------------------
     Create/Initialize a NetworkLayer
@@ -352,21 +346,30 @@ withNetworkLayerBase tr net np conn versionData tol action = do
     let readCurrentNodeEra = atomically $ readTMVar eraVar
 
     action $ NetworkLayer
-        { currentNodeTip =
+        { chainSync = \followTr' follower -> do
+            let withStats = withFollowStatsMonitoring
+                    followTr'
+                    (_syncProgress interpreterVar)
+            withStats $ \followTr -> do
+                let addLogging =
+                        addFollowerLogging followTr (toCardanoBlockHeader gp)
+                client <- mkWalletClient
+                    followTr
+                    (mapChainFollower
+                        (toPoint getGenesisBlockHash)
+                        (fromTip' gp)
+                        id
+                        (addLogging follower))
+                    cfg
+                connectClient tr handlers client versionData conn
+
+        , currentNodeTip =
             fromTip getGenesisBlockHash <$> atomically readNodeTip
         , currentNodeEra =
             -- NOTE: Is not guaranteed to be consistent with @currentNodeTip@
             readCurrentNodeEra
         , watchNodeTip = do
             _watchNodeTip readNodeTip
-        , nextBlocks =
-            _nextBlocks
-        , initCursor =
-            _initCursor
-        , destroyCursor =
-            _destroyCursor
-        , cursorSlotNo =
-            _cursorSlotNo
         , currentProtocolParameters =
             fst . fst <$> atomically (readTMVar networkParamsVar)
         , currentNodeProtocolParameters =
@@ -437,42 +440,15 @@ withNetworkLayerBase tr net np conn versionData tol action = do
         link =<< async (connectClient tr handlers client versionData conn)
         pure q
 
-    _initCursor :: HasCallStack => [W.BlockHeader] -> IO Cursor
-    _initCursor headers = do
-        chainSyncQ <- atomically newTQueue
-        client <- mkWalletClient (contramap MsgChainSyncCmd tr) cfg gp chainSyncQ
-        let handlers = failOnConnectionLost tr
-        thread <- async (connectClient tr handlers client versionData conn)
-        link thread
-        let points = reverse $ genesisPoint :
-                (toPoint getGenesisBlockHash <$> headers)
-        let findIt = chainSyncQ `send` CmdFindIntersection points
-        traceWith tr $ MsgFindIntersection headers
-        res <- findIt
-        case res of
-            Just intersection -> do
-                traceWith tr
-                    $ MsgIntersectionFound
-                    $ fromChainHash getGenesisBlockHash
-                    $ pointHash intersection
-                pure $ Cursor thread intersection chainSyncQ
-            _ -> fail $ unwords
-                [ "initCursor: intersection not found? This can't happen"
-                , "because we always give at least the genesis point."
-                , "Here are the points we gave: " <> show headers
-                ]
-
-    _destroyCursor (Cursor thread _ _) = do
-        liftIO $ traceWith tr $ MsgDestroyCursor (asyncThreadId thread)
-        cancel thread
-
-    _nextBlocks (Cursor thread _ chainSyncQ) = do
-        let toCursor point = Cursor thread point chainSyncQ
-        liftIO $ mapCursor toCursor <$> chainSyncQ `send` CmdNextBlocks
-
-    _cursorSlotNo (Cursor _ point _) = do
-        fromWithOrigin (SlotNo 0) $ pointSlot point
-
+    -- NOTE1: only shelley transactions can be submitted like this, because they
+    -- are deserialised as shelley transactions before submitting.
+    --
+    -- NOTE2: It is not ideal to query the current era again here because we
+    -- should in practice use the same era as the one used to construct the
+    -- transaction. However, when turning transactions to 'SealedTx', we loose
+    -- all form of type-level indicator about the era. The 'SealedTx' type
+    -- shouldn't be needed anymore since we've dropped jormungandr, so we could
+    -- instead carry a transaction from cardano-api types with proper typing.
     _postTx localTxSubmissionQ tx = do
         liftIO $ traceWith tr $ MsgPostTx tx
         let cmd = CmdSubmitTx $ unsealShelleyTx tx
@@ -616,22 +592,24 @@ type NetworkClient m = NodeToClientVersion -> OuroborosApplication
 -- | Construct a network client with the given communication channel, for the
 -- purposes of syncing blocks to a single wallet.
 mkWalletClient
-    :: (MonadThrow m, MonadST m, MonadTimer m, MonadAsync m)
-    => Tracer m (ChainSyncLog Text Text)
+    :: forall m msg. (MonadThrow m, MonadST m, MonadTimer m, MonadAsync m)
+    => Tracer m (FollowLog msg)
+    -> ChainFollower m
+        (Point (CardanoBlock StandardCrypto))
+        (Tip (CardanoBlock StandardCrypto))
+        (CardanoBlock StandardCrypto)
     -> CodecConfig (CardanoBlock StandardCrypto)
-    -> W.GenesisParameters
-        -- ^ Static blockchain parameters
-    -> TQueue m (ChainSyncCmd (CardanoBlock StandardCrypto) m)
-        -- ^ Communication channel with the ChainSync client
     -> m (NetworkClient m)
-mkWalletClient tr cfg gp chainSyncQ = do
-    stash <- atomically newTQueue
+mkWalletClient tr follower cfg = do
     pure $ \v -> nodeToClientProtocols (const $ return $ NodeToClientProtocols
         { localChainSyncProtocol =
             InitiatorProtocolOnly $ MuxPeerRaw $ \channel ->
                 runPipelinedPeer nullTracer (cChainSyncCodec $ codecs v cfg) channel
                 $ chainSyncClientPeerPipelined
-                $ chainSyncWithBlocks tr' (fromTip' gp) chainSyncQ stash
+                $ chainSyncWithBlocks
+                    (contramap (MsgChainSync . mapChainSyncLog showB showP) tr)
+                    follower
+
         , localTxSubmissionProtocol =
             doNothingProtocol
 
@@ -639,8 +617,10 @@ mkWalletClient tr cfg gp chainSyncQ = do
             doNothingProtocol
         }) v
   where
-    tr' = contramap (mapChainSyncLog showB showP) tr
+    showB :: CardanoBlock StandardCrypto -> Text
     showB = showP . blockPoint
+
+    showP :: Point (CardanoBlock StandardCrypto) -> Text
     showP p = case (getPoint p) of
         Origin -> "Origin"
         At blk -> mconcat
@@ -1060,15 +1040,6 @@ retryOnConnectionLost tr =
   where
     tr' = contramap MsgConnectionLost tr
 
--- | Handlers that are failing if the connection is lost
-failOnConnectionLost :: Tracer IO NetworkLayerLog -> RetryHandlers
-failOnConnectionLost tr =
-    [ const $ Handler $ handleIOException tr' False
-    , const $ Handler $ handleMuxError tr' False
-    ]
-  where
-    tr' = contramap MsgConnectionLost tr
-
 -- When the node's connection vanished, we may also want to handle things in a
 -- slightly different way depending on whether we are a waller worker or just
 -- the node's tip thread.
@@ -1094,7 +1065,7 @@ handleIOException tr onResourceVanished e
         traceWith tr $ Just e
         pure onResourceVanished
 
-    | otherwise =
+    | otherwise = do
         pure False
   where
     isResourceVanishedError = isInfixOf "resource vanished" . show
@@ -1220,7 +1191,6 @@ data NetworkLayerLog where
       -- ^ Number of pools in stake distribution, and rewards map,
       -- respectively.
     MsgWatcherUpdate :: W.BlockHeader -> BracketLog -> NetworkLayerLog
-    MsgChainSyncCmd :: (ChainSyncLog Text Text) -> NetworkLayerLog
     MsgInterpreter :: CardanoInterpreter StandardCrypto -> NetworkLayerLog
     -- TODO: Combine ^^ and vv
     MsgInterpreterLog :: TimeInterpreterLog -> NetworkLayerLog
@@ -1315,7 +1285,6 @@ instance ToText NetworkLayerLog where
         MsgQueryTime qry diffTime ->
             "Query " <> T.pack qry <> " took " <> T.pack (show diffTime) <>
             if isSlowQuery qry diffTime then " (too slow)" else ""
-        MsgChainSyncCmd a -> toText a
         MsgInterpreter interpreter ->
             "Updated the history interpreter: " <> T.pack (show interpreter)
         MsgInterpreterLog msg -> toText msg
@@ -1346,7 +1315,6 @@ instance HasSeverityAnnotation NetworkLayerLog where
         MsgFetchStakePoolsData{}           -> Debug
         MsgFetchStakePoolsDataSummary{}    -> Info
         MsgWatcherUpdate{}                 -> Debug
-        MsgChainSyncCmd cmd                -> getSeverityAnnotation cmd
         MsgInterpreter{}                   -> Debug
         MsgQuery _ msg                     -> getSeverityAnnotation msg
         MsgQueryTime qry dt
diff --git a/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs b/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs
index cd1586d8896..b324ee9ceed 100644
--- a/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs
+++ b/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs
@@ -59,12 +59,7 @@ import Cardano.Wallet.Api.Types
 import Cardano.Wallet.Byron.Compatibility
     ( toByronBlockHeader )
 import Cardano.Wallet.Network
-    ( FollowAction (..)
-    , FollowExceptionRecovery (..)
-    , FollowLog (MsgFollowLog)
-    , NetworkLayer (..)
-    , follow
-    )
+    ( ChainFollower (..), FollowLog (..), NetworkLayer (..) )
 import Cardano.Wallet.Primitive.Slotting
     ( PastHorizonException (..)
     , TimeInterpreter
@@ -107,7 +102,6 @@ import Cardano.Wallet.Shelley.Compatibility
     , fromMaryBlock
     , fromShelleyBlock
     , getProducer
-    , toCardanoBlockHeader
     , toShelleyBlockHeader
     )
 import Cardano.Wallet.Unsafe
@@ -539,6 +533,8 @@ monitorStakePools
 monitorStakePools followTr (NetworkParameters gp sp _pp) nl DBLayer{..} =
     monitor =<< mkLatestGarbageCollectionEpochRef
   where
+    innerTr = contramap MsgFollowLog followTr
+
     monitor latestGarbageCollectionEpochRef = do
             let rollForward = forward latestGarbageCollectionEpochRef
 
@@ -548,9 +544,11 @@ monitorStakePools followTr (NetworkParameters gp sp _pp) nl DBLayer{..} =
                     -- return it.
                     return $ Right slot
 
-            follow nl followTr
-                initCursor rollForward rollback
-                AbortOnExceptions getHeader
+            chainSync nl followTr $ ChainFollower
+                { readLocalTip = initCursor
+                , rollForward = \tip blocks -> rollForward blocks tip innerTr
+                , rollBackward = fmap (either (error "todo") id) . rollback
+                }
 
     GenesisParameters  { getGenesisBlockHash  } = gp
     SlottingParameters { getSecurityParameter } = sp
@@ -571,18 +569,14 @@ monitorStakePools followTr (NetworkParameters gp sp _pp) nl DBLayer{..} =
     initCursor = atomically $ listHeaders (max 100 k)
       where k = fromIntegral $ getQuantity getSecurityParameter
 
-    getHeader :: CardanoBlock StandardCrypto -> BlockHeader
-    getHeader = toCardanoBlockHeader gp
-
     forward
         :: IORef EpochNo
         -> NonEmpty (CardanoBlock StandardCrypto)
         -> BlockHeader
         -> Tracer IO StakePoolLog
-        -> IO (FollowAction Void)
+        -> IO ()
     forward latestGarbageCollectionEpochRef blocks _ tr = do
         atomically $ forAllAndLastM blocks forAllBlocks forLastBlock
-        return Continue
       where
         forAllBlocks = \case
             BlockByron _ -> do

From 517c7f2a91149818b83ab9fbbc7cfa3e4334c0a9 Mon Sep 17 00:00:00 2001
From: Heinrich Apfelmus <heinrich.apfelmus@iohk.io>
Date: Mon, 18 Oct 2021 15:49:24 +0200
Subject: [PATCH 04/10] Introduce `ChainPoint` type for chain following

* Percolate the `ChainPoint` type halfway to the database layer
* TODO later: Use the type provided by `Cardano.Api` instead
---
 lib/core/src/Cardano/Wallet.hs                | 44 +++++++++++++++++--
 lib/core/src/Cardano/Wallet/DB.hs             |  2 +-
 lib/core/src/Cardano/Wallet/DB/Model.hs       |  4 +-
 lib/core/src/Cardano/Wallet/DB/Sqlite.hs      |  4 +-
 lib/core/src/Cardano/Wallet/Gen.hs            | 11 +++++
 lib/core/src/Cardano/Wallet/Network.hs        | 30 ++++++-------
 .../src/Cardano/Wallet/Primitive/Types.hs     | 21 +++++++++
 .../src/Ouroboros/Network/Client/Wallet.hs    | 23 ----------
 .../test/unit/Cardano/Wallet/DB/Properties.hs |  5 ++-
 .../unit/Cardano/Wallet/DB/StateMachine.hs    |  8 ++--
 .../test/unit/Cardano/Wallet/NetworkSpec.hs   |  6 +--
 .../Cardano/Wallet/Shelley/Compatibility.hs   | 26 +++++++----
 .../src/Cardano/Wallet/Shelley/Network.hs     |  5 ++-
 .../src/Cardano/Wallet/Shelley/Pools.hs       | 18 ++++++--
 .../Wallet/Shelley/CompatibilitySpec.hs       | 10 ++---
 15 files changed, 143 insertions(+), 74 deletions(-)

diff --git a/lib/core/src/Cardano/Wallet.hs b/lib/core/src/Cardano/Wallet.hs
index 2309c762ce9..6ec990068a5 100644
--- a/lib/core/src/Cardano/Wallet.hs
+++ b/lib/core/src/Cardano/Wallet.hs
@@ -340,6 +340,7 @@ import Cardano.Wallet.Primitive.Types
     ( ActiveSlotCoefficient (..)
     , Block (..)
     , BlockHeader (..)
+    , ChainPoint (..)
     , DelegationCertificate (..)
     , FeePolicy (LinearFee)
     , GenesisParameters (..)
@@ -892,7 +893,7 @@ restoreWallet
 restoreWallet ctx wid = db & \DBLayer{..} -> do
     liftIO $ chainSync nw tr' $ ChainFollower
         { readLocalTip =
-            liftIO $ atomically $ listCheckpoints wid
+            liftIO $ atomically $ map toChainPoint <$> listCheckpoints wid
         , rollForward = \tip blocks -> throwInIO $
             restoreBlocks @ctx @s @k
                 ctx (contramap MsgFollowLog tr') wid blocks tip
@@ -916,13 +917,48 @@ rollbackBlocks
     :: forall ctx s k. (HasDBLayer IO s k ctx)
     => ctx
     -> WalletId
-    -> SlotNo
-    -> ExceptT ErrNoSuchWallet IO SlotNo
+    -> ChainPoint
+    -> ExceptT ErrNoSuchWallet IO ChainPoint
 rollbackBlocks ctx wid point = db & \DBLayer{..} -> do
-    mapExceptT atomically $ rollbackTo wid point
+    mapExceptT atomically $ toChainPoint <$> rollbackTo wid (pseudoPointSlot point)
   where
     db = ctx ^. dbLayer @IO @s @k
 
+-- 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
+
+{- NOTE [PointSlotNo] 
+
+`SlotNo` cannot represent the genesis point `Origin`.
+
+Historical hack. Our DB layers can't represent `Origin` when rolling
+back, so we map `Origin` to `SlotNo 0`, which is wrong.
+
+Rolling back to SlotNo 0 instead of Origin is fine for followers starting
+from genesis (which should be the majority of cases). Other, non-trivial
+rollbacks to genesis cannot occur on mainnet (genesis is years within
+stable part, and there were no rollbacks in byron).
+
+Could possibly be problematic in the beginning of a testnet without a
+byron era. /Perhaps/ this is what is happening in the
+>>> [cardano-wallet.pools-engine:Error:1293] [2020-11-24 10:02:04.00 UTC]
+>>> Couldn't store production for given block before it conflicts with
+>>> another block. Conflicting block header is:
+>>> 5bde7e7b<-[f1b35b98-4290#2008]
+errors observed in the integration tests.
+
+FIXME: Fix should be relatively straight-forward, so we should probably
+do it.
+Heinrich: I have introduced the 'ChainPoint' type to represent points
+on the chain. This type is already used in chain sync protocol,
+but it still needs to be propagated to the database layer.
+-}
+
 -- | Apply the given blocks to the wallet and update the wallet state,
 -- transaction history and corresponding metadata.
 restoreBlocks
diff --git a/lib/core/src/Cardano/Wallet/DB.hs b/lib/core/src/Cardano/Wallet/DB.hs
index 88a87e7da3d..9a135188a31 100644
--- a/lib/core/src/Cardano/Wallet/DB.hs
+++ b/lib/core/src/Cardano/Wallet/DB.hs
@@ -304,7 +304,7 @@ data DBLayer m s k = forall stm. (MonadIO stm, MonadFail stm) => DBLayer
     , rollbackTo
         :: WalletId
         -> SlotNo
-        -> ExceptT ErrNoSuchWallet stm SlotNo
+        -> ExceptT ErrNoSuchWallet stm BlockHeader
         -- ^ Drops all checkpoints and transaction data after the given slot.
         --
         -- Returns the actual slot to which the database has rolled back. This
diff --git a/lib/core/src/Cardano/Wallet/DB/Model.hs b/lib/core/src/Cardano/Wallet/DB/Model.hs
index 1b5e058e1cd..6cfa5e4a0a5 100644
--- a/lib/core/src/Cardano/Wallet/DB/Model.hs
+++ b/lib/core/src/Cardano/Wallet/DB/Model.hs
@@ -301,7 +301,7 @@ mRemovePendingOrExpiredTx wid tid = alterModelErr wid $ \wal ->
                 , submittedTxs = Map.delete tid (submittedTxs wal)
                 } )
 
-mRollbackTo :: Ord wid => wid -> SlotNo -> ModelOp wid s xprv SlotNo
+mRollbackTo :: Ord wid => wid -> SlotNo -> ModelOp wid s xprv BlockHeader
 mRollbackTo wid requested db@(Database wallets txs) = case Map.lookup wid wallets of
     Nothing ->
         ( Left (NoSuchWallet wid), db )
@@ -319,7 +319,7 @@ mRollbackTo wid requested db@(Database wallets txs) = case Map.lookup wid wallet
                             Map.mapMaybe (rescheduleOrForget point) (txHistory wal)
                         }
                 in
-                    ( Right point
+                    ( Right $ view #currentTip (checkpoints wal Map.! point)
                     , Database (Map.insert wid wal' wallets) txs
                     )
   where
diff --git a/lib/core/src/Cardano/Wallet/DB/Sqlite.hs b/lib/core/src/Cardano/Wallet/DB/Sqlite.hs
index 6edfd4f9ca8..1f7737e8933 100644
--- a/lib/core/src/Cardano/Wallet/DB/Sqlite.hs
+++ b/lib/core/src/Cardano/Wallet/DB/Sqlite.hs
@@ -1444,7 +1444,9 @@ newDBLayerWith cacheBehavior tr ti SqliteContext{runQuery} = do
                         [ StakeKeyCertSlot >. nearestPoint
                         ]
                     refreshCache wid
-                    pure (Right nearestPoint)
+                    selectLatestCheckpointCached wid >>= \case
+                        Nothing -> error "Sqlite.rollbackTo: impossible code path"
+                        Just cp -> pure $ Right $ cp ^. #currentTip
 
         , prune = \wid epochStability -> ExceptT $ do
             selectLatestCheckpointCached wid >>= \case
diff --git a/lib/core/src/Cardano/Wallet/Gen.hs b/lib/core/src/Cardano/Wallet/Gen.hs
index d60e5b85767..4c1753f9492 100644
--- a/lib/core/src/Cardano/Wallet/Gen.hs
+++ b/lib/core/src/Cardano/Wallet/Gen.hs
@@ -14,6 +14,7 @@ module Cardano.Wallet.Gen
     , shrinkPercentage
     , genLegacyAddress
     , genBlockHeader
+    , genChainPoint
     , genActiveSlotCoefficient
     , shrinkActiveSlotCoefficient
     , genSlotNo
@@ -50,6 +51,7 @@ import Cardano.Wallet.Primitive.AddressDiscovery.Shared
 import Cardano.Wallet.Primitive.Types
     ( ActiveSlotCoefficient (..)
     , BlockHeader (..)
+    , ChainPoint (..)
     , ProtocolMagic (..)
     , SlotNo (..)
     )
@@ -91,6 +93,7 @@ import Test.QuickCheck
     , arbitrarySizedNatural
     , choose
     , elements
+    , frequency
     , listOf
     , listOf1
     , oneof
@@ -167,6 +170,14 @@ genSlotNo = SlotNo . fromIntegral <$> arbitrary @Word32
 shrinkSlotNo :: SlotNo -> [SlotNo]
 shrinkSlotNo (SlotNo x) = map SlotNo $ shrink x
 
+genChainPoint :: Gen ChainPoint
+genChainPoint = frequency
+    [ ( 1, pure ChainPointAtGenesis)  -- "common" but not "very common"
+    , (40, toChainPoint <$> (genBlockHeader =<< genSlotNo))
+    ]
+  where
+    toChainPoint (BlockHeader slot _ h _) = ChainPoint slot h
+
 genBlockHeader :: SlotNo -> Gen BlockHeader
 genBlockHeader sl = do
         BlockHeader sl (mockBlockHeight sl) <$> genHash <*> genHash
diff --git a/lib/core/src/Cardano/Wallet/Network.hs b/lib/core/src/Cardano/Wallet/Network.hs
index 4f202f7ae87..a75878b6898 100644
--- a/lib/core/src/Cardano/Wallet/Network.hs
+++ b/lib/core/src/Cardano/Wallet/Network.hs
@@ -52,6 +52,7 @@ import Cardano.Wallet.Primitive.SyncProgress
     ( SyncProgress (..) )
 import Cardano.Wallet.Primitive.Types
     ( BlockHeader (..)
+    , ChainPoint
     , ProtocolParameters
     , SlotNo (..)
     , SlottingParameters (..)
@@ -112,7 +113,7 @@ data NetworkLayer m block = NetworkLayer
     { chainSync
         :: forall msg. Tracer IO (FollowLog msg)
         -> ChainFollower m
-            BlockHeader
+            ChainPoint
             BlockHeader
             block
         -> m ()
@@ -197,12 +198,10 @@ data ChainFollower m point tip block = ChainFollower
         --
         -- Implementors _may_ delete old checkpoints while rolling forward.
 
-    , rollBackward :: SlotNo -> m SlotNo
+    , rollBackward :: point -> m point
         -- ^ Roll back to the requested slot, or further, and return the point
         -- actually rolled back to.
         --
-        -- TODO: `SlotNo` cannot represent the genesis point `Origin`.
-        --
         -- __Example 1:__
         --
         -- If the follower stores checkpoints for all blocks, we can always roll
@@ -239,15 +238,16 @@ data ChainFollower m point tip block = ChainFollower
 mapChainFollower
     :: Functor m
     => (point1 -> point2) -- ^ Covariant
+    -> (point2 -> point1) -- ^ Contravariant
     -> (tip2 -> tip1) -- ^ Contravariant
     -> (block2 -> block1) -- ^ Contravariant
     -> ChainFollower m point1 tip1 block1
     -> ChainFollower m point2 tip2 block2
-mapChainFollower fpoint ftip fblock cf =
+mapChainFollower fpoint12 fpoint21 ftip fblock cf =
     ChainFollower
-        { readLocalTip = map fpoint <$> readLocalTip cf
+        { readLocalTip = map fpoint12 <$> readLocalTip cf
         , rollForward = \t bs -> rollForward cf (ftip t) (fmap fblock bs)
-        , rollBackward = rollBackward cf
+        , rollBackward = fmap fpoint12 . rollBackward cf . fpoint21
         }
 
 
@@ -316,8 +316,8 @@ data FollowLog msg
     | MsgFollowStats (FollowStats LogState)
     | MsgApplyBlocks BlockHeader (NonEmpty BlockHeader)
     | MsgFollowLog msg -- Inner tracer
-    | MsgWillRollback SlotNo
-    | MsgDidRollback SlotNo SlotNo
+    | MsgWillRollback ChainPoint
+    | MsgDidRollback ChainPoint ChainPoint
     | MsgFailedRollingBack Text -- Reason
     | MsgWillIgnoreRollback SlotNo Text -- Reason
     | MsgChainSync (ChainSyncLog Text Text)
@@ -535,8 +535,8 @@ instance HasSeverityAnnotation (FollowStats LogState) where
 addFollowerLogging
     :: Monad m
     => Tracer m (FollowLog msg)
-    -> ChainFollower m point BlockHeader block
-    -> ChainFollower m point BlockHeader block
+    -> ChainFollower m ChainPoint BlockHeader block
+    -> ChainFollower m ChainPoint BlockHeader block
 addFollowerLogging tr cf = ChainFollower
     { readLocalTip = do
         readLocalTip cf
@@ -544,10 +544,10 @@ addFollowerLogging tr cf = ChainFollower
         traceWith tr $ MsgApplyBlocks tip (fromBlock <$> blocks)
         traceWith tr $ MsgFollowerTip (Just tip)
         rollForward cf tip blocks
-    , rollBackward = \slot -> do
-        slot' <- rollBackward cf slot
-        traceWith tr $ MsgDidRollback slot slot'
-        return slot'
+    , rollBackward = \point -> do
+        point' <- rollBackward cf point
+        traceWith tr $ MsgDidRollback point point'
+        pure point'
     }
 
 -- | Starts a new thread for monitoring health and statistics from
diff --git a/lib/core/src/Cardano/Wallet/Primitive/Types.hs b/lib/core/src/Cardano/Wallet/Primitive/Types.hs
index 4c03b31f451..b2018720eab 100644
--- a/lib/core/src/Cardano/Wallet/Primitive/Types.hs
+++ b/lib/core/src/Cardano/Wallet/Primitive/Types.hs
@@ -35,6 +35,7 @@ module Cardano.Wallet.Primitive.Types
     -- * Block
       Block(..)
     , BlockHeader(..)
+    , ChainPoint (..)
 
     -- * Delegation and stake pools
     , CertificatePublicationTime (..)
@@ -774,6 +775,26 @@ instance Buildable (Block) where
         <> build h
         <> if null txs then " ∅" else "\n" <> indentF 4 (blockListF txs)
 
+-- | A point on the blockchain
+-- is either the genesis block, or a block with a hash that was
+-- created at a particular 'SlotNo'.
+--
+-- TODO: This type is essentially a copy of the 'Cardano.Api.Block.ChainPoint'
+-- type. We want to import it from there when overhauling our types.
+data ChainPoint
+    = ChainPointAtGenesis
+    | ChainPoint !SlotNo !(Hash "BlockHeader")
+    deriving (Eq, Show, Generic)
+
+instance NFData ChainPoint
+
+instance Buildable ChainPoint where
+    build ChainPointAtGenesis    = "[point genesis]"
+    build (ChainPoint slot hash) =
+        "[point " <> hashF <> " at slot " <> pretty slot <> "]"
+      where
+        hashF = prefixF 8 $ T.decodeUtf8 $ convertToBase Base16 $ getHash hash
+
 data BlockHeader = BlockHeader
     { slotNo
         :: SlotNo
diff --git a/lib/core/src/Ouroboros/Network/Client/Wallet.hs b/lib/core/src/Ouroboros/Network/Client/Wallet.hs
index f16cb5557ce..07e37954a73 100644
--- a/lib/core/src/Ouroboros/Network/Client/Wallet.hs
+++ b/lib/core/src/Ouroboros/Network/Client/Wallet.hs
@@ -106,7 +106,6 @@ import Ouroboros.Network.Protocol.LocalTxSubmission.Client
 import Ouroboros.Network.Protocol.LocalTxSubmission.Type
     ( SubmitResult (..) )
 
-import qualified Cardano.Wallet.Primitive.Types as W
 import qualified Data.List.NonEmpty as NE
 import qualified Ouroboros.Network.Protocol.ChainSync.ClientPipelined as P
 import qualified Ouroboros.Network.Protocol.LocalStateQuery.Client as LSQ
@@ -430,28 +429,6 @@ chainSyncWithBlocks tr chainFollower =
                 clientStNegotiateIntersection
             }
 
-    -- Historical hack. Our DB layers can't represent `Origin` when rolling
-    -- back, so we map `Origin` to `SlotNo 0`, which is wrong.
-    --
-    -- Rolling back to SlotNo 0 instead of Origin is fine for followers starting
-    -- from genesis (which should be the majority of cases). Other, non-trivial
-    -- rollbacks to genesis cannot occur on mainnet (genesis is years within
-    -- stable part, and there were no rollbacks in byron).
-    --
-    -- Could possibly be problematic in the beginning of a testnet without a
-    -- byron era. /Perhaps/ this is what is happening in the
-    -- >>> [cardano-wallet.pools-engine:Error:1293] [2020-11-24 10:02:04.00 UTC]
-    -- >>> Couldn't store production for given block before it conflicts with
-    -- >>> another block. Conflicting block header is:
-    -- >>> 5bde7e7b<-[f1b35b98-4290#2008]
-    -- errors observed in the integration tests.
-    --
-    -- FIXME: Fix should be relatively straight-forward, so we should probably
-    -- do it.
-    pseudoPointSlot p = case pointSlot p of
-        Origin -> W.SlotNo 0
-        At slot -> slot
-
 --------------------------------------------------------------------------------
 --
 -- LocalStateQuery
diff --git a/lib/core/test/unit/Cardano/Wallet/DB/Properties.hs b/lib/core/test/unit/Cardano/Wallet/DB/Properties.hs
index f2763f606cc..1f50f191164 100644
--- a/lib/core/test/unit/Cardano/Wallet/DB/Properties.hs
+++ b/lib/core/test/unit/Cardano/Wallet/DB/Properties.hs
@@ -807,7 +807,7 @@ prop_rollbackCheckpoint db@DBLayer{..} cp0 (MockChain chain) = do
         let str = maybe "∅" pretty cp
         monitor $ counterexample ("Checkpoint after rollback: \n" <> str)
         assert (ShowFmt cp == ShowFmt (pure point))
-        assert (ShowFmt point' == ShowFmt (tip ^. #slotNo))
+        assert (ShowFmt (point' ^. #slotNo) == ShowFmt (tip ^. #slotNo))
 
 -- | Re-schedule pending transaction on rollback, i.e.:
 --
@@ -840,7 +840,8 @@ prop_rollbackTxHistory db@DBLayer{..} (InitialCheckpoint cp0) (GenTxHistory txs0
             unsafeRunExceptT $ putTxHistory wid txs0
 
     prop wid requestedPoint = do
-        point <- run $ unsafeRunExceptT $ mapExceptT atomically $ rollbackTo wid requestedPoint
+        point <- run $ unsafeRunExceptT $ mapExceptT atomically $
+            view #slotNo <$> rollbackTo wid requestedPoint
         txs <- run $ atomically $ fmap toTxHistory
             <$> readTxHistory wid Nothing Descending wholeRange Nothing
 
diff --git a/lib/core/test/unit/Cardano/Wallet/DB/StateMachine.hs b/lib/core/test/unit/Cardano/Wallet/DB/StateMachine.hs
index f213ac57ed4..71ddca66e8a 100644
--- a/lib/core/test/unit/Cardano/Wallet/DB/StateMachine.hs
+++ b/lib/core/test/unit/Cardano/Wallet/DB/StateMachine.hs
@@ -118,7 +118,7 @@ import Cardano.Wallet.Primitive.AddressDiscovery.Shared
 import Cardano.Wallet.Primitive.Model
     ( Wallet )
 import Cardano.Wallet.Primitive.Types
-    ( BlockHeader
+    ( BlockHeader (..)
     , DecentralizationLevel
     , DelegationCertificate
     , EpochNo (..)
@@ -158,7 +158,7 @@ import Cardano.Wallet.Primitive.Types.Tx
     , TransactionInfo (..)
     , Tx (..)
     , TxIn (..)
-    , TxMeta (..)
+    , TxMeta
     , TxMetadata
     , TxOut (..)
     , TxScriptValidity
@@ -457,7 +457,7 @@ runMock = \case
         first (Resp . fmap DelegationRewardBalance)
         . mReadDelegationRewardBalance wid
     RollbackTo wid sl ->
-        first (Resp . fmap Point) . mRollbackTo wid sl
+        first (Resp . fmap (Point . slotNo)) . mRollbackTo wid sl
   where
     timeInterpreter = dummyTimeInterpreter
 
@@ -535,7 +535,7 @@ runIO db@DBLayer{..} = fmap Resp . go
         ReadDelegationRewardBalance wid -> Right . DelegationRewardBalance <$>
             atomically (readDelegationRewardBalance wid)
         RollbackTo wid sl -> catchNoSuchWallet Point $
-            mapExceptT atomically $ rollbackTo wid sl
+            mapExceptT atomically $ fmap slotNo $ rollbackTo wid sl
 
     catchWalletAlreadyExists f =
         fmap (bimap errWalletAlreadyExists f) . runExceptT
diff --git a/lib/core/test/unit/Cardano/Wallet/NetworkSpec.hs b/lib/core/test/unit/Cardano/Wallet/NetworkSpec.hs
index 25ddc090608..2ca89844278 100644
--- a/lib/core/test/unit/Cardano/Wallet/NetworkSpec.hs
+++ b/lib/core/test/unit/Cardano/Wallet/NetworkSpec.hs
@@ -8,7 +8,7 @@ module Cardano.Wallet.NetworkSpec
 import Prelude
 
 import Cardano.Wallet.Gen
-    ( genBlockHeader, genSlotNo )
+    ( genBlockHeader, genChainPoint, genSlotNo )
 import Cardano.Wallet.Network
     ( ErrPostTx (..), FollowLog (..), emptyStats, updateStats )
 import Cardano.Wallet.Primitive.Types
@@ -49,8 +49,8 @@ instance Arbitrary (FollowLog msg) where
           <$> arbitrary
           <*> ((NE.fromList . getNonEmpty) <$> arbitrary)
       , MsgDidRollback
-          <$> genSlotNo
-          <*> genSlotNo
+          <$> genChainPoint
+          <*> genChainPoint
       , MsgFollowerTip . Just
           <$> arbitrary
       , pure $ MsgFollowerTip Nothing
diff --git a/lib/shelley/src/Cardano/Wallet/Shelley/Compatibility.hs b/lib/shelley/src/Cardano/Wallet/Shelley/Compatibility.hs
index e2730779afe..7c3c708a62e 100644
--- a/lib/shelley/src/Cardano/Wallet/Shelley/Compatibility.hs
+++ b/lib/shelley/src/Cardano/Wallet/Shelley/Compatibility.hs
@@ -59,6 +59,7 @@ module Cardano.Wallet.Shelley.Compatibility
     , toCardanoHash
     , unsealShelleyTx
     , toPoint
+    , fromPoint
     , toCardanoTxId
     , toCardanoTxIn
     , fromCardanoTxIn
@@ -115,6 +116,7 @@ module Cardano.Wallet.Shelley.Compatibility
     , fromGenesisData
     , fromTip
     , fromTip'
+    , toTip
     , fromCardanoTx
     , fromShelleyTx
     , fromAllegraTx
@@ -194,7 +196,8 @@ import Cardano.Wallet.Byron.Compatibility
 import Cardano.Wallet.Primitive.AddressDerivation
     ( NetworkDiscriminant (..) )
 import Cardano.Wallet.Primitive.Types
-    ( MinimumUTxOValue (..)
+    ( ChainPoint (..)
+    , MinimumUTxOValue (..)
     , PoolCertificate (..)
     , PoolRegistrationCertificate (..)
     , PoolRetirementCertificate (..)
@@ -414,13 +417,13 @@ toCardanoHash :: W.Hash "BlockHeader" -> OneEraHash (CardanoEras sc)
 toCardanoHash (W.Hash bytes) =
     OneEraHash $ toShort bytes
 
-toPoint
-    :: W.Hash "Genesis"
-    -> W.BlockHeader
-    -> Point (CardanoBlock sc)
-toPoint genesisH (W.BlockHeader sl _ (W.Hash h) _)
-  | h == (coerce genesisH) = O.GenesisPoint
-  | otherwise = O.BlockPoint sl (OneEraHash $ toShort h)
+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)
 
 toCardanoBlockHeader
     :: forall c. Era (SL.ShelleyEra c)
@@ -618,6 +621,13 @@ fromTip genesisHash tip = case getPoint (getTipPoint tip) of
         Origin -> BlockNo 0
         At x -> x
 
+toTip :: W.Hash "Genesis" -> W.BlockHeader -> Tip (CardanoBlock sc)
+toTip genesisHash (W.BlockHeader sl bl h _)
+    | h == (coerce genesisHash) = O.TipGenesis
+    | otherwise = O.Tip sl
+        (toCardanoHash h)
+        (BlockNo $ fromIntegral $ getQuantity bl)
+
 -- NOTE: Unsafe conversion from Natural -> Word16
 fromMaxSize :: Natural -> Quantity "byte" Word16
 fromMaxSize =
diff --git a/lib/shelley/src/Cardano/Wallet/Shelley/Network.hs b/lib/shelley/src/Cardano/Wallet/Shelley/Network.hs
index d8683515539..27c37df7fee 100644
--- a/lib/shelley/src/Cardano/Wallet/Shelley/Network.hs
+++ b/lib/shelley/src/Cardano/Wallet/Shelley/Network.hs
@@ -10,7 +10,6 @@
 {-# LANGUAGE NoMonoLocalBinds #-}
 {-# LANGUAGE NoMonomorphismRestriction #-}
 {-# LANGUAGE NumericUnderscores #-}
-{-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE Rank2Types #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TupleSections #-}
@@ -90,6 +89,7 @@ import Cardano.Wallet.Shelley.Compatibility
     , fromCardanoHash
     , fromLedgerPParams
     , fromNonMyopicMemberRewards
+    , fromPoint
     , fromPoolDistr
     , fromShelleyCoin
     , fromShelleyPParams
@@ -356,7 +356,8 @@ withNetworkLayerBase tr net np conn versionData tol action = do
                 client <- mkWalletClient
                     followTr
                     (mapChainFollower
-                        (toPoint getGenesisBlockHash)
+                        toPoint
+                        fromPoint
                         (fromTip' gp)
                         id
                         (addLogging follower))
diff --git a/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs b/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs
index b324ee9ceed..0782acb8755 100644
--- a/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs
+++ b/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs
@@ -71,6 +71,7 @@ import Cardano.Wallet.Primitive.Types
     ( ActiveSlotCoefficient (..)
     , BlockHeader (..)
     , CertificatePublicationTime (..)
+    , ChainPoint (..)
     , EpochNo (..)
     , GenesisParameters (..)
     , NetworkParameters (..)
@@ -83,6 +84,7 @@ import Cardano.Wallet.Primitive.Types
     , PoolRetirementCertificate (..)
     , Settings (..)
     , SlotLength (..)
+    , SlotNo (..)
     , SlottingParameters (..)
     , StakePoolMetadata
     , StakePoolMetadataHash
@@ -538,14 +540,22 @@ monitorStakePools followTr (NetworkParameters gp sp _pp) nl DBLayer{..} =
     monitor latestGarbageCollectionEpochRef = do
             let rollForward = forward latestGarbageCollectionEpochRef
 
-            let rollback slot = do
-                    liftIO . atomically $ rollbackTo slot
+            let rollback point = do
+                    liftIO . atomically $ rollbackTo $ pseudoPointSlot point
                     -- The DB will always rollback to the requested slot, so we
                     -- return it.
-                    return $ Right slot
+                    return $ Right point
+
+                -- See NOTE [PointSlotNo]
+                pseudoPointSlot :: ChainPoint -> SlotNo
+                pseudoPointSlot ChainPointAtGenesis = SlotNo 0
+                pseudoPointSlot (ChainPoint slot _) = slot
+
+                toChainPoint :: BlockHeader -> ChainPoint
+                toChainPoint (BlockHeader slot _ h _) = ChainPoint slot h
 
             chainSync nl followTr $ ChainFollower
-                { readLocalTip = initCursor
+                { readLocalTip = map toChainPoint <$> initCursor
                 , rollForward = \tip blocks -> rollForward blocks tip innerTr
                 , rollBackward = fmap (either (error "todo") id) . rollback
                 }
diff --git a/lib/shelley/test/unit/Cardano/Wallet/Shelley/CompatibilitySpec.hs b/lib/shelley/test/unit/Cardano/Wallet/Shelley/CompatibilitySpec.hs
index 6c10310a6f4..df3b62b8cff 100644
--- a/lib/shelley/test/unit/Cardano/Wallet/Shelley/CompatibilitySpec.hs
+++ b/lib/shelley/test/unit/Cardano/Wallet/Shelley/CompatibilitySpec.hs
@@ -89,7 +89,7 @@ import Cardano.Wallet.Shelley.Compatibility
     , invertUnitInterval
     , toCardanoHash
     , toCardanoValue
-    , toPoint
+    , toTip
     , tokenBundleSizeAssessor
     )
 import Cardano.Wallet.Unsafe
@@ -127,7 +127,7 @@ import Data.Word
 import GHC.TypeLits
     ( natVal )
 import Ouroboros.Network.Block
-    ( BlockNo (..), Point, SlotNo (..), Tip (..), getTipPoint )
+    ( BlockNo (..), SlotNo (..), Tip (..) )
 import Test.Hspec
     ( Spec, describe, it, shouldBe, shouldSatisfy )
 import Test.Hspec.Core.Spec
@@ -175,10 +175,10 @@ import qualified Shelley.Spec.Ledger.PParams as SL
 spec :: Spec
 spec = do
     describe "Conversions" $ do
-        it "toPoint' . fromTip' == getTipPoint" $ property $ \gh tip -> do
+        it "toTip' . fromTip' == id" $ property $ \gh tip -> do
             let fromTip' = fromTip gh
-            let toPoint' = toPoint gh :: W.BlockHeader -> Point (CardanoBlock StandardCrypto)
-            toPoint' (fromTip' tip) === (getTipPoint tip)
+            let toTip' = toTip gh :: W.BlockHeader -> Tip (CardanoBlock StandardCrypto)
+            toTip' (fromTip' tip) === tip
 
         it "unsafeIntToWord" $
             property prop_unsafeIntToWord

From 865e7e55450ea80602c4de134d0fe22d9772abf7 Mon Sep 17 00:00:00 2001
From: Heinrich Apfelmus <heinrich.apfelmus@iohk.io>
Date: Thu, 21 Oct 2021 16:26:07 +0200
Subject: [PATCH 05/10] Clean up network logging

* Remove unused messages
* Remove superstitious printing of exceptions in `connectClient`.
* Remove `MsgFollowLog` constructor
---
 lib/core/src/Cardano/Wallet.hs                |  29 +-
 lib/core/src/Cardano/Wallet/Network.hs        | 354 ++++++++----------
 .../Cardano/Wallet/Primitive/SyncProgress.hs  |  35 +-
 .../src/Cardano/Wallet/Primitive/Types.hs     |   4 +
 .../Cardano/Wallet/Primitive/Types/Hash.hs    |   4 +
 .../src/Ouroboros/Network/Client/Wallet.hs    |  92 +++--
 .../test/unit/Cardano/Wallet/NetworkSpec.hs   |  28 +-
 lib/shelley/bench/restore-bench.hs            |   4 +-
 lib/shelley/src/Cardano/Wallet/Shelley.hs     |   9 +-
 .../src/Cardano/Wallet/Shelley/Network.hs     | 101 ++---
 .../src/Cardano/Wallet/Shelley/Pools.hs       |  69 ++--
 11 files changed, 329 insertions(+), 400 deletions(-)

diff --git a/lib/core/src/Cardano/Wallet.hs b/lib/core/src/Cardano/Wallet.hs
index 6ec990068a5..3fe980567ff 100644
--- a/lib/core/src/Cardano/Wallet.hs
+++ b/lib/core/src/Cardano/Wallet.hs
@@ -231,7 +231,11 @@ import Cardano.Wallet.Logging
     , unliftIOTracer
     )
 import Cardano.Wallet.Network
-    ( ChainFollower (..), ErrPostTx (..), FollowLog (..), NetworkLayer (..) )
+    ( ChainFollowLog (..)
+    , ChainFollower (..)
+    , ErrPostTx (..)
+    , NetworkLayer (..)
+    )
 import Cardano.Wallet.Primitive.AddressDerivation
     ( DelegationAddress (..)
     , Depth (..)
@@ -891,20 +895,19 @@ restoreWallet
     -> WalletId
     -> ExceptT ErrNoSuchWallet IO ()
 restoreWallet ctx wid = db & \DBLayer{..} -> do
-    liftIO $ chainSync nw tr' $ ChainFollower
+    liftIO $ chainSync nw (contramap MsgChainFollow tr) $ ChainFollower
         { readLocalTip =
             liftIO $ atomically $ map toChainPoint <$> listCheckpoints wid
-        , rollForward = \tip blocks -> throwInIO $
+        , rollForward = \blocks tip -> throwInIO $
             restoreBlocks @ctx @s @k
-                ctx (contramap MsgFollowLog tr') wid blocks tip
+                ctx (contramap MsgWalletFollow tr) wid blocks tip
         , rollBackward =
             throwInIO . rollbackBlocks @ctx @s @k ctx wid
         }
-    --liftIO $ follow nw tr readCps forward backward RetryOnExceptions (view #header)
   where
     db = ctx ^. dbLayer @IO @s @k
     nw = ctx ^. networkLayer @IO
-    tr' = contramap MsgFollow (ctx ^. logger @WalletWorkerLog)
+    tr = ctx ^. logger @WalletWorkerLog
 
     throwInIO :: ExceptT ErrNoSuchWallet IO a -> IO a
     throwInIO x = runExceptT x >>= \case
@@ -1033,7 +1036,6 @@ restoreBlocks ctx tr wid blocks nodeTip = db & \DBLayer{..} -> mapExceptT atomic
 
     liftIO $ do
         traceWith tr $ MsgDiscoveredTxs txs
-        traceWith tr $ MsgBlocks blocks
         traceWith tr $ MsgDiscoveredTxsContent txs
   where
     nl = ctx ^. networkLayer
@@ -3029,20 +3031,23 @@ guardQuit WalletDelegation{active,next} rewards = do
 -- | Log messages for actions running within a wallet worker context.
 data WalletWorkerLog
     = MsgWallet WalletLog
-    | MsgFollow (FollowLog WalletFollowLog)
+    | MsgWalletFollow WalletFollowLog
+    | MsgChainFollow ChainFollowLog
     deriving (Show, Eq)
 
 instance ToText WalletWorkerLog where
     toText = \case
         MsgWallet msg -> toText msg
-        MsgFollow msg -> toText msg
+        MsgWalletFollow msg -> toText msg
+        MsgChainFollow msg -> toText msg
 
 instance HasPrivacyAnnotation WalletWorkerLog
 
 instance HasSeverityAnnotation WalletWorkerLog where
     getSeverityAnnotation = \case
         MsgWallet msg -> getSeverityAnnotation msg
-        MsgFollow msg -> getSeverityAnnotation msg
+        MsgWalletFollow msg -> getSeverityAnnotation msg
+        MsgChainFollow msg -> getSeverityAnnotation msg
 
 -- | Log messages arising from the restore and follow process.
 data WalletFollowLog
@@ -3050,7 +3055,6 @@ data WalletFollowLog
     | MsgCheckpoint BlockHeader
     | MsgDiscoveredTxs [(Tx, TxMeta)]
     | MsgDiscoveredTxsContent [(Tx, TxMeta)]
-    | MsgBlocks (NonEmpty Block)
     deriving (Show, Eq)
 
 -- | Log messages from API server actions running in a wallet worker context.
@@ -3093,8 +3097,6 @@ instance ToText WalletFollowLog where
             "discovered " <> pretty (length txs) <> " new transaction(s)"
         MsgDiscoveredTxsContent txs ->
             "transactions: " <> pretty (blockListF (snd <$> txs))
-        MsgBlocks blocks ->
-            "blocks: " <> pretty (NE.toList blocks)
 
 instance ToText WalletLog where
     toText = \case
@@ -3139,7 +3141,6 @@ instance HasSeverityAnnotation WalletFollowLog where
         MsgDiscoveredTxs [] -> Debug
         MsgDiscoveredTxs _ -> Info
         MsgDiscoveredTxsContent _ -> Debug
-        MsgBlocks _ -> Debug -- Ideally move to FollowLog or remove
 
 instance HasPrivacyAnnotation WalletLog
 instance HasSeverityAnnotation WalletLog where
diff --git a/lib/core/src/Cardano/Wallet/Network.hs b/lib/core/src/Cardano/Wallet/Network.hs
index a75878b6898..7092a9db485 100644
--- a/lib/core/src/Cardano/Wallet/Network.hs
+++ b/lib/core/src/Cardano/Wallet/Network.hs
@@ -1,6 +1,5 @@
 {-# LANGUAGE AllowAmbiguousTypes #-}
 {-# LANGUAGE DataKinds #-}
-{-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DeriveFunctor #-}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DerivingVia #-}
@@ -8,7 +7,6 @@
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE Rank2Types #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StandaloneDeriving #-}
@@ -25,15 +23,14 @@ module Cardano.Wallet.Network
     -- * Chain following
     , ChainFollower (..)
     , mapChainFollower
-    , FollowLog (..)
+    , ChainFollowLog (..)
     , ChainSyncLog (..)
     , mapChainSyncLog
     , withFollowStatsMonitoring
-    , addFollowerLogging
 
     -- * Logging (for testing)
     , FollowStats (..)
-    , LogState (..)
+    , Rearview (..)
     , emptyStats
     , updateStats
     ) where
@@ -52,7 +49,7 @@ import Cardano.Wallet.Primitive.SyncProgress
     ( SyncProgress (..) )
 import Cardano.Wallet.Primitive.Types
     ( BlockHeader (..)
-    , ChainPoint
+    , ChainPoint (..)
     , ProtocolParameters
     , SlotNo (..)
     , SlottingParameters (..)
@@ -76,8 +73,6 @@ import Data.List.NonEmpty
     ( NonEmpty (..) )
 import Data.Map
     ( Map )
-import Data.Quantity
-    ( Quantity (..) )
 import Data.Set
     ( Set )
 import Data.Text
@@ -103,7 +98,6 @@ import UnliftIO.Concurrent
 
 import qualified Cardano.Api.Shelley as Node
 import qualified Data.List.NonEmpty as NE
-import qualified Data.Text as T
 
 {-------------------------------------------------------------------------------
     ChainSync
@@ -111,12 +105,16 @@ import qualified Data.Text as T
 -- | Interface for network capabilities.
 data NetworkLayer m block = NetworkLayer
     { chainSync
-        :: forall msg. Tracer IO (FollowLog msg)
+        :: Tracer IO ChainFollowLog
         -> ChainFollower m
             ChainPoint
             BlockHeader
             block
         -> m ()
+        -- ^ Connect to the node and run the ChainSync protocol.
+        -- The callbacks provided in the 'ChainFollower' argument
+        -- are used to handle intersection finding,
+        -- the arrival of new blocks, and rollbacks.
 
     , currentNodeTip
         :: m BlockHeader
@@ -193,7 +191,7 @@ data ChainFollower m point tip block = ChainFollower
         -- served from genesis.
         --
         -- TODO: Could be named readCheckpoints?
-    , rollForward :: tip -> NonEmpty block -> m ()
+    , rollForward :: NonEmpty block -> tip -> m ()
         -- ^ Callback for rolling forward.
         --
         -- Implementors _may_ delete old checkpoints while rolling forward.
@@ -246,11 +244,10 @@ mapChainFollower
 mapChainFollower fpoint12 fpoint21 ftip fblock cf =
     ChainFollower
         { readLocalTip = map fpoint12 <$> readLocalTip cf
-        , rollForward = \t bs -> rollForward cf (ftip t) (fmap fblock bs)
+        , rollForward = \bs tip -> rollForward cf (fmap fblock bs) (ftip tip)
         , rollBackward = fmap fpoint12 . rollBackward cf . fpoint21
         }
 
-
 {-------------------------------------------------------------------------------
     Errors
 -------------------------------------------------------------------------------}
@@ -267,11 +264,13 @@ instance ToText ErrPostTx where
     Logging
 -------------------------------------------------------------------------------}
 
-
--- | Low-level logs for chain-sync
+-- | Low-level logs of the ChainSync mini-protocol
 data ChainSyncLog block point
-    = MsgChainRollForward block point
+    = MsgChainFindIntersect [point]
+    | MsgChainRollForward (NonEmpty block) point
     | MsgChainRollBackward point Int
+    | MsgChainTip point
+    | MsgLocalTip point
     | MsgTipDistance Natural
     deriving (Show, Eq, Generic)
 
@@ -281,117 +280,89 @@ mapChainSyncLog
     -> ChainSyncLog b1 p1
     -> ChainSyncLog b2 p2
 mapChainSyncLog f g = \case
-    MsgChainRollForward block point -> MsgChainRollForward (f block) (g point)
+    MsgChainFindIntersect points -> MsgChainFindIntersect (g <$> points)
+    MsgChainRollForward blocks tip ->
+        MsgChainRollForward (f <$> blocks) (g tip)
     MsgChainRollBackward point n -> MsgChainRollBackward (g point) n
+    MsgChainTip point -> MsgChainTip (g point)
+    MsgLocalTip point -> MsgLocalTip (g point)
     MsgTipDistance d -> MsgTipDistance d
 
-instance (ToText block, ToText point)
-    => ToText (ChainSyncLog block point) where
+instance ToText (ChainSyncLog BlockHeader ChainPoint) where
     toText = \case
-        MsgChainRollForward b tip ->
-            "ChainSync roll forward: " <> toText b <> " tip is " <> toText tip
+        MsgChainFindIntersect cps -> mconcat
+            [ "Requesting intersection using "
+            , toText (length cps)
+            , " points"
+            , maybe "" ((", the latest being " <>) . pretty) (lastMay cps)
+            ]
+        MsgChainRollForward headers tip ->
+            let buildRange (x :| []) = x
+                buildRange xs = NE.head xs <> ".." <> NE.last xs
+                slots = pretty . slotNo <$> headers
+            in mconcat
+                [ "ChainSync roll forward: "
+                , "applying blocks at slots [", buildRange slots, "]"
+                , ", tip is "
+                , pretty tip
+                ]
         MsgChainRollBackward b 0 ->
-            "ChainSync roll backward: " <> toText b
+            "ChainSync roll backward: " <> pretty b
         MsgChainRollBackward b bufferSize -> mconcat
             [ "ChainSync roll backward: "
-            , toText b
-            , ", handled inside buffer with remaining length "
+            , pretty b
+            , ", handled inside pipeline buffer with remaining length "
             , toText bufferSize
             ]
-        MsgTipDistance d -> "Tip distance: " <> toText d
+        MsgChainTip tip ->
+            "Node tip is " <> pretty tip
+        MsgLocalTip point ->
+            "Synchronized with point: " <> pretty point
+        MsgTipDistance d -> "Distance to chain tip: " <> toText d <> " blocks"
 
 instance HasPrivacyAnnotation (ChainSyncLog block point)
 
 instance HasSeverityAnnotation (ChainSyncLog block point) where
     getSeverityAnnotation = \case
+        MsgChainFindIntersect{} -> Debug
         MsgChainRollForward{} -> Debug
         MsgChainRollBackward{} -> Debug
+        MsgChainTip{} -> Debug
+        MsgLocalTip{} -> Debug
         MsgTipDistance{} -> Debug
 
-data FollowLog msg
-    = MsgStartFollowing [BlockHeader]
-    | MsgHaltMonitoring
-    | MsgUnhandledException Text
-    | MsgFollowerTip (Maybe BlockHeader)
-    | MsgFollowStats (FollowStats LogState)
-    | MsgApplyBlocks BlockHeader (NonEmpty BlockHeader)
-    | MsgFollowLog msg -- Inner tracer
-    | MsgWillRollback ChainPoint
-    | MsgDidRollback ChainPoint ChainPoint
-    | MsgFailedRollingBack Text -- Reason
-    | MsgWillIgnoreRollback SlotNo Text -- Reason
-    | MsgChainSync (ChainSyncLog Text Text)
+-- | Higher level log of a chain follower.
+-- Includes computed statistics about synchronization progress.
+data ChainFollowLog
+    = MsgChainSync (ChainSyncLog BlockHeader ChainPoint)
+    | MsgFollowStats (FollowStats Rearview)
+    | MsgStartFollowing
     deriving (Show, Eq, Generic)
 
-instance ToText msg => ToText (FollowLog msg) where
+instance ToText ChainFollowLog where
     toText = \case
-        MsgStartFollowing cps -> mconcat
-            [ "Chain following starting. Requesting intersection using "
-            , T.pack . show $ length cps
-            , " checkpoints"
-            , maybe "" ((", the latest being " <>) . pretty) (lastMay cps)
-            ]
-        MsgHaltMonitoring ->
-            "Stopping following as requested."
-        MsgUnhandledException err ->
-            "Unexpected error following the chain: " <> err
-        MsgFollowerTip p -> "Tip" <> pretty p
-        MsgFollowStats s -> toText s
-        MsgApplyBlocks tipHdr hdrs ->
-            let slot = pretty . slotNo
-                buildRange (x :| []) = x
-                buildRange xs = NE.head xs <> ".." <> NE.last xs
-                blockHeights = pretty . getQuantity . blockHeight <$> hdrs
-            in mconcat
-                [ "Applying block numbers [", buildRange blockHeights, "]"
-                , "  Wallet/node slots: ", slot (NE.last hdrs)
-                , "/", slot tipHdr
-                ]
-        MsgWillIgnoreRollback sl reason ->
-            "Will ignore rollback to " <> pretty sl
-                <> " because of " <> pretty reason
-        MsgWillRollback sl ->
-            "Will rollback to " <> pretty sl
-        MsgDidRollback requested actual -> mconcat
-            [ "Did rollback to "
-            , pretty actual
-            , " after request to rollback to "
-            , pretty requested
-            ]
-        MsgFailedRollingBack reason -> "Failed rolling back: " <>
-            reason
-        MsgFollowLog msg -> toText msg
         MsgChainSync msg -> toText msg
+        MsgFollowStats s -> toText s
+        MsgStartFollowing -> "Chain following starting."
 
-instance HasPrivacyAnnotation (FollowLog msg)
-instance HasSeverityAnnotation msg => HasSeverityAnnotation (FollowLog msg) where
+instance HasPrivacyAnnotation ChainFollowLog
+instance HasSeverityAnnotation ChainFollowLog where
     getSeverityAnnotation = \case
-        MsgStartFollowing _ -> Info
-        MsgHaltMonitoring -> Info
-        MsgFollowStats s -> getSeverityAnnotation s
-        MsgFollowerTip _ -> Debug
-        MsgUnhandledException _ -> Error
-        MsgApplyBlocks _ _ -> Debug
-        MsgFollowLog msg -> getSeverityAnnotation msg
-        MsgWillRollback _ -> Debug
-        MsgDidRollback _ _ -> Debug
-        MsgFailedRollingBack _ -> Error
-        MsgWillIgnoreRollback _ _ -> Debug
         MsgChainSync msg -> getSeverityAnnotation msg
+        MsgFollowStats s -> getSeverityAnnotation s
+        MsgStartFollowing -> Info
 
-
---
--- Log aggregation
---
-
+{-------------------------------------------------------------------------------
+    Log aggregation
+-------------------------------------------------------------------------------}
 -- | Statistics of interest from the follow-function.
 --
--- The @f@ allows us to use @LogState@ to keep track of both current and
+-- 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)
-    , tip :: !(f SlotNo)
+    , localTip :: !(f ChainPoint)
     , time :: !(f UTCTime)
       -- ^ NOTE: Current time is not updated until @flush@ is called.
     , prog :: !(f SyncProgress)
@@ -401,109 +372,88 @@ data FollowStats f = FollowStats
 -- It seems UTCTime contains thunks internally. This shouldn't matter as we
 -- 1. Change it seldom - from @flush@, not from @updateStats@
 -- 2. Set to a completely new value when we do change it.
-deriving via (AllowThunksIn '["time"] (FollowStats LogState))
-    instance (NoThunks (FollowStats LogState))
+deriving via (AllowThunksIn '["time"] (FollowStats Rearview))
+    instance (NoThunks (FollowStats Rearview))
 
-deriving instance Show (FollowStats LogState)
-deriving instance Eq (FollowStats LogState)
+deriving instance Show (FollowStats Rearview)
+deriving instance Eq (FollowStats Rearview)
 
 -- | Change the @f@ wrapping each record field.
 hoistStats
     :: (forall a. f a -> g a)
     -> FollowStats f
     -> FollowStats g
-hoistStats f FollowStats{blocksApplied,rollbacks,tip,time,prog} = FollowStats
-    { blocksApplied = f blocksApplied
-    , rollbacks = f rollbacks
-    , tip = f tip
-    , time = f time
-    , prog = f prog
-    }
+hoistStats f (FollowStats a b c d e) =
+    FollowStats (f a) (f b) (f c) (f d) (f e)
 
--- | For keeping track of what we have logged and what we have not.
+-- | A 'Rearview' consists of a past value and a present value.
+-- Useful for keeping track of past logs.
 --
 -- The idea is to
 -- 1. Reconstruct a model of the @current@ @state@ using a @Trace@
 -- 2. Sometimes log the difference between the @current@ state and the most
 -- recently logged one.
-data LogState a = LogState
-    { prev :: !a -- ^ Most previously logged state
+data Rearview a = Rearview
+    { past :: !a -- ^ Most previously logged state
     , current :: !a -- ^ Not-yet logged state
-    } deriving (Eq, Show, Functor, Generic, NoThunks)
+    } deriving (Eq, Show, Functor, Generic)
 
-initLogState :: a -> LogState a
-initLogState a = LogState a a
+instance NoThunks a => NoThunks (Rearview a)
 
--- | Modify the current state of a @LogState state@
-overCurrent :: (a -> a) -> LogState a -> LogState a
-overCurrent f (LogState prev cur) = LogState prev (f cur)
+initRearview :: a -> Rearview a
+initRearview a = Rearview a a
 
--- | /The way/ to log the current stats.
---
--- Returns the current stats from the TMVar, and sets each @prev@ state to
--- @current@ as new value of the @TMVar@.
-flush
-    :: UTCTime
-    -> (SlotNo -> IO SyncProgress)
-    -> StrictTMVar IO (FollowStats LogState)
-    -> IO (FollowStats LogState)
-flush t calcSyncProgress var = do
-    s <- atomically $ takeTMVar var
-    p <- calcSyncProgress (current $ tip s)
-    -- This is where we need to update the time and sync progress
-    let s' = s { time = overCurrent (const t) (time s) }
-               { prog = overCurrent (const p) (prog s) }
-    atomically $ putTMVar var (hoistStats forgetPrev s')
-    return s'
-  where
-    forgetPrev (LogState _prev cur) = LogState cur cur
+-- | Modify the present state of a @Rearview state@
+overCurrent :: (a -> a) -> Rearview a -> Rearview a
+overCurrent f (Rearview pas cur) = Rearview pas (f cur)
 
-emptyStats :: UTCTime -> FollowStats LogState
-emptyStats t = FollowStats (f 0) (f 0) (f $ SlotNo 0) (f t) (f prog)
+emptyStats :: UTCTime -> FollowStats Rearview
+emptyStats t = FollowStats (f 0) (f 0) (f ChainPointAtGenesis) (f t) (f p)
   where
-    f = initLogState
-    prog = NotResponding -- Hijacked as an initial value for simplicity.
+    f = initRearview
+    p = NotResponding -- Hijacked as an initial value for simplicity.
 
-
--- | Update the stats based on a new log message.
-updateStats :: FollowLog msg -> FollowStats LogState -> FollowStats LogState
+-- | Update the current statistics based on a new log message.
+updateStats
+    :: ChainSyncLog block ChainPoint
+    -> FollowStats Rearview -> FollowStats Rearview
 updateStats msg s = case msg of
-    MsgApplyBlocks _tip blocks ->
+    MsgChainRollForward blocks _tip ->
         s { blocksApplied = overCurrent (+ NE.length blocks) (blocksApplied s) }
-    MsgDidRollback _ _ ->
+    MsgChainRollBackward _ 0 ->
+        -- rolled back in a way that could not be handled by the pipeline buffer
         s { rollbacks = overCurrent (1 +) (rollbacks s) }
-    MsgFollowerTip p ->
-        s { tip = overCurrent (const $ slotFromMaybeBh p) (tip s) }
+    MsgLocalTip point ->
+        s { localTip = overCurrent (const point) (localTip s) }
     _ -> s
-  where
-    slotFromMaybeBh = maybe (SlotNo 0) slotNo
 
-instance ToText (FollowStats LogState) where
-    toText st@(FollowStats b r tip t prog) = syncStatus <> " " <> stats <> sevExpl
+instance ToText (FollowStats Rearview) where
+    toText st@(FollowStats b r tip t progress) =
+        syncStatus <> " " <> stats <> sevExpl
       where
-        syncStatus = case prog of
-            LogState NotResponding Ready ->
+        syncStatus = case progress of
+            Rearview NotResponding Ready ->
                 "In sync."
-            LogState Ready Ready ->
+            Rearview Ready Ready ->
                 "Still in sync."
-            LogState NotResponding NotResponding ->
+            Rearview NotResponding NotResponding ->
                 "Still not syncing."
-            LogState (Syncing _p) Ready ->
+            Rearview (Syncing _p) Ready ->
                 "In sync!"
-            LogState Ready (Syncing p) ->
+            Rearview Ready (Syncing p) ->
                 "Fell out of sync (" <> (pretty p) <> ")"
-            LogState _ (Syncing p) ->
+            Rearview _ (Syncing p) ->
                 "Syncing (" <> (pretty p) <> ")"
-            LogState prev NotResponding ->
-                "Not responding. Previously " <> (pretty prev) <> "."
+            Rearview past_ NotResponding ->
+                "Not responding. Previously " <> (pretty past_) <> "."
         stats = mconcat
             [ "Applied " <> pretty (using (-) b) <> " blocks, "
             , pretty (using (-) r) <> " rollbacks "
             , "in the last " <> pretty (using diffUTCTime t) <> ". "
-            , "Currently at slot " <> pretty (current tip) <> "."
+            , "Currently tip is" <> pretty (current tip) <> "."
             ]
           where
-            using f x = f (current x) (prev x)
+            using f x = f (current x) (past x)
 
         sevExpl = maybe
             ""
@@ -516,64 +466,72 @@ instance ToText (FollowStats LogState) where
 -- But this check might be in the wrong place. Might be better to
 -- produce new logs from inside the updateStats function and immeditely
 -- warn there.
-explainedSeverityAnnotation :: FollowStats LogState -> (Severity, Maybe Text)
+explainedSeverityAnnotation :: FollowStats Rearview -> (Severity, Maybe Text)
 explainedSeverityAnnotation s
-        | progressMovedBackwards = (Warning, Just "progress decreased")
-        | noBlocks && notRestored = (Warning, Just "not applying blocks")
-        | nowInSync = (Notice, Nothing)
-        | otherwise = (Info, Nothing)
+    | progressMovedBackwards = (Warning, Just "progress decreased")
+    | noBlocks && notRestored = (Warning, Just "not applying blocks")
+    | nowInSync = (Notice, Nothing)
+    | otherwise = (Info, Nothing)
   where
-    progressMovedBackwards = current (prog s) < prev (prog s)
-    nowInSync = current (prog s) == Ready && prev (prog s) < Ready
+    progressMovedBackwards = current (prog s) < past (prog s)
+    nowInSync = current (prog s) == Ready && past (prog s) < Ready
     notRestored = current (prog s) /= Ready
-    noBlocks = (current (blocksApplied s) - prev (blocksApplied s)) <= 0
+    noBlocks = (current (blocksApplied s) - past (blocksApplied s)) <= 0
 
-
-instance HasSeverityAnnotation (FollowStats LogState) where
+instance HasSeverityAnnotation (FollowStats Rearview) where
     getSeverityAnnotation = fst . explainedSeverityAnnotation
 
-addFollowerLogging
-    :: Monad m
-    => Tracer m (FollowLog msg)
-    -> ChainFollower m ChainPoint BlockHeader block
-    -> ChainFollower m ChainPoint BlockHeader block
-addFollowerLogging tr cf = ChainFollower
-    { readLocalTip = do
-        readLocalTip cf
-    , rollForward = \tip blocks -> do
-        traceWith tr $ MsgApplyBlocks tip (fromBlock <$> blocks)
-        traceWith tr $ MsgFollowerTip (Just tip)
-        rollForward cf tip blocks
-    , rollBackward = \point -> do
-        point' <- rollBackward cf point
-        traceWith tr $ MsgDidRollback point point'
-        pure point'
-    }
+-- | Update the 'TMVar' holding the 'FollowStats'@ @'Rearview'
+-- to forget the 'past' values and replace them with the 'current' ones.
+-- Also update the time and sync process.
+flushStats
+    :: UTCTime
+    -> (SlotNo -> IO SyncProgress)
+    -> StrictTMVar IO (FollowStats Rearview)
+    -> IO (FollowStats Rearview)
+flushStats t calcSyncProgress var = do
+    s <- atomically $ takeTMVar var
+    p <- calcSyncProgress $ pseudoPointSlot $ current $ localTip s
+    let s' = s { time = overCurrent (const t) (time s) }
+               { prog = overCurrent (const p) (prog s) }
+    atomically $ putTMVar var $ hoistStats forgetPast s'
+    return s'
+  where
+    forgetPast (Rearview _past curr) = initRearview curr
 
--- | Starts a new thread for monitoring health and statistics from
--- the returned @FollowLog msg@.
+-- See NOTE [PointSlotNo]
+pseudoPointSlot :: ChainPoint -> SlotNo
+pseudoPointSlot ChainPointAtGenesis = SlotNo 0
+pseudoPointSlot (ChainPoint slot _) = slot
+
+-- | Monitors health and statistics by inspecting the messages
+-- submitted to a 'ChainSyncLog' tracer.
+--
+-- Statistics are computed in regular time intervals.
+-- In order to do that, the monitor runs in separate thread.
+-- The results are submitted to the outer 'ChainFollowLog' tracer.
 withFollowStatsMonitoring
-    :: Tracer IO (FollowLog msg)
+    :: Tracer IO ChainFollowLog
     -> (SlotNo -> IO SyncProgress)
-    -> ((Tracer IO (FollowLog msg)) -> IO ())
+    -> (Tracer IO (ChainSyncLog BlockHeader ChainPoint) -> IO ())
     -> IO ()
 withFollowStatsMonitoring tr calcSyncProgress act = do
-    t0' <- getCurrentTime
-    var <- newTMVarIO $ emptyStats t0'
-    let tr' = flip contramapM tr $ \msg -> do
+    t0  <- getCurrentTime
+    var <- newTMVarIO $ emptyStats t0
+    let trChainSyncLog = flip contramapM tr $ \msg -> do
             atomically $ do
                 s <- takeTMVar var
                 putTMVar var $! updateStats msg s
-            pure msg
-    traceWith tr' $ MsgFollowerTip Nothing
+            pure $ MsgChainSync msg
+    traceWith trChainSyncLog $ MsgLocalTip ChainPointAtGenesis
     race_
-        (act tr')
+        (act trChainSyncLog)
         (loop var startupDelay)
   where
     loop var delay = do
         threadDelay delay
         t <- getCurrentTime
-        s <- flush t calcSyncProgress var
+        s <- flushStats t calcSyncProgress var
         traceWith tr $ MsgFollowStats s
         let delay' =
                 if (current (prog s)) == Ready
diff --git a/lib/core/src/Cardano/Wallet/Primitive/SyncProgress.hs b/lib/core/src/Cardano/Wallet/Primitive/SyncProgress.hs
index 705f623d469..8b980e6d8f7 100644
--- a/lib/core/src/Cardano/Wallet/Primitive/SyncProgress.hs
+++ b/lib/core/src/Cardano/Wallet/Primitive/SyncProgress.hs
@@ -99,27 +99,16 @@ instance FromText SyncTolerance where
 
 -- | Estimate restoration progress based on:
 --
--- - The current local tip
--- - The last slot
+-- - The slot of the latest block consumed (our progress)
+-- - The slot corresponding to the latest wall-clock time (our target)
 --
--- For the sake of this calculation, we are somewhat conflating the definitions
--- of slots and block height. Because we can't reliably _trust_ that the current
--- node is actually itself synced with the network. So, we compute the progress
--- as:
+-- The estimated progress is the quotient of these two quantities.
 --
--- @
--- p = h / (h + X)
--- @
---
--- Where:
---
--- - @h@: the number of blocks we have ingested so far.
--- - @X@: the estimatd remaining slots to reach the network tip.
---
--- Initially, `X` gives a relatively poor estimation of the network height, as
--- it assumes that every next slot will be a block. But, as we ingest blocks,
--- `h` becomes bigger and `X` becomes smaller making the progress estimation
--- better and better. At some point, `X` is null, and we have `p = h / h`
+-- In the Cardano consensus protocol, only a fraction of slots contains blocks.
+-- Hence, the progress percentage will often be < 100%,
+-- as the slot corresponding to the current wall-clock time
+-- may not be filled with a block.
+-- The sync tolerance should be large enough to accomodate this issue.
 syncProgress
     :: (HasCallStack, Monad m)
     => SyncTolerance
@@ -127,12 +116,12 @@ syncProgress
     -> TimeInterpreter m
         -- ^ Converts slots to actual time.
     -> SlotNo
-        -- ^ Slot of local tip
+        -- ^ Slot of latest block consumed
     -> RelativeTime
-        -- ^ Current Time
+        -- ^ Current wall clock time
     -> m SyncProgress
-syncProgress (SyncTolerance tolerance) ti tip now = do
-    timeCovered <- interpretQuery ti $ slotToRelTime tip
+syncProgress (SyncTolerance tolerance) ti slot now = do
+    timeCovered <- interpretQuery ti $ slotToRelTime slot
     let progress
             | now == start = 0
             | otherwise = convert timeCovered % convert now
diff --git a/lib/core/src/Cardano/Wallet/Primitive/Types.hs b/lib/core/src/Cardano/Wallet/Primitive/Types.hs
index b2018720eab..f8c9e73ce4a 100644
--- a/lib/core/src/Cardano/Wallet/Primitive/Types.hs
+++ b/lib/core/src/Cardano/Wallet/Primitive/Types.hs
@@ -251,6 +251,8 @@ import GHC.TypeLits
     ( KnownNat, natVal )
 import Network.URI
     ( URI (..), uriToString )
+import NoThunks.Class
+    ( NoThunks )
 import Numeric.Natural
     ( Natural )
 import Test.QuickCheck
@@ -788,6 +790,8 @@ data ChainPoint
 
 instance NFData ChainPoint
 
+instance NoThunks ChainPoint
+
 instance Buildable ChainPoint where
     build ChainPointAtGenesis    = "[point genesis]"
     build (ChainPoint slot hash) =
diff --git a/lib/core/src/Cardano/Wallet/Primitive/Types/Hash.hs b/lib/core/src/Cardano/Wallet/Primitive/Types/Hash.hs
index e1f5a851a23..e952cbcde2c 100644
--- a/lib/core/src/Cardano/Wallet/Primitive/Types/Hash.hs
+++ b/lib/core/src/Cardano/Wallet/Primitive/Types/Hash.hs
@@ -48,6 +48,8 @@ import GHC.Generics
     ( Generic )
 import GHC.TypeLits
     ( KnownSymbol, Symbol, symbolVal )
+import NoThunks.Class
+    ( NoThunks (..) )
 import Quiet
     ( Quiet (..) )
 
@@ -63,6 +65,8 @@ newtype Hash (tag :: Symbol) = Hash { getHash :: ByteString }
     deriving (Read, Show) via (Quiet (Hash tag))
     deriving anyclass (NFData, Hashable)
 
+instance NoThunks (Hash tag)
+
 instance Buildable (Hash tag) where
     build h = mempty
         <> prefixF 8 builder
diff --git a/lib/core/src/Ouroboros/Network/Client/Wallet.hs b/lib/core/src/Ouroboros/Network/Client/Wallet.hs
index 07e37954a73..593a093455e 100644
--- a/lib/core/src/Ouroboros/Network/Client/Wallet.hs
+++ b/lib/core/src/Ouroboros/Network/Client/Wallet.hs
@@ -86,6 +86,7 @@ import Ouroboros.Network.Block
     , Point (..)
     , Tip (..)
     , blockNo
+    , blockPoint
     , blockSlot
     , castTip
     , getTipPoint
@@ -293,34 +294,34 @@ chainSyncWithBlocks tr chainFollower =
         :: m (P.ClientPipelinedStIdle 'Z block (Point block) (Tip block) m Void)
     clientStNegotiateIntersection = do
         points <- readLocalTip chainFollower
-        if null points
-        then clientStIdle oneByOne
-        else pure $ P.SendMsgFindIntersect
-            points
-            clientStIntersect
-      where
-        clientStIntersect
-            :: P.ClientPipelinedStIntersect block (Point block) (Tip block) m Void
-        clientStIntersect = P.ClientPipelinedStIntersect
-            { recvMsgIntersectFound = \_point _tip -> do
-                -- Here, the node tells us which  point  from the possible
-                -- intersections is the latest point on the chain.
-                -- However, we do not have to roll back to this point here;
-                -- when we send a MsgRequestNext message, the node will reply
-                -- with a MsgRollBackward message to this point first.
-                --
-                -- This behavior is not in the network specification yet, but see
-                -- https://input-output-rnd.slack.com/archives/CDA6LUXAQ/p1623322238039900
-                clientStIdle oneByOne
-
-            , recvMsgIntersectNotFound = \_tip -> do
-                -- Same as above, the node will (usually) reply to us with a
-                -- MsgRollBackward message later (here to the genesis point)
-                --
-                -- There is a weird corner case when the original MsgFindIntersect
-                -- message contains an empty list. See
-                -- https://input-output-rnd.slack.com/archives/CDA6LUXAQ/p1634644689103100
-                clientStIdle oneByOne
+        -- Cave: An empty list is interpreted as requesting the genesis point.
+        let points' = if null points then [Point Origin] else points
+        traceWith tr $ MsgChainFindIntersect points'
+        pure $ P.SendMsgFindIntersect points' clientStIntersect
+
+    -- Receive the result of the MsgFindIntersection request
+    clientStIntersect
+        :: P.ClientPipelinedStIntersect block (Point block) (Tip block) m Void
+    clientStIntersect = P.ClientPipelinedStIntersect
+        { P.recvMsgIntersectFound = \_point tip -> do
+            -- Here, the node tells us which  point  from the possible
+            -- intersections is the latest point on the chain.
+            -- However, we do not have to roll back to this point here;
+            -- when we send a MsgRequestNext message, the node will reply
+            -- with a MsgRollBackward message to this point first.
+            --
+            -- This behavior is not in the network specification yet, but see
+            -- https://input-output-rnd.slack.com/archives/CDA6LUXAQ/p1623322238039900
+            traceWith tr $ MsgChainTip (getTipPoint tip)
+            clientStIdle oneByOne
+        , P.recvMsgIntersectNotFound = \_tip -> do
+            -- No intersection was found.
+            -- As the read-pointer on the node could be unknown to us,
+            -- we now explicitly request the genesis point.
+            --
+            -- See also
+            -- https://input-output-rnd.slack.com/archives/CDA6LUXAQ/p1634644689103100
+            pure clientStIntersect
             }
 
     clientStIdle
@@ -356,9 +357,12 @@ chainSyncWithBlocks tr chainFollower =
         -> P.ClientStNext n block (Point block) (Tip block) m Void
     collectResponses blocks Zero = P.ClientStNext
         { P.recvMsgRollForward = \block tip -> do
-            traceWith tr $ MsgChainRollForward block (getTipPoint tip)
+            traceWith tr $ MsgChainTip (getTipPoint tip)
+
             let blocks' = NE.reverse (block :| blocks)
-            rollForward chainFollower tip blocks'
+            traceWith tr $ MsgChainRollForward blocks' (getTipPoint tip)
+            handleRollforward blocks' tip
+
             let distance = tipDistance (blockNo block) tip
             traceWith tr $ MsgTipDistance distance
             let strategy = if distance <= 1
@@ -367,13 +371,13 @@ chainSyncWithBlocks tr chainFollower =
             clientStIdle strategy
 
         , P.recvMsgRollBackward = \point tip -> do
+            traceWith tr $ MsgChainTip (getTipPoint tip)
             r <- handleRollback blocks point tip
             case r of
                 Buffer xs -> do
-                    traceWith tr $ MsgChainRollBackward point (length xs)
                     case reverse xs of
                         []          -> pure ()
-                        (b:blocks') -> rollForward chainFollower tip (b :| blocks')
+                        (b:blocks') -> handleRollforward (b :| blocks') tip
                     clientStIdle oneByOne
                 FollowerExact ->
                     clientStIdle oneByOne
@@ -386,6 +390,7 @@ chainSyncWithBlocks tr chainFollower =
             pure $ P.CollectResponse Nothing $ collectResponses (block:blocks) n
 
         , P.recvMsgRollBackward = \point tip -> do
+            traceWith tr $ MsgChainTip (getTipPoint tip)
             r <- handleRollback blocks point tip
             pure $ P.CollectResponse Nothing $ case r of
                 Buffer xs -> collectResponses xs n
@@ -393,21 +398,30 @@ chainSyncWithBlocks tr chainFollower =
                 FollowerNeedToReNegotiate -> dropResponsesAndRenegotiate n
         }
 
+    handleRollforward :: NonEmpty block -> Tip block -> m ()
+    handleRollforward blocks tip = do
+        rollForward chainFollower blocks tip
+        traceWith tr $ MsgLocalTip (blockPoint $ NE.last blocks)
+
     handleRollback
         :: [block]
         -> Point block
         -> Tip block
         -> m (LocalRollbackResult block)
-    handleRollback buffer point _tip =
-        case rollbackBuffer point buffer of
+    handleRollback buffer point _tip = do
+        let buffer' = rollbackBuffer point buffer
+        traceWith tr $ MsgChainRollBackward point (length buffer')
+        case buffer' of
             [] -> do
-                traceWith tr $ MsgChainRollBackward point 0
                 actual <- rollBackward chainFollower point
                 if actual == point
-                then pure FollowerExact
-                else do
-                    pure FollowerNeedToReNegotiate
-            xs -> pure $ Buffer xs
+                    then do
+                        traceWith tr $ MsgLocalTip point
+                        pure FollowerExact
+                    else do
+                        pure FollowerNeedToReNegotiate
+            xs -> do
+                pure $ Buffer xs
 
     -- | Discards the in-flight requests, and re-negotiates the intersection
     -- afterwards.
diff --git a/lib/core/test/unit/Cardano/Wallet/NetworkSpec.hs b/lib/core/test/unit/Cardano/Wallet/NetworkSpec.hs
index 2ca89844278..7c2dbe9599a 100644
--- a/lib/core/test/unit/Cardano/Wallet/NetworkSpec.hs
+++ b/lib/core/test/unit/Cardano/Wallet/NetworkSpec.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
@@ -10,9 +11,9 @@ import Prelude
 import Cardano.Wallet.Gen
     ( genBlockHeader, genChainPoint, genSlotNo )
 import Cardano.Wallet.Network
-    ( ErrPostTx (..), FollowLog (..), emptyStats, updateStats )
+    ( ChainSyncLog (..), ErrPostTx (..), emptyStats, updateStats )
 import Cardano.Wallet.Primitive.Types
-    ( BlockHeader (..) )
+    ( BlockHeader (..), ChainPoint (..) )
 import Data.Time.Clock
     ( getCurrentTime )
 import NoThunks.Class
@@ -30,7 +31,8 @@ spec = do
         testShow $ ErrPostTxValidationError mempty
 
     describe "updateStats" $ do
-        it "results in no unexpected thunks" $ property $ \(msg :: FollowLog ()) -> do
+        it "results in no unexpected thunks" $ property $
+          \(msg :: ChainSyncLog () 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.
@@ -43,19 +45,15 @@ spec = do
                 Nothing -> return ()
                 Just x -> expectationFailure $ show x
 
-instance Arbitrary (FollowLog msg) where
+instance Arbitrary block => Arbitrary (ChainSyncLog block ChainPoint) where
     arbitrary = oneof
-      [ MsgApplyBlocks
-          <$> arbitrary
-          <*> ((NE.fromList . getNonEmpty) <$> arbitrary)
-      , MsgDidRollback
-          <$> genChainPoint
-          <*> genChainPoint
-      , MsgFollowerTip . Just
-          <$> arbitrary
-      , pure $ MsgFollowerTip Nothing
-      , pure MsgHaltMonitoring
-      ]
+        [ MsgChainRollForward <$> genNonEmpty <*> genChainPoint
+        , MsgChainRollBackward <$> genChainPoint <*> arbitrary
+        , MsgChainTip <$> genChainPoint
+        , MsgLocalTip <$> genChainPoint
+        ]
+      where
+        genNonEmpty = (NE.fromList . getNonEmpty) <$> arbitrary
   -- Shrinking not that important here
 
 instance Arbitrary BlockHeader where
diff --git a/lib/shelley/bench/restore-bench.hs b/lib/shelley/bench/restore-bench.hs
index aabb6a9d843..2b291d6b367 100644
--- a/lib/shelley/bench/restore-bench.hs
+++ b/lib/shelley/bench/restore-bench.hs
@@ -75,7 +75,7 @@ import Cardano.Wallet.DB.Sqlite
 import Cardano.Wallet.Logging
     ( trMessageText )
 import Cardano.Wallet.Network
-    ( FollowLog (..), NetworkLayer (..) )
+    ( ChainFollowLog (..), ChainSyncLog (..), NetworkLayer (..) )
 import Cardano.Wallet.Primitive.AddressDerivation
     ( Depth (..)
     , NetworkDiscriminant (..)
@@ -695,7 +695,7 @@ dummySeedFromName = SomeMnemonic @24
 
 traceProgressForPlotting :: Tracer IO Text -> Tracer IO WalletWorkerLog
 traceProgressForPlotting tr = Tracer $ \case
-    MsgFollow (MsgApplyBlocks _nodeTip bs) -> do
+    MsgChainFollow (MsgChainSync (MsgChainRollForward bs _nodeTip)) -> do
         let tip = pretty . getQuantity . blockHeight . NE.last $ bs
         time <- pretty . utcTimeToPOSIXSeconds <$> getCurrentTime
         traceWith tr (time <> " " <> tip)
diff --git a/lib/shelley/src/Cardano/Wallet/Shelley.hs b/lib/shelley/src/Cardano/Wallet/Shelley.hs
index 0e04434b804..3e465930348 100644
--- a/lib/shelley/src/Cardano/Wallet/Shelley.hs
+++ b/lib/shelley/src/Cardano/Wallet/Shelley.hs
@@ -77,7 +77,7 @@ import Cardano.Wallet.DB.Sqlite
 import Cardano.Wallet.Logging
     ( trMessageText )
 import Cardano.Wallet.Network
-    ( FollowLog (..), NetworkLayer (..) )
+    ( NetworkLayer (..) )
 import Cardano.Wallet.Primitive.AddressDerivation
     ( DelegationAddress (..)
     , Depth (..)
@@ -359,8 +359,9 @@ serveWallet
 
             let tr = poolsEngineTracer
 
-            void $ forkFinally (monitorStakePools tr np nl db)
-                (traceAfterThread (contramap (MsgFollowLog . MsgExitMonitoring) poolsEngineTracer))
+            void $ forkFinally
+                (monitorStakePools tr np nl db)
+                (traceAfterThread (contramap MsgExitMonitoring tr))
 
             -- fixme: needs to be simplified as part of ADP-634
             let startMetadataThread = forkIOWithUnmask $ \unmask ->
@@ -514,7 +515,7 @@ data Tracers' f = Tracers
     , tokenMetadataTracer :: f TokenMetadataLog
     , walletEngineTracer  :: f WalletEngineLog
     , walletDbTracer      :: f DBFactoryLog
-    , poolsEngineTracer   :: f (FollowLog StakePoolLog)
+    , poolsEngineTracer   :: f StakePoolLog
     , poolsDbTracer       :: f PoolDbLog
     , ntpClientTracer     :: f NtpTrace
     , networkTracer       :: f NetworkLayerLog
diff --git a/lib/shelley/src/Cardano/Wallet/Shelley/Network.hs b/lib/shelley/src/Cardano/Wallet/Shelley/Network.hs
index 27c37df7fee..9fa37bbaba3 100644
--- a/lib/shelley/src/Cardano/Wallet/Shelley/Network.hs
+++ b/lib/shelley/src/Cardano/Wallet/Shelley/Network.hs
@@ -64,11 +64,11 @@ import Cardano.Wallet.Byron.Compatibility
 import Cardano.Wallet.Logging
     ( BracketLog, bracketTracer, produceTimings )
 import Cardano.Wallet.Network
-    ( ChainFollower (..)
+    ( ChainFollowLog (..)
+    , ChainFollower (..)
+    , ChainSyncLog (..)
     , ErrPostTx (..)
-    , FollowLog (..)
     , NetworkLayer (..)
-    , addFollowerLogging
     , mapChainFollower
     , mapChainSyncLog
     , withFollowStatsMonitoring
@@ -86,7 +86,6 @@ import Cardano.Wallet.Primitive.Types.Tx
 import Cardano.Wallet.Shelley.Compatibility
     ( StandardCrypto
     , fromAlonzoPParams
-    , fromCardanoHash
     , fromLedgerPParams
     , fromNonMyopicMemberRewards
     , fromPoint
@@ -166,8 +165,6 @@ import Data.Quantity
     ( Percentage )
 import Data.Set
     ( Set )
-import Data.Text
-    ( Text )
 import Data.Text.Class
     ( ToText (..) )
 import Data.Time.Clock
@@ -207,7 +204,7 @@ import Ouroboros.Consensus.Node.NetworkProtocolVersion
 import Ouroboros.Consensus.Shelley.Ledger.Config
     ( CodecConfig (..), getCompactGenesis )
 import Ouroboros.Network.Block
-    ( Point, Tip (..), blockPoint, getPoint )
+    ( Point, Tip (..) )
 import Ouroboros.Network.Client.Wallet
     ( LSQ (..)
     , LocalStateQueryCmd (..)
@@ -238,8 +235,6 @@ import Ouroboros.Network.NodeToClient
     , nodeToClientProtocols
     , withIOManager
     )
-import Ouroboros.Network.Point
-    ( WithOrigin (..) )
 import Ouroboros.Network.Protocol.ChainSync.Client
     ( chainSyncClientPeer )
 import Ouroboros.Network.Protocol.ChainSync.ClientPipelined
@@ -271,7 +266,6 @@ import qualified Cardano.Ledger.Crypto as SL
 import qualified Cardano.Wallet.Primitive.SyncProgress as SyncProgress
 import qualified Cardano.Wallet.Primitive.Types as W
 import qualified Cardano.Wallet.Primitive.Types.Coin as W
-import qualified Cardano.Wallet.Primitive.Types.Hash as W
 import qualified Cardano.Wallet.Primitive.Types.RewardAccount as W
 import qualified Cardano.Wallet.Primitive.Types.Tx as W
 import qualified Codec.CBOR.Term as CBOR
@@ -280,7 +274,6 @@ import qualified Data.Set as Set
 import qualified Data.Text as T
 import qualified Ouroboros.Consensus.Byron.Ledger as Byron
 import qualified Ouroboros.Consensus.Shelley.Ledger as Shelley
-import qualified Ouroboros.Network.Point as Point
 import qualified Shelley.Spec.Ledger.API as SL
 import qualified Shelley.Spec.Ledger.LedgerState as SL
 
@@ -346,22 +339,23 @@ withNetworkLayerBase tr net np conn versionData tol action = do
     let readCurrentNodeEra = atomically $ readTMVar eraVar
 
     action $ NetworkLayer
-        { chainSync = \followTr' follower -> do
+        { chainSync = \trFollowLog follower -> do
             let withStats = withFollowStatsMonitoring
-                    followTr'
+                    trFollowLog
                     (_syncProgress interpreterVar)
-            withStats $ \followTr -> do
-                let addLogging =
-                        addFollowerLogging followTr (toCardanoBlockHeader gp)
-                client <- mkWalletClient
-                    followTr
-                    (mapChainFollower
-                        toPoint
-                        fromPoint
-                        (fromTip' gp)
-                        id
-                        (addLogging follower))
-                    cfg
+            withStats $ \trChainSyncLog -> do
+                let mapB = toCardanoBlockHeader gp
+                    mapP = fromPoint
+                let client = mkWalletClient
+                        (contramap (mapChainSyncLog mapB mapP) trChainSyncLog)
+                        (mapChainFollower
+                            toPoint
+                            fromPoint
+                            (fromTip' gp)
+                            id
+                            follower)
+                        cfg
+                traceWith trFollowLog MsgStartFollowing
                 connectClient tr handlers client versionData conn
 
         , currentNodeTip =
@@ -593,23 +587,20 @@ type NetworkClient m = NodeToClientVersion -> OuroborosApplication
 -- | Construct a network client with the given communication channel, for the
 -- purposes of syncing blocks to a single wallet.
 mkWalletClient
-    :: forall m msg. (MonadThrow m, MonadST m, MonadTimer m, MonadAsync m)
-    => Tracer m (FollowLog msg)
-    -> ChainFollower m
-        (Point (CardanoBlock StandardCrypto))
-        (Tip (CardanoBlock StandardCrypto))
-        (CardanoBlock StandardCrypto)
-    -> CodecConfig (CardanoBlock StandardCrypto)
-    -> m (NetworkClient m)
-mkWalletClient tr follower cfg = do
-    pure $ \v -> nodeToClientProtocols (const $ return $ NodeToClientProtocols
+    :: forall m block
+    . ( block ~ CardanoBlock (StandardCrypto)
+      , MonadThrow m, MonadST m, MonadTimer m, MonadAsync m)
+    => Tracer m (ChainSyncLog block (Point block))
+    -> ChainFollower m (Point block) (Tip block) block
+    -> CodecConfig block
+    -> NetworkClient m
+mkWalletClient tr follower cfg v =
+    nodeToClientProtocols (const $ return $ NodeToClientProtocols
         { localChainSyncProtocol =
             InitiatorProtocolOnly $ MuxPeerRaw $ \channel ->
                 runPipelinedPeer nullTracer (cChainSyncCodec $ codecs v cfg) channel
                 $ chainSyncClientPeerPipelined
-                $ chainSyncWithBlocks
-                    (contramap (MsgChainSync . mapChainSyncLog showB showP) tr)
-                    follower
+                $ chainSyncWithBlocks tr follower
 
         , localTxSubmissionProtocol =
             doNothingProtocol
@@ -617,20 +608,6 @@ mkWalletClient tr follower cfg = do
         , localStateQueryProtocol =
             doNothingProtocol
         }) v
-  where
-    showB :: CardanoBlock StandardCrypto -> Text
-    showB = showP . blockPoint
-
-    showP :: Point (CardanoBlock StandardCrypto) -> Text
-    showP p = case (getPoint p) of
-        Origin -> "Origin"
-        At blk -> mconcat
-            [ "(slotNo "
-            , T.pack $ show $ unSlotNo $ Point.blockPointSlot blk
-            , ", "
-            , pretty $ fromCardanoHash $ Point.blockPointHash blk
-            , ")"
-            ]
 
 -- | Construct a network client with the given communication channel, for the
 -- purposes of querying delegations and rewards.
@@ -1011,9 +988,8 @@ connectClient tr handlers client vData conn = withIOManager $ \iocp -> do
             , nctHandshakeTracer = contramap MsgHandshakeTracer tr
             }
     let socket = localSnocket iocp (nodeSocketFile conn)
-    flip withException (print @SomeException) $
-        recoveringNodeConnection tr handlers $
-            connectTo socket tracers versions (nodeSocketFile conn)
+    recoveringNodeConnection tr handlers $
+        connectTo socket tracers versions (nodeSocketFile conn)
 
 recoveringNodeConnection
     :: Tracer IO NetworkLayerLog
@@ -1170,9 +1146,6 @@ data NetworkLayerLog where
         -> NetworkLayerLog
     MsgHandshakeTracer ::
       (WithMuxBearer (ConnectionId LocalAddress) HandshakeTrace) -> NetworkLayerLog
-    MsgFindIntersection :: [W.BlockHeader] -> NetworkLayerLog
-    MsgIntersectionFound :: (W.Hash "BlockHeader") -> NetworkLayerLog
-    MsgFindIntersectionTimeout :: NetworkLayerLog
     MsgPostTx :: W.SealedTx -> NetworkLayerLog
     MsgNodeTip :: W.BlockHeader -> NetworkLayerLog
     MsgProtocolParameters :: W.ProtocolParameters -> W.SlottingParameters -> NetworkLayerLog
@@ -1224,14 +1197,6 @@ instance ToText NetworkLayerLog where
             T.pack (show msg)
         MsgHandshakeTracer (WithMuxBearer conn h) ->
             pretty conn <> " " <> T.pack (show h)
-        MsgFindIntersectionTimeout ->
-            "Couldn't find an intersection in a timely manner. Retrying..."
-        MsgFindIntersection points -> T.unwords
-            [ "Looking for an intersection with the node's local chain with:"
-            , T.intercalate ", " (pretty <$> points)
-            ]
-        MsgIntersectionFound point -> T.unwords
-            [ "Intersection found:", pretty point ]
         MsgPostTx tx ->
             "Posting transaction, serialized as:\n"+|hexF (serialisedTx tx)|+""
         MsgLocalStateQuery client msg ->
@@ -1300,10 +1265,6 @@ instance HasSeverityAnnotation NetworkLayerLog where
         MsgConnectionLost{}                -> Warning
         MsgTxSubmission{}                  -> Info
         MsgHandshakeTracer{}               -> Debug
-        MsgFindIntersectionTimeout         -> Warning
-        MsgFindIntersection{}              -> Debug
-        -- MsgFindIntersection is duplicated by MsgStartFollowing
-        MsgIntersectionFound{}             -> Debug
         MsgPostTx{}                        -> Debug
         MsgLocalStateQuery{}               -> Debug
         MsgNodeTip{}                       -> Debug
diff --git a/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs b/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs
index 0782acb8755..9ccbd877b4f 100644
--- a/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs
+++ b/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs
@@ -59,7 +59,7 @@ import Cardano.Wallet.Api.Types
 import Cardano.Wallet.Byron.Compatibility
     ( toByronBlockHeader )
 import Cardano.Wallet.Network
-    ( ChainFollower (..), FollowLog (..), NetworkLayer (..) )
+    ( ChainFollowLog (..), ChainFollower (..), NetworkLayer (..) )
 import Cardano.Wallet.Primitive.Slotting
     ( PastHorizonException (..)
     , TimeInterpreter
@@ -527,38 +527,36 @@ readPoolDbData DBLayer {..} currentEpoch = atomically $ do
 --
 
 monitorStakePools
-    :: Tracer IO (FollowLog StakePoolLog)
+    :: Tracer IO StakePoolLog
     -> NetworkParameters
     -> NetworkLayer IO (CardanoBlock StandardCrypto)
     -> DBLayer IO
     -> IO ()
-monitorStakePools followTr (NetworkParameters gp sp _pp) nl DBLayer{..} =
+monitorStakePools tr (NetworkParameters gp sp _pp) nl DBLayer{..} =
     monitor =<< mkLatestGarbageCollectionEpochRef
   where
-    innerTr = contramap MsgFollowLog followTr
-
     monitor latestGarbageCollectionEpochRef = do
-            let rollForward = forward latestGarbageCollectionEpochRef
-
-            let rollback point = do
-                    liftIO . atomically $ rollbackTo $ pseudoPointSlot point
-                    -- The DB will always rollback to the requested slot, so we
-                    -- return it.
-                    return $ Right point
-
-                -- See NOTE [PointSlotNo]
-                pseudoPointSlot :: ChainPoint -> SlotNo
-                pseudoPointSlot ChainPointAtGenesis = SlotNo 0
-                pseudoPointSlot (ChainPoint slot _) = slot
-
-                toChainPoint :: BlockHeader -> ChainPoint
-                toChainPoint (BlockHeader slot _ h _) = ChainPoint slot h
-
-            chainSync nl followTr $ ChainFollower
-                { readLocalTip = map toChainPoint <$> initCursor
-                , rollForward = \tip blocks -> rollForward blocks tip innerTr
-                , rollBackward = fmap (either (error "todo") id) . rollback
-                }
+        let rollForward = forward latestGarbageCollectionEpochRef
+
+        let rollback point = do
+                liftIO . atomically $ rollbackTo $ pseudoPointSlot point
+                -- The DB will always rollback to the requested slot, so we
+                -- return it.
+                return point
+
+            -- See NOTE [PointSlotNo]
+            pseudoPointSlot :: ChainPoint -> SlotNo
+            pseudoPointSlot ChainPointAtGenesis = SlotNo 0
+            pseudoPointSlot (ChainPoint slot _) = slot
+
+            toChainPoint :: BlockHeader -> ChainPoint
+            toChainPoint (BlockHeader slot _ h _) = ChainPoint slot h
+
+        chainSync nl (contramap MsgChainMonitoring tr) $ ChainFollower
+            { readLocalTip = map toChainPoint <$> initCursor
+            , rollForward  = rollForward
+            , rollBackward = rollback
+            }
 
     GenesisParameters  { getGenesisBlockHash  } = gp
     SlottingParameters { getSecurityParameter } = sp
@@ -583,9 +581,8 @@ monitorStakePools followTr (NetworkParameters gp sp _pp) nl DBLayer{..} =
         :: IORef EpochNo
         -> NonEmpty (CardanoBlock StandardCrypto)
         -> BlockHeader
-        -> Tracer IO StakePoolLog
         -> IO ()
-    forward latestGarbageCollectionEpochRef blocks _ tr = do
+    forward latestGarbageCollectionEpochRef blocks _ = do
         atomically $ forAllAndLastM blocks forAllBlocks forLastBlock
       where
         forAllBlocks = \case
@@ -616,8 +613,8 @@ monitorStakePools followTr (NetworkParameters gp sp _pp) nl DBLayer{..} =
             let header = view #header blk
             let slot = view #slotNo header
             handleErr (putPoolProduction header poolId)
-            garbageCollectPools slot latestGarbageCollectionEpochRef tr
-            putPoolCertificates slot certificates tr
+            garbageCollectPools slot latestGarbageCollectionEpochRef
+            putPoolCertificates slot certificates
 
         handleErr action = runExceptT action
             >>= \case
@@ -664,7 +661,7 @@ monitorStakePools followTr (NetworkParameters gp sp _pp) nl DBLayer{..} =
     -- that occurred two epochs ago that has not subsquently been superseded,
     -- it should be safe to garbage collect that pool.
     --
-    garbageCollectPools currentSlot latestGarbageCollectionEpochRef tr = do
+    garbageCollectPools currentSlot latestGarbageCollectionEpochRef = do
         let ti = timeInterpreter nl
         liftIO (runExceptT (interpretQuery ti (epochOf currentSlot))) >>= \case
             Left _ -> return ()
@@ -694,7 +691,7 @@ monitorStakePools followTr (NetworkParameters gp sp _pp) nl DBLayer{..} =
     --
     -- Precedence is determined by the 'readPoolLifeCycleStatus' function.
     --
-    putPoolCertificates slot certificates tr = do
+    putPoolCertificates slot certificates = do
         let publicationTimes =
                 CertificatePublicationTime slot <$> [minBound ..]
         forM_ (publicationTimes `zip` certificates) $ \case
@@ -709,11 +706,11 @@ monitorStakePools followTr (NetworkParameters gp sp _pp) nl DBLayer{..} =
 -- | Worker thread that monitors pool metadata and syncs it to the database.
 monitorMetadata
     :: TVar PoolMetadataGCStatus
-    -> Tracer IO (FollowLog StakePoolLog)
+    -> Tracer IO StakePoolLog
     -> SlottingParameters
     -> DBLayer IO
     -> IO ()
-monitorMetadata gcStatus tr' sp db@(DBLayer{..}) = do
+monitorMetadata gcStatus tr sp db@(DBLayer{..}) = do
     settings <- atomically readSettings
     manager <- newManager defaultManagerSettings
 
@@ -757,7 +754,6 @@ monitorMetadata gcStatus tr' sp db@(DBLayer{..}) = do
         | otherwise ->
             traceWith tr MsgSMASHUnreachable
   where
-    tr = contramap MsgFollowLog tr'
     trFetch = contramap MsgFetchPoolMetadata tr
 
     fetchMetadata
@@ -844,6 +840,7 @@ gcDelistedPools gcStatus tr DBLayer{..} fetchDelisted = forever $ do
 
 data StakePoolLog
     = MsgExitMonitoring AfterThreadLog
+    | MsgChainMonitoring ChainFollowLog
     | MsgStakePoolGarbageCollection PoolGarbageCollectionInfo
     | MsgStakePoolRegistration PoolRegistrationCertificate
     | MsgStakePoolRetirement PoolRetirementCertificate
@@ -870,6 +867,7 @@ instance HasPrivacyAnnotation StakePoolLog
 instance HasSeverityAnnotation StakePoolLog where
     getSeverityAnnotation = \case
         MsgExitMonitoring msg -> getSeverityAnnotation msg
+        MsgChainMonitoring msg -> getSeverityAnnotation msg
         MsgStakePoolGarbageCollection{} -> Debug
         MsgStakePoolRegistration{} -> Debug
         MsgStakePoolRetirement{} -> Debug
@@ -884,6 +882,7 @@ instance ToText StakePoolLog where
     toText = \case
         MsgExitMonitoring msg ->
             "Stake pool monitor exit: " <> toText msg
+        MsgChainMonitoring msg -> toText msg
         MsgStakePoolGarbageCollection info -> mconcat
             [ "Performing garbage collection of retired stake pools. "
             , "Currently in epoch "

From b1c8badf372b61bb126a32019058775308909a61 Mon Sep 17 00:00:00 2001
From: Heinrich Apfelmus <heinrich.apfelmus@iohk.io>
Date: Tue, 19 Oct 2021 17:23:40 +0200
Subject: [PATCH 06/10] Handle the genesis point explicitly

* Check whether the block we want to rollback to is the genesis block, use that in `ChainPoint`.
* Request genesis explicitly when `MsgIntersectNotFound`. This ensures that the /read-pointer/ on the block producer side points to genesis, avoiding a weird corner case.
---
 lib/core/src/Cardano/Wallet.hs                | 33 ++++++++++++-------
 lib/core/src/Cardano/Wallet/Network.hs        |  2 +-
 .../src/Ouroboros/Network/Client/Wallet.hs    | 31 ++++++++++++++---
 .../unit/Cardano/Wallet/DB/StateMachine.hs    |  2 +-
 .../src/Cardano/Wallet/Shelley/Pools.hs       |  3 +-
 5 files changed, 53 insertions(+), 18 deletions(-)

diff --git a/lib/core/src/Cardano/Wallet.hs b/lib/core/src/Cardano/Wallet.hs
index 3fe980567ff..6c3fcdce9ac 100644
--- a/lib/core/src/Cardano/Wallet.hs
+++ b/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] 
 
diff --git a/lib/core/src/Cardano/Wallet/Network.hs b/lib/core/src/Cardano/Wallet/Network.hs
index 7092a9db485..91dec73965a 100644
--- a/lib/core/src/Cardano/Wallet/Network.hs
+++ b/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)
diff --git a/lib/core/src/Ouroboros/Network/Client/Wallet.hs b/lib/core/src/Ouroboros/Network/Client/Wallet.hs
index 593a093455e..b6822857bda 100644
--- a/lib/core/src/Ouroboros/Network/Client/Wallet.hs
+++ b/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
diff --git a/lib/core/test/unit/Cardano/Wallet/DB/StateMachine.hs b/lib/core/test/unit/Cardano/Wallet/DB/StateMachine.hs
index 71ddca66e8a..4435891604d 100644
--- a/lib/core/test/unit/Cardano/Wallet/DB/StateMachine.hs
+++ b/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
diff --git a/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs b/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs
index 9ccbd877b4f..2480090ebff 100644
--- a/lib/shelley/src/Cardano/Wallet/Shelley/Pools.hs
+++ b/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

From b89234c085e10e0e62150157f58f85f3fd68d901 Mon Sep 17 00:00:00 2001
From: Heinrich Apfelmus <heinrich.apfelmus@iohk.io>
Date: Thu, 28 Oct 2021 17:43:58 +0200
Subject: [PATCH 07/10] Sort chain points before requesting intersection
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

… so that the wallet does not sync from the origin anymore. ><
---
 lib/core/src/Cardano/Wallet/Network.hs           |  4 ++--
 lib/core/src/Cardano/Wallet/Primitive/Types.hs   | 14 +++++++++++++-
 lib/core/src/Ouroboros/Network/Client/Wallet.hs  | 16 +++++++++++++++-
 .../src/Cardano/Wallet/Shelley/Network.hs        |  2 +-
 4 files changed, 31 insertions(+), 5 deletions(-)

diff --git a/lib/core/src/Cardano/Wallet/Network.hs b/lib/core/src/Cardano/Wallet/Network.hs
index 91dec73965a..134a4a70f12 100644
--- a/lib/core/src/Cardano/Wallet/Network.hs
+++ b/lib/core/src/Cardano/Wallet/Network.hs
@@ -90,7 +90,7 @@ import NoThunks.Class
 import Numeric.Natural
     ( Natural )
 import Safe
-    ( lastMay )
+    ( headMay )
 import UnliftIO.Async
     ( race_ )
 import UnliftIO.Concurrent
@@ -294,7 +294,7 @@ instance ToText (ChainSyncLog BlockHeader ChainPoint) where
             [ "Requesting intersection using "
             , toText (length cps)
             , " points"
-            , maybe "" ((", the latest being " <>) . pretty) (lastMay cps)
+            , maybe "" ((", the latest being " <>) . pretty) (headMay cps)
             ]
         MsgChainRollForward headers tip ->
             let buildRange (x :| []) = x
diff --git a/lib/core/src/Cardano/Wallet/Primitive/Types.hs b/lib/core/src/Cardano/Wallet/Primitive/Types.hs
index f8c9e73ce4a..20517e7e0fe 100644
--- a/lib/core/src/Cardano/Wallet/Primitive/Types.hs
+++ b/lib/core/src/Cardano/Wallet/Primitive/Types.hs
@@ -36,6 +36,7 @@ module Cardano.Wallet.Primitive.Types
       Block(..)
     , BlockHeader(..)
     , ChainPoint (..)
+    , compareSlot
 
     -- * Delegation and stake pools
     , CertificatePublicationTime (..)
@@ -786,7 +787,18 @@ instance Buildable (Block) where
 data ChainPoint
     = ChainPointAtGenesis
     | ChainPoint !SlotNo !(Hash "BlockHeader")
-    deriving (Eq, Show, Generic)
+    deriving (Eq, Ord, Show, Generic)
+
+-- | Compare the slot numbers of two 'ChainPoint's,
+-- but where the 'ChainPointAtGenesis' comes before all natural slot numbers.
+--
+-- Note: The 'Ord' instance of 'ChainPoint' is more fine-grained and
+-- also compares block hashes.
+compareSlot :: ChainPoint -> ChainPoint -> Ordering
+compareSlot ChainPointAtGenesis ChainPointAtGenesis = EQ
+compareSlot ChainPointAtGenesis _ = LT
+compareSlot _ ChainPointAtGenesis = GT
+compareSlot (ChainPoint sl1 _) (ChainPoint sl2 _) = compare sl1 sl2
 
 instance NFData ChainPoint
 
diff --git a/lib/core/src/Ouroboros/Network/Client/Wallet.hs b/lib/core/src/Ouroboros/Network/Client/Wallet.hs
index b6822857bda..d21aea146bd 100644
--- a/lib/core/src/Ouroboros/Network/Client/Wallet.hs
+++ b/lib/core/src/Ouroboros/Network/Client/Wallet.hs
@@ -68,8 +68,12 @@ import Data.Functor
     ( (<&>) )
 import Data.Kind
     ( Type )
+import Data.List
+    ( sortBy )
 import Data.List.NonEmpty
     ( NonEmpty (..) )
+import Data.Ord
+    ( comparing )
 import Data.Void
     ( Void )
 import Network.TypedProtocol.Pipelined
@@ -92,6 +96,8 @@ import Ouroboros.Network.Block
     , getTipPoint
     , pointSlot
     )
+import Ouroboros.Network.Point
+    ( blockPointSlot )
 import Ouroboros.Network.Protocol.ChainSync.Client
     ( ChainSyncClient (..)
     , ClientStIdle (..)
@@ -294,7 +300,9 @@ chainSyncWithBlocks tr chainFollower =
     clientStNegotiateIntersection = do
         points <- readLocalTip chainFollower
         -- Cave: An empty list is interpreted as requesting the genesis point.
-        let points' = if null points then [Point Origin] else points
+        let points' = if null points
+                then [Point Origin]
+                else sortBy (flip compareSlot) points -- older points last
         traceWith tr $ MsgChainFindIntersect points'
         pure $ P.SendMsgFindIntersect points' clientStIntersect
 
@@ -454,6 +462,12 @@ chainSyncWithBlocks tr chainFollower =
                 clientStNegotiateIntersection
             }
 
+compareSlot :: Point block -> Point block -> Ordering
+compareSlot (Point Origin) (Point Origin) = EQ
+compareSlot (Point Origin) _ = LT
+compareSlot _ (Point Origin) = GT
+compareSlot (Point (At b1)) (Point (At b2)) = comparing blockPointSlot b1 b2
+
 --------------------------------------------------------------------------------
 --
 -- LocalStateQuery
diff --git a/lib/shelley/src/Cardano/Wallet/Shelley/Network.hs b/lib/shelley/src/Cardano/Wallet/Shelley/Network.hs
index 9fa37bbaba3..439a6878387 100644
--- a/lib/shelley/src/Cardano/Wallet/Shelley/Network.hs
+++ b/lib/shelley/src/Cardano/Wallet/Shelley/Network.hs
@@ -256,7 +256,7 @@ import UnliftIO.Compat
 import UnliftIO.Concurrent
     ( ThreadId )
 import UnliftIO.Exception
-    ( Handler (..), IOException, SomeException, withException )
+    ( Handler (..), IOException )
 
 import qualified Cardano.Api as Cardano
 import qualified Cardano.Api.Shelley as Cardano

From 61e958c8b2500e7bb5b9f97ea0c486287a912415 Mon Sep 17 00:00:00 2001
From: Heinrich Apfelmus <heinrich.apfelmus@iohk.io>
Date: Wed, 20 Oct 2021 13:46:47 +0200
Subject: [PATCH 08/10] Discuss [CheckedExceptionsAndCallbacks]

---
 lib/core/src/Cardano/Wallet.hs                | 45 +++++++++++++++++--
 lib/core/src/Cardano/Wallet/DB.hs             |  4 --
 .../src/Cardano/Wallet/Shelley/Network.hs     | 18 ++++++--
 3 files changed, 57 insertions(+), 10 deletions(-)

diff --git a/lib/core/src/Cardano/Wallet.hs b/lib/core/src/Cardano/Wallet.hs
index 6c3fcdce9ac..27f0ccecf30 100644
--- a/lib/core/src/Cardano/Wallet.hs
+++ b/lib/core/src/Cardano/Wallet.hs
@@ -531,7 +531,7 @@ import Statistics.Quantile
 import Type.Reflection
     ( Typeable, typeRep )
 import UnliftIO.Exception
-    ( Exception, throwIO )
+    ( Exception, catch, throwIO )
 import UnliftIO.MVar
     ( modifyMVar_, newMVar )
 
@@ -896,7 +896,7 @@ restoreWallet
     -> WalletId
     -> ExceptT ErrNoSuchWallet IO ()
 restoreWallet ctx wid = db & \DBLayer{..} -> do
-    liftIO $ chainSync nw (contramap MsgChainFollow tr) $ ChainFollower
+    catchFromIO $ chainSync nw (contramap MsgChainFollow tr) $ ChainFollower
         { readLocalTip = liftIO $ atomically $
             map (toChainPoint block0) <$> listCheckpoints wid
         , rollForward = \blocks tip -> throwInIO $
@@ -911,10 +911,49 @@ restoreWallet ctx wid = db & \DBLayer{..} -> do
     tr = ctx ^. logger @WalletWorkerLog
     (block0, _, _) = ctx ^. genesisData
 
+    -- See Note [CheckedExceptionsAndCallbacks]
     throwInIO :: ExceptT ErrNoSuchWallet IO a -> IO a
     throwInIO x = runExceptT x >>= \case
         Right a -> pure a
-        Left e -> throwIO e
+        Left  e -> throwIO $ UncheckErrNoSuchWallet e
+
+    catchFromIO :: IO a -> ExceptT ErrNoSuchWallet IO a
+    catchFromIO m = ExceptT $
+        (Right <$> m) `catch` (\(UncheckErrNoSuchWallet e) -> pure $ Left e)
+
+newtype UncheckErrNoSuchWallet = UncheckErrNoSuchWallet ErrNoSuchWallet
+    deriving (Eq, Show)
+instance Exception UncheckErrNoSuchWallet
+
+{- NOTE [CheckedExceptionsAndCallbacks]
+
+Callback functions (such as the fields of 'ChainFollower')
+may throw exceptions. Such exceptions typically cause the thread
+(such as 'chainSync') which calls the callbacks to exit and
+to return control to its parent.
+
+Ideally, we would like these exceptions to be \"checked exceptions\",
+which means that they are visible on the type level.
+In our codebase, we (should) make sure that exceptions which are checked
+cannot be instances of the 'Exception' class -- in this way,
+it is statically guaranteed that they cannot be thrown in the 'IO' monad.
+
+On the flip side, visibility on the type level does imply that
+the calling thread (here 'chainSync') needs to be either polymorphic
+in the checked exceptions or aware of them.
+Making 'chainSync' aware of the checked exception is currently
+not a good idea, because this function is used in different contexts,
+which have different checked exceptions.
+So, it would need to be polymorophic in the the undelrying monad,
+but at present, 'chainSync' is restricted to 'IO' beause some
+of its constituents are also restricted to 'IO'.
+
+As a workaround / solution, we wrap the checked exception into a new type
+which can be thrown in the 'IO' monad.
+When the calling thread exits, we catch the exception again
+and present it as a checked exception.
+
+-}
 
 -- | 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.
diff --git a/lib/core/src/Cardano/Wallet/DB.hs b/lib/core/src/Cardano/Wallet/DB.hs
index 9a135188a31..5fd4c08bde4 100644
--- a/lib/core/src/Cardano/Wallet/DB.hs
+++ b/lib/core/src/Cardano/Wallet/DB.hs
@@ -63,8 +63,6 @@ import Cardano.Wallet.Primitive.Types.Tx
     , TxMeta
     , TxStatus
     )
-import Control.Exception
-    ( Exception )
 import Control.Monad.IO.Class
     ( MonadIO )
 import Control.Monad.Trans.Except
@@ -331,8 +329,6 @@ newtype ErrNoSuchWallet
     = ErrNoSuchWallet WalletId -- Wallet is gone or doesn't exist yet
     deriving (Eq, Show)
 
-instance Exception ErrNoSuchWallet
-
 -- | Can't add a transaction to the local tx submission pool.
 data ErrPutLocalTxSubmission
     = ErrPutLocalTxSubmissionNoSuchWallet ErrNoSuchWallet
diff --git a/lib/shelley/src/Cardano/Wallet/Shelley/Network.hs b/lib/shelley/src/Cardano/Wallet/Shelley/Network.hs
index 439a6878387..240cc43d1c4 100644
--- a/lib/shelley/src/Cardano/Wallet/Shelley/Network.hs
+++ b/lib/shelley/src/Cardano/Wallet/Shelley/Network.hs
@@ -954,9 +954,21 @@ serialisedCodecs nodeToClientVersion cfg =
 -------------------------------------------------------------------------------}
 -- | Construct a network client with the given protocols.
 --
--- FIXME: This functions overlaps with 'connectClient'.
--- However, it is more modern in that is uses 'Cardano.Api'.
--- We may or may not want to switch 'Cardano.Api' in the future.
+-- TODO: This functions overlaps with 'connectClient'.
+-- However, it is more modern in that it uses "Cardano.Api".
+--
+-- Do we want to switch to "Cardano.Api" for the NodeToClient protocols?
+--
+-- Cons:
+--
+-- * "Cardano.Api" is not polymorphic in the underlying monad.
+-- But in order to use /checked exception/ in the client monad,
+-- we would need the 'connectToLocalNode' function to be polymorphic
+-- in the monad (and therefore also in the exceptions).
+--
+-- Pro:
+--
+-- * "Cardano.Api" is simpler in that it does not require so much plumbing.
 connectCardanoApiClient
     :: Tracer IO NetworkLayerLog
         -- ^ Base trace for underlying protocols

From 2fbafa1b429e68f4750b98050fb4aa02750c373e Mon Sep 17 00:00:00 2001
From: Heinrich Apfelmus <heinrich.apfelmus@iohk.io>
Date: Mon, 1 Nov 2021 12:38:04 +0100
Subject: [PATCH 09/10] Update documentation for `restoreBlocks`

---
 lib/core/src/Cardano/Wallet.hs | 9 +++++----
 1 file changed, 5 insertions(+), 4 deletions(-)

diff --git a/lib/core/src/Cardano/Wallet.hs b/lib/core/src/Cardano/Wallet.hs
index 27f0ccecf30..265df3ab1fa 100644
--- a/lib/core/src/Cardano/Wallet.hs
+++ b/lib/core/src/Cardano/Wallet.hs
@@ -878,11 +878,12 @@ listUtxoStatistics ctx wid = do
     let utxo = availableUTxO @s pending wal
     pure $ computeUtxoStatistics log10 utxo
 
--- | Restore a wallet from its current tip up to the network tip.
+-- | Restore a wallet from its current tip.
 --
--- This function returns immediately, starting a worker thread in the
--- background that will fetch and apply remaining blocks until the
--- network tip is reached or until failure.
+-- After the wallet has been restored,
+-- this action will continue to fetch newly created blocks
+-- and apply them, or roll back to a previous point whenever
+-- the chain switches.
 restoreWallet
     :: forall ctx s k.
         ( HasNetworkLayer IO ctx

From 99cfe7c72bce45af79d1b7ab5ada4a76337748da Mon Sep 17 00:00:00 2001
From: Heinrich Apfelmus <heinrich.apfelmus@iohk.io>
Date: Mon, 1 Nov 2021 12:38:49 +0100
Subject: [PATCH 10/10] Adapt to new `HasLogger` type in master

---
 lib/core/src/Cardano/Wallet.hs | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/lib/core/src/Cardano/Wallet.hs b/lib/core/src/Cardano/Wallet.hs
index 265df3ab1fa..fbe1dc2b49e 100644
--- a/lib/core/src/Cardano/Wallet.hs
+++ b/lib/core/src/Cardano/Wallet.hs
@@ -889,7 +889,7 @@ restoreWallet
         ( HasNetworkLayer IO ctx
         , HasDBLayer IO s k ctx
         , HasGenesisData ctx
-        , HasLogger WalletWorkerLog ctx
+        , HasLogger IO WalletWorkerLog ctx
         , IsOurs s Address
         , IsOurs s RewardAccount
         )
@@ -909,7 +909,7 @@ restoreWallet ctx wid = db & \DBLayer{..} -> do
   where
     db = ctx ^. dbLayer @IO @s @k
     nw = ctx ^. networkLayer @IO
-    tr = ctx ^. logger @WalletWorkerLog
+    tr = ctx ^. logger @_ @WalletWorkerLog
     (block0, _, _) = ctx ^. genesisData
 
     -- See Note [CheckedExceptionsAndCallbacks]