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

@@ -336,6 +336,7 @@ import Cardano.Wallet.Primitive.Types
     ( ActiveSlotCoefficient (..)
     , Block (..)
     , BlockHeader (..)
+    , ChainPoint (..)
     , DelegationCertificate (..)
     , GenesisParameters (..)
     , IsDelegatingTo (..)
@@ -872,7 +873,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
@@ -896,13 +897,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

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

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

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

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 (..)
@@ -108,7 +109,7 @@ data NetworkLayer m block = NetworkLayer
     { chainSync
         :: forall msg. Tracer IO (FollowLog msg)
         -> ChainFollower m
-            BlockHeader
+            ChainPoint
             BlockHeader
             block
         -> m ()
@@ -175,7 +176,7 @@ data NetworkLayer m block = NetworkLayer
 instance Functor m => Functor (NetworkLayer m) where
     fmap f nl = nl
         { chainSync = \ tr follower ->
-            chainSync nl tr (mapChainFollower id id f follower)
+            chainSync nl tr (mapChainFollower id id id f follower)
         }
 
 {-------------------------------------------------------------------------------
@@ -389,12 +390,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
@@ -431,15 +430,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
         }
 
 
@@ -496,8 +496,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)
@@ -715,19 +715,19 @@ 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
     , rollForward = \tip blocks -> do
         traceWith tr $ MsgApplyBlocks tip (fmap (error "FIXME: todo") 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

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

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

@@ -400,9 +400,8 @@ chainSyncWithBlocks tr cf =
             case rollbackBuffer point buffer of
                 [] -> do -- b)
                     traceWith tr $ MsgChainRollBackward point 0
-                    let slot = pseudoPointSlot point
-                    actual <- rollBackward cf slot
-                    if actual == slot
+                    actual <- rollBackward cf point
+                    if actual == point
                     then pure FollowerExact
                     else do
                         pure FollowerNeedToReNegotiate
@@ -434,28 +433,6 @@ chainSyncWithBlocks tr cf =
                 cont
             }
 
-    -- 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

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 =

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

@@ -89,6 +89,7 @@ import Cardano.Wallet.Shelley.Compatibility
     , fromCardanoHash
     , fromLedgerPParams
     , fromNonMyopicMemberRewards
+    , fromPoint
     , fromPoolDistr
     , fromShelleyCoin
     , fromShelleyPParams
@@ -348,7 +349,7 @@ withNetworkLayerBase tr net np conn versionData tol action = do
                 client <- mkWalletClient
                     followTr
                     (mapChainFollower
-                        (toPoint getGenesisBlockHash)
+                        toPoint fromPoint
                         (fromTip' gp)
                         id
                         (addFollowerLogging followTr follower))