Fix rollback logic

cardano-db-sync/src/Cardano/DbSync.hs

@@ -374,8 +374,7 @@ chainSyncClient trce metrics latestPoints currentTip actionQueue =
                 Gauge.set (fromIntegral newSize) $ mQueuePostWrite metrics
                 pure $ finish (At (blockNo blk)) tip
         , recvMsgRollBackward = \point tip ->
-            liftIO $ do
-              logInfo trce $ "recvMsgRollBackward: " <> textShow (point, tip)
+            liftIO .
               logException trce "recvMsgRollBackward: " $ do
                 -- This will get the current tip rather than what we roll back to
                 -- but will only be incorrect for a short time span.

cardano-db-sync/src/Cardano/DbSync/Era/Shelley/Util.hs

@@ -96,7 +96,7 @@ pointToSlotHash (Point x) =
     At blk -> Just (Point.blockPointSlot blk, Point.blockPointHash blk)
 
 renderHash :: ShelleyHash -> Text
-renderHash = Text.decodeUtf8 . unHeaderHash
+renderHash = Text.decodeUtf8 . Base16.encode . unHeaderHash
 
 slotNumber :: ShelleyBlock -> Word64
 slotNumber =

cardano-db-sync/src/Cardano/DbSync/Plugin/Default/Byron/Rollback.hs

@@ -15,7 +15,6 @@ import           Control.Monad.IO.Class (MonadIO)
 import           Control.Monad.Trans.Except.Extra (runExceptT)
 
 import           Data.Text (Text)
-import qualified Data.Text as Text
 
 import           Database.Persist.Sql (SqlBackend)
 
@@ -25,7 +24,7 @@ import           Cardano.DbSync.Error
 import           Cardano.DbSync.Util
 
 import           Ouroboros.Consensus.Byron.Ledger (ByronBlock)
-import           Ouroboros.Network.Block (Point (..))
+import           Ouroboros.Network.Block (BlockNo (..), Point (..))
 
 
 rollbackToPoint :: Trace IO Text -> Point ByronBlock -> IO (Either DbSyncNodeError ())
@@ -37,18 +36,14 @@ rollbackToPoint trce point =
   where
     action :: MonadIO m => SlotNo -> Byron.HeaderHash -> ExceptT DbSyncNodeError (ReaderT SqlBackend m) ()
     action slot hash = do
-        blk <- liftLookupFail "rollbackToPoint" $ DB.queryMainBlock (Byron.unHeaderHash hash)
-        case DB.blockSlotNo blk of
-          Nothing -> dbSyncNodeError "rollbackToPoint: slot number is Nothing"
-          Just slotNo -> do
-            if slotNo <= unSlotNo slot
-              then liftIO . logInfo trce $ mconcat
-                            [ "Byron: No rollback required: db tip slot is ", textShow slotNo
-                            , " ledger tip slot is ", textShow (unSlotNo slot)
-                            ]
-              else do
-                liftIO . logInfo trce $ Text.concat
-                            [ "Rollbacking to slot ", textShow (unSlotNo slot)
-                            , ", hash ", Byron.renderAbstractHash hash
-                            ]
-                void . lift $ DB.deleteCascadeSlotNo slotNo
+        liftIO . logInfo trce $
+            mconcat
+              [ "Byron: Rolling back to slot ", textShow (unSlotNo slot)
+              , ", hash ", Byron.renderAbstractHash hash
+              ]
+        xs <- lift $ DB.queryBlockNosWithSlotNoGreater (unSlotNo slot)
+        liftIO . logInfo trce $
+            mconcat
+              [ "Byron: Deleting blocks numbered: ", textShow (map unBlockNo xs)
+              ]
+        mapM_ (void . lift . DB.deleteCascadeBlockNo) xs

cardano-db-sync/src/Cardano/DbSync/Plugin/Default/Shelley/Rollback.hs

