Introduce SlotPoint type to distinguish genesis from (SlotNo 0)

This commit partially addresses the issue where the DB layer historically did not distinguish between the genesis point and the block with SlotNo 0, which comes directly after genesis.

* The types of `rollbackTo` and `listCheckpoints` can now distinguish these points.
* For reasons of correctness, we need to use `SlotPoint` in the `Checkpoints` type.
* However, the DB file format still uses slot numbers only. But as we want to revamp the format anyway, the plan is to keep it as it is for now, and remove the issue with the revamp.

lib/core/src/Cardano/Wallet.hs

@@ -359,6 +359,7 @@ import Cardano.Wallet.Primitive.Types
     , ProtocolParameters (..)
     , Range (..)
     , Signature (..)
+    , SlotPoint
     , SlottingParameters (..)
     , SortOrder (..)
     , WalletDelegation (..)
@@ -368,6 +369,7 @@ import Cardano.Wallet.Primitive.Types
     , WalletName (..)
     , WalletPassphraseInfo (..)
     , dlgCertPoolId
+    , toSlotPoint
     , wholeRange
     )
 import Cardano.Wallet.Primitive.Types.Address
@@ -894,7 +896,6 @@ restoreWallet
     :: forall ctx s k.
         ( HasNetworkLayer IO ctx
         , HasDBLayer IO s k ctx
-        , HasGenesisData ctx
         , HasLogger IO WalletWorkerLog ctx
         , IsOurs s Address
         , IsOurs s RewardAccount
@@ -904,19 +905,17 @@ restoreWallet
     -> ExceptT ErrNoSuchWallet IO ()
 restoreWallet ctx wid = db & \DBLayer{..} -> do
     catchFromIO $ chainSync nw (contramap MsgChainFollow tr) $ ChainFollower
-        { readLocalTip = liftIO $ atomically $
-            map (toChainPoint block0) <$> listCheckpoints wid
+        { readLocalTip = liftIO $ atomically $ listCheckpoints wid
         , rollForward = \blocks tip -> throwInIO $
             restoreBlocks @ctx @s @k
                 ctx (contramap MsgWalletFollow tr) wid blocks tip
         , rollBackward =
-            throwInIO . rollbackBlocks @ctx @s @k ctx wid
+            throwInIO . rollbackBlocks @ctx @s @k ctx wid . toSlotPoint
         }
   where
     db = ctx ^. dbLayer @IO @s @k
     nw = ctx ^. networkLayer @IO
     tr = ctx ^. logger @_ @WalletWorkerLog
-    (block0, _, _) = ctx ^. genesisData
 
     -- See Note [CheckedExceptionsAndCallbacks]
     throwInIO :: ExceptT ErrNoSuchWallet IO a -> IO a
@@ -967,57 +966,15 @@ and present it as a checked exception.
 rollbackBlocks
     :: forall ctx s k.
         ( HasDBLayer IO s k ctx
-        , HasGenesisData ctx
         )
     => ctx
     -> WalletId
-    -> ChainPoint
+    -> SlotPoint
     -> ExceptT ErrNoSuchWallet IO ChainPoint
 rollbackBlocks ctx wid point = db & \DBLayer{..} -> do
-    mapExceptT atomically $ (toChainPoint block0)
-        <$> rollbackTo wid (pseudoPointSlot point)
+    mapExceptT atomically $ rollbackTo wid 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
-
-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]
-
-`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.

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

@@ -42,11 +42,12 @@ import Cardano.Wallet.Primitive.AddressDerivation
 import Cardano.Wallet.Primitive.Model
     ( Wallet )
 import Cardano.Wallet.Primitive.Types
-    ( BlockHeader
+    ( ChainPoint
     , DelegationCertificate
     , GenesisParameters
     , Range (..)
     , SlotNo (..)
+    , SlotPoint
     , SortOrder (..)
     , WalletId
     , WalletMetadata
@@ -161,7 +162,7 @@ data DBLayer m s k = forall stm. (MonadIO stm, MonadFail stm) => DBLayer
 
     , listCheckpoints
         :: WalletId
-        -> stm [BlockHeader]
+        -> stm [ChainPoint]
         -- ^ List all known checkpoint tips, ordered by slot ids from the oldest
         -- to the newest.
 
@@ -301,12 +302,13 @@ data DBLayer m s k = forall stm. (MonadIO stm, MonadFail stm) => DBLayer
 
     , rollbackTo
         :: WalletId
-        -> SlotNo
-        -> ExceptT ErrNoSuchWallet stm BlockHeader
-        -- ^ Drops all checkpoints and transaction data after the given slot.
+        -> SlotPoint
+        -> ExceptT ErrNoSuchWallet stm ChainPoint
+        -- ^ Drops all checkpoints and transaction data which
+        -- have appeared after the given 'ChainPoint'.
         --
-        -- Returns the actual slot to which the database has rolled back. This
-        -- slot is guaranteed to be earlier than (or identical to) the given
+        -- Returns the actual 'ChainPoint' to which the database has rolled back.
+        -- Its slot is guaranteed to be earlier than (or identical to) the given
         -- point of rollback but can't be guaranteed to be exactly the same
         -- because the database may only keep sparse checkpoints.
 

lib/core/src/Cardano/Wallet/DB/Model.hs

@@ -76,20 +76,24 @@ import Cardano.Wallet.Primitive.Slotting
     ( TimeInterpreter, epochOf, interpretQuery, slotToUTCTime )
 import Cardano.Wallet.Primitive.Types
     ( BlockHeader (blockHeight, slotNo)
+    , ChainPoint
     , DelegationCertificate (..)
     , EpochNo (..)
     , GenesisParameters (..)
     , PoolId
     , Range (..)
     , SlotNo (..)
+    , SlotPoint
     , SortOrder (..)
     , StakeKeyCertificate (..)
     , WalletDelegation (..)
     , WalletDelegationNext (..)
     , WalletDelegationStatus (..)
     , WalletMetadata (..)
+    , chainPointFromBlockHeader
     , dlgCertPoolId
     , isWithinRange
+    , toSlotPoint
     )
 import Cardano.Wallet.Primitive.Types.Coin
     ( Coin (..) )
@@ -262,11 +266,11 @@ mostRecentCheckpoint :: WalletDatabase s xprv -> Maybe (Wallet s)
 mostRecentCheckpoint = fmap snd . Map.lookupMax . checkpoints
 
 mListCheckpoints
-    :: Ord wid => wid -> ModelOp wid s xprv [BlockHeader]
+    :: Ord wid => wid -> ModelOp wid s xprv [ChainPoint]
 mListCheckpoints wid db@(Database wallets _) =
     (Right $ sort $ maybe [] tips (Map.lookup wid wallets), db)
   where
-    tips = map currentTip . Map.elems . checkpoints
+    tips = map (chainPointFromBlockHeader . currentTip) . Map.elems . checkpoints
 
 mUpdatePendingTxForExpiry :: Ord wid => wid -> SlotNo -> ModelOp wid s xprv ()
 mUpdatePendingTxForExpiry wid tipSlot = alterModel wid $ ((),) . updatePending
@@ -300,7 +304,7 @@ mRemovePendingOrExpiredTx wid tid = alterModelErr wid $ \wal ->
                 , submittedTxs = Map.delete tid (submittedTxs wal)
                 } )
 
-mRollbackTo :: Ord wid => wid -> SlotNo -> ModelOp wid s xprv BlockHeader
+mRollbackTo :: Ord wid => wid -> SlotPoint -> ModelOp wid s xprv ChainPoint
 mRollbackTo wid requested db@(Database wallets txs) = case Map.lookup wid wallets of
     Nothing ->
         ( Left (NoSuchWallet wid), db )
@@ -318,7 +322,10 @@ mRollbackTo wid requested db@(Database wallets txs) = case Map.lookup wid wallet
                             Map.mapMaybe (rescheduleOrForget point) (txHistory wal)
                         }
                 in
-                    ( Right $ view #currentTip (checkpoints wal Map.! point)
+                    ( Right
+                        $ chainPointFromBlockHeader
+                        $ view #currentTip
+                        $ checkpoints wal Map.! point
                     , Database (Map.insert wid wal' wallets) txs
                     )
   where
@@ -338,7 +345,9 @@ mRollbackTo wid requested db@(Database wallets txs) = case Map.lookup wid wallet
     findNearestPoint = safeHead . sortOn Down . mapMaybe fn
       where
         fn :: Wallet s -> Maybe SlotNo
-        fn cp = if (tip cp <= requested) then Just (tip cp) else Nothing
+        fn cp = if stip cp <= requested then Just (tip cp) else Nothing
+          where
+            stip = toSlotPoint . chainPointFromBlockHeader . currentTip
 
     safeHead :: [a] -> Maybe a
     safeHead [] = Nothing