db-truncater: make --truncate-after-slot more lenient again (#1203)

Closes #1202

This PR reverts the behavioral change of #1143, specifically
5747d3c. Concretely,
`--truncate-after-slot slotNo` will now remove all blocks with a slot
number higher than `slotNo` in the ImmutableDB, but does not require
that a block with exactly that slot number exists. This is convenient eg
for truncating all blocks after an epoch without having to find out the
exact slot of the last block in the epoch just before.

At the same time, the run time is still much faster than before #1143:
We iteratively check all slot numbers descending from the given one, and
truncate to the first point that is in the ImmutableDB. As realistic
ImmutableDBs are only somewhat sparse (active slot coefficient is `f =
1/20`), this should be very fast (ie still constant time in the length
of the chain if we consider the slot distance between any two adjacent
blocks to be bounded). In addition, we explicitly check whether the
given argument is beyond the tip of the ImmutableDB, and immediately
exit (successfully) in that case.

ouroboros-consensus-cardano/app/DBTruncater/Parsers.hs

@@ -32,7 +32,7 @@ slotNoOption =
     mods = mconcat
       [ long "truncate-after-slot"
       , metavar "SLOT_NUMBER"
-      , help "The slot number of the intended new tip of the chain after truncation"
+      , help "Remove all blocks with a higher slot number"
       ]
 
 blockNoOption :: Parser BlockNo

ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBTruncater/Run.hs

@@ -11,16 +11,19 @@ import           Cardano.Slotting.Slot (WithOrigin (..))
 import           Cardano.Tools.DBAnalyser.HasAnalysis
 import           Cardano.Tools.DBTruncater.Types
 import           Control.Monad
+import           Control.Monad.Trans.Class (lift)
+import           Control.Monad.Trans.Maybe (MaybeT (..))
 import           Control.Tracer
+import           Data.Foldable (asum)
+import           Data.Functor ((<&>))
 import           Data.Functor.Identity
-import           Data.Traversable (for)
 import           Ouroboros.Consensus.Block
 import           Ouroboros.Consensus.Config
 import           Ouroboros.Consensus.Node as Node
 import           Ouroboros.Consensus.Node.InitStorage as Node
 import           Ouroboros.Consensus.Storage.Common
 import           Ouroboros.Consensus.Storage.ImmutableDB (ImmutableDB, Iterator,
-                     IteratorResult (..))
+                     IteratorResult (..), Tip (..))
 import qualified Ouroboros.Consensus.Storage.ImmutableDB as ImmutableDB
 import           Ouroboros.Consensus.Storage.ImmutableDB.Impl
 import           Ouroboros.Consensus.Util.IOLike
@@ -56,33 +59,35 @@ truncate DBTruncaterConfig{ dbDir, truncateAfter, verbose } args = do
           }
 
     withDB immutableDBArgs $ \(immutableDB, internal) -> do
-      mLastHdr :: Maybe (Header block) <- case truncateAfter of
-        TruncateAfterSlot slotNo -> do
-          mHash <- getHashForSlot internal slotNo
-          for (RealPoint slotNo <$> mHash) $
-            ImmutableDB.getKnownBlockComponent immutableDB GetHeader
+      tip <- atomically $ ImmutableDB.getTip immutableDB
+      let truncationBeyondTip = case truncateAfter of
+            TruncateAfterSlot slotNo -> (tipSlotNo  <$> tip) <= NotOrigin slotNo
+            TruncateAfterBlock bno   -> (tipBlockNo <$> tip) <= NotOrigin bno
+      if truncationBeyondTip
+      then putStrLn $ "Nothing to truncate, tip stays at " <> show tip
+      else do
+        mLastHdr :: Maybe (Header block) <- case truncateAfter of
+          TruncateAfterSlot slotNo -> runMaybeT $ asum $
+            [slotNo, slotNo - 1 .. 0] <&> \s -> do
+              pt <- RealPoint s <$> MaybeT (getHashForSlot internal s)
+              lift $ ImmutableDB.getKnownBlockComponent immutableDB GetHeader pt
 
-        TruncateAfterBlock bno   -> do
-          -- At the moment, we're just running a linear search with streamAll to
-          -- find the correct block to truncate from, but we could in theory do this
-          -- more quickly by binary searching the chunks of the ImmutableDB.
-          iterator <- ImmutableDB.streamAll immutableDB registry GetHeader
-          findLast ((<= bno) . blockNo) iterator
+          TruncateAfterBlock bno   -> do
+            -- At the moment, we're just running a linear search with streamAll to
+            -- find the correct block to truncate from, but we could in theory do this
+            -- more quickly by binary searching the chunks of the ImmutableDB.
+            iterator <- ImmutableDB.streamAll immutableDB registry GetHeader
+            findLast ((<= bno) . blockNo) iterator
 
-      case ImmutableDB.headerToTip <$> mLastHdr of
-        Nothing ->
-          putStrLn $ mconcat
-            [ "Unable to find a truncate point. This is because the ImmutableDB"
-            , "does not contain a block with the given slot or block number."
-            ]
-        Just newTip -> do
-          when verbose $ do
+        case ImmutableDB.headerToTip <$> mLastHdr of
+          Nothing -> fail "Couldn't find a point to truncate to!"
+          Just newTip -> do
             putStrLn $ mconcat
               [ "Truncating the ImmutableDB using the following block as the "
               , "new tip:\n"
               , "  ", show newTip
               ]
-          deleteAfter internal (At newTip)
+            deleteAfter internal (At newTip)
 
 -- | Given a predicate, and an iterator, find the last item for which
 -- the predicate passes.

ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBTruncater/Types.hs

@@ -13,10 +13,8 @@ data DBTruncaterConfig = DBTruncaterConfig {
 
 -- | Where to truncate the ImmutableDB.
 data TruncateAfter
-    -- | Truncate after the given slot number, such that the new tip has this
-    -- exact slot number. Fail if this is not possible, ie no block has this
-    -- slot number. If there are two blocks with the same slot number (due to
-    -- EBBs), the tip will be the non-EBB.
+    -- | Truncate after the given slot number, deleting all blocks with a higher
+    -- slot number.
   = TruncateAfterSlot SlotNo
     -- | Truncate after the given block number (such that the new tip has this
     -- block number).