@@ -20,11 +20,10 @@ import           Control.Monad.IO.Class (MonadIO)
 import           Control.Monad.Trans.Except.Extra (runExceptT)
 
 import           Data.Text (Text)
-import qualified Data.Text as Text
 
 import           Database.Persist.Sql (SqlBackend)
 
-import           Ouroboros.Network.Block (Point (..))
+import           Ouroboros.Network.Block (BlockNo (..), Point (..))
 
 
 rollbackToPoint :: Trace IO Text -> Point ShelleyBlock -> IO (Either DbSyncNodeError ())
@@ -36,18 +35,14 @@ rollbackToPoint trce point =
   where
     action :: MonadIO m => SlotNo -> ShelleyHash -> ExceptT DbSyncNodeError (ReaderT SqlBackend m) ()
     action slot hash = do
-        blk <- liftLookupFail "rollbackToPoint" $ DB.queryMainBlock (Shelley.unHeaderHash hash)
-        case DB.blockSlotNo blk of
-          Nothing -> dbSyncNodeError "rollbackToPoint: slot number is Nothing"
-          Just slotNo -> do
-            if slotNo <= unSlotNo slot
-              then liftIO . logInfo trce $ mconcat
-                            [ "Shelley: No rollback required: db tip slot is ", textShow slotNo
-                            , " ledger tip slot is ", textShow (unSlotNo slot)
-                            ]
-              else do
-                liftIO . logInfo trce $ Text.concat
-                            [ "Rollbacking to slot ", textShow (unSlotNo slot)
-                            , ", hash ", Shelley.renderHash hash
-                            ]
-                void . lift $ DB.deleteCascadeSlotNo slotNo
+        liftIO . logInfo trce $
+            mconcat
+              [ "Shelley: Rolling back to slot ", textShow (unSlotNo slot)
+              , ", hash ", Shelley.renderHash hash
+              ]
+        xs <- lift $ DB.queryBlockNosWithSlotNoGreater (unSlotNo slot)
+        liftIO . logInfo trce $
+            mconcat
+              [ "Shelley: Deleting blocks numbered: ", textShow (map unBlockNo xs)
+              ]
+        mapM_ (void . lift . DB.deleteCascadeBlockNo) xs

cardano-db/cardano-db.cabal

@@ -59,6 +59,7 @@ library
                       , filepath
                       , iohk-monitoring
                       , monad-logger
+                      , ouroboros-network
                       , persistent
                       , persistent-postgresql
                       , persistent-template >= 2.7.0

cardano-db/src/Cardano/Db/Delete.hs

@@ -1,5 +1,6 @@
 module Cardano.Db.Delete
   ( deleteCascadeBlock
+  , deleteCascadeBlockNo
   , deleteCascadeSlotNo
   ) where
 
@@ -14,6 +15,8 @@ import           Database.Persist.Types (entityKey)
 
 import           Cardano.Db.Schema
 
+import           Ouroboros.Network.Block (BlockNo (..))
+
 
 -- | Delete a block if it exists. Returns 'True' if it did exist and has been
 -- deleted and 'False' if it did not exist.
@@ -23,10 +26,19 @@ deleteCascadeBlock block = do
   mapM_ (deleteCascade . entityKey) keys
   pure $ not (null keys)
 
+-- | Delete a block if it exists. Returns 'True' if it did exist and has been
+-- deleted and 'False' if it did not exist.
+deleteCascadeBlockNo :: MonadIO m => BlockNo -> ReaderT SqlBackend m Bool
+deleteCascadeBlockNo (BlockNo blockNo) = do
+  keys <- selectList [ BlockBlockNo ==. Just blockNo ] []
+  mapM_ (deleteCascade . entityKey) keys
+  pure $ not (null keys)
+
 -- | Delete a block if it exists. Returns 'True' if it did exist and has been
 -- deleted and 'False' if it did not exist.
 deleteCascadeSlotNo :: MonadIO m => Word64 -> ReaderT SqlBackend m Bool
 deleteCascadeSlotNo slotNo = do
   keys <- selectList [ BlockSlotNo ==. Just slotNo ] []
   mapM_ (deleteCascade . entityKey) keys
   pure $ not (null keys)
+

cardano-db/src/Cardano/Db/Query.hs

@@ -10,6 +10,7 @@ module Cardano.Db.Query
   , queryBlockHeight
   , queryBlockId
   , queryBlockNo
+  , queryBlockNosWithSlotNoGreater
   , queryMainBlock
   , queryBlockTxCount
   , queryCalcEpochEntry
@@ -86,6 +87,8 @@ import           Cardano.Db.Error
 import           Cardano.Db.Schema
 import           Cardano.Db.Types
 
+import           Ouroboros.Network.Block (BlockNo (..))
+
 -- If you squint, these Esqueleto queries almost look like SQL queries.
 
 
@@ -122,6 +125,16 @@ queryBlockNo blkNo = do
             pure blk
   pure $ fmap entityVal (listToMaybe res)
 
+queryBlockNosWithSlotNoGreater :: MonadIO m => Word64 -> ReaderT SqlBackend m [BlockNo]
+queryBlockNosWithSlotNoGreater slotNo = do
+  res <- select . from $ \ blk -> do
+            -- Want all BlockNos where the block satisfies this predicate.
+            where_ (blk ^. BlockSlotNo >. just (val slotNo))
+            -- Return them in descending order so we can delete the highest numbered
+            -- ones first.
+            orderBy [desc (blk ^. BlockBlockNo)]
+            pure (blk ^. BlockBlockNo)
+  pure $ catMaybes (map (fmap BlockNo . unValue) res)
 
 -- | Get the current block height.
 queryBlockHeight :: MonadIO m => ReaderT SqlBackend m Word64
@@ -145,7 +158,7 @@ queryMainBlock hash = do
     queryMainBlockId blkid = do
       res <- select . from $ \ blk -> do
               where_ $ (isJust (blk ^. BlockBlockNo) &&. blk ^. BlockId <=. val blkid)
-              orderBy [desc (blk ^. BlockId)]
+              orderBy [desc (blk ^. BlockSlotNo)]
               limit 1
               pure blk
       pure $ maybeToEither (DbLookupBlockId $ unBlockId blkid) entityVal (listToMaybe res)
@@ -213,7 +226,7 @@ queryCheckPoints :: MonadIO m => Word64 -> ReaderT SqlBackend m [(Word64, ByteSt
 queryCheckPoints limitCount = do
     latest <- select $ from $ \ blk -> do
                 where_ $ (isJust $ blk ^. BlockSlotNo)
-                orderBy [desc (blk ^. BlockId)]
+                orderBy [desc (blk ^. BlockSlotNo)]
                 limit 1
                 pure $ (blk ^. BlockSlotNo)
     case join (unValue <$> listToMaybe latest) of
@@ -304,7 +317,7 @@ queryIsFullySynced = do
 queryLatestBlockId :: MonadIO m => ReaderT SqlBackend m (Maybe BlockId)
 queryLatestBlockId = do
   res <- select $ from $ \ blk -> do
-                orderBy [desc (blk ^. BlockId)]
+                orderBy [desc (blk ^. BlockSlotNo)]
                 limit $ 1
                 pure $ (blk ^. BlockId)
   pure $ fmap unValue (listToMaybe res)
@@ -323,7 +336,7 @@ queryLatestBlockNo = do
 queryLatestBlock :: MonadIO m => ReaderT SqlBackend m (Maybe Block)
 queryLatestBlock = do
   res <- select $ from $ \ blk -> do
-                orderBy [desc (blk ^. BlockId)]
+                orderBy [desc (blk ^. BlockSlotNo)]
                 limit 1
                 pure $ blk
   pure $ fmap entityVal (listToMaybe res)