{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

module Cardano.Tools.DBTruncater.Run (truncate) where

import Cardano.Slotting.Slot (WithOrigin (..))
import Cardano.Tools.DBAnalyser.HasAnalysis
import Cardano.Tools.DBTruncater.Types
import Cardano.Tools.LeiosDb (requireLeiosDbFile)
import Control.Monad
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Maybe (MaybeT (..))
import Control.ResourceRegistry (withRegistry)
import Control.Tracer
import Data.Foldable (asum)
import Data.Functor ((<&>))
import Data.Functor.Identity
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 (..)
  , Tip (..)
  )
import qualified Ouroboros.Consensus.Storage.ImmutableDB as ImmutableDB
import Ouroboros.Consensus.Storage.ImmutableDB.Impl
import Ouroboros.Consensus.Storage.LeiosDB
  ( deleteDanglingTxs
  , truncateLeiosDbAfterSlot
  , vacuumLeiosDb
  )
import Ouroboros.Consensus.Util.Args
import Ouroboros.Consensus.Util.IOLike
import qualified System.FilePath as FilePath
import System.IO
import Prelude hiding (truncate)

truncate ::
  forall block.
  (Node.RunNode block, HasProtocolInfo block) =>
  DBTruncaterConfig ->
  Args block ->
  IO ()
truncate :: forall block.
(RunNode block, HasProtocolInfo block) =>
DBTruncaterConfig -> Args block -> IO ()
truncate DBTruncaterConfig{String
dbDir :: String
dbDir :: DBTruncaterConfig -> String
dbDir, TruncateAfter
truncateAfter :: TruncateAfter
truncateAfter :: DBTruncaterConfig -> TruncateAfter
truncateAfter, Bool
verbose :: Bool
verbose :: DBTruncaterConfig -> Bool
verbose} Args block
args = do
  -- Check the files before the ImmutableDB truncation, so a missing LeiosDb
  -- fails before the tool deletes any block.
  mLeiosDbPaths <- do
    let volLeiosDBFile :: String
volLeiosDBFile = String
dbDir String -> String -> String
FilePath.</> String
"leios.vol.db"
        immLeiosDBFile :: String
immLeiosDBFile = String
dbDir String -> String -> String
FilePath.</> String
"leios.imm.db"
    String -> IO ()
requireLeiosDbFile String
volLeiosDBFile
    String -> IO ()
requireLeiosDbFile String
immLeiosDBFile
    Maybe (String, String) -> IO (Maybe (String, String))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (String, String) -> IO (Maybe (String, String)))
-> ((String, String) -> Maybe (String, String))
-> (String, String)
-> IO (Maybe (String, String))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, String) -> Maybe (String, String)
forall a. a -> Maybe a
Just ((String, String) -> IO (Maybe (String, String)))
-> (String, String) -> IO (Maybe (String, String))
forall a b. (a -> b) -> a -> b
$ (String
volLeiosDBFile, String
immLeiosDBFile)
  withRegistry $ \ResourceRegistry IO
registry -> do
    lock <- IO (StrictMVar IO ())
forall (m :: * -> *). MonadMVar m => m (StrictMVar m ())
mkLock
    immutableDBTracer <- mkVerboseTracer lock verbose
    ProtocolInfo
      { pInfoConfig = config
      } <-
      mkProtocolInfo args
    let
      fs = String -> RelativeMountPoint -> SomeHasFS IO
Node.stdMkChainDbHasFS String
dbDir (String -> RelativeMountPoint
RelativeMountPoint String
"immutable")
      chunkInfo = StorageConfig block -> ChunkInfo
forall blk. NodeInitStorage blk => StorageConfig blk -> ChunkInfo
Node.nodeImmutableDbChunkInfo (TopLevelConfig block -> StorageConfig block
forall blk. TopLevelConfig blk -> StorageConfig blk
configStorage TopLevelConfig block
config)
      immutableDBArgs :: Complete ImmutableDbArgs IO block
      immutableDBArgs =
        (forall (m :: * -> *) blk.
Monad m =>
Incomplete ImmutableDbArgs m blk
ImmutableDB.defaultArgs @IO)
          { immTracer = immutableDBTracer
          , immRegistry = registry
          , immCheckIntegrity = nodeCheckIntegrity (configStorage config)
          , immCodecConfig = configCodec config
          , immChunkInfo = chunkInfo
          , immHasFS = fs
          }

    withDB immutableDBArgs $ \(ImmutableDB IO block
immutableDB, Internal IO block
internal) -> do
      tip <- STM IO (WithOrigin (Tip block)) -> IO (WithOrigin (Tip block))
forall a. HasCallStack => STM IO a -> IO a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM IO (WithOrigin (Tip block)) -> IO (WithOrigin (Tip block)))
-> STM IO (WithOrigin (Tip block)) -> IO (WithOrigin (Tip block))
forall a b. (a -> b) -> a -> b
$ ImmutableDB IO block -> STM IO (WithOrigin (Tip block))
forall (m :: * -> *) blk.
HasCallStack =>
ImmutableDB m blk -> STM m (WithOrigin (Tip blk))
ImmutableDB.getTip ImmutableDB IO block
immutableDB
      let truncationBeyondTip = case TruncateAfter
truncateAfter of
            TruncateAfterSlot SlotNo
slotNo -> (Tip block -> SlotNo
forall blk. Tip blk -> SlotNo
tipSlotNo (Tip block -> SlotNo)
-> WithOrigin (Tip block) -> WithOrigin SlotNo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> WithOrigin (Tip block)
tip) WithOrigin SlotNo -> WithOrigin SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
<= SlotNo -> WithOrigin SlotNo
forall t. t -> WithOrigin t
NotOrigin SlotNo
slotNo
            TruncateAfterBlock BlockNo
bno -> (Tip block -> BlockNo
forall blk. Tip blk -> BlockNo
tipBlockNo (Tip block -> BlockNo)
-> WithOrigin (Tip block) -> WithOrigin BlockNo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> WithOrigin (Tip block)
tip) WithOrigin BlockNo -> WithOrigin BlockNo -> Bool
forall a. Ord a => a -> a -> Bool
<= BlockNo -> WithOrigin BlockNo
forall t. t -> WithOrigin t
NotOrigin BlockNo
bno
      if truncationBeyondTip
        then putStrLn $ "Nothing to truncate, tip stays at " <> show tip
        else do
          mLastHdr :: Maybe (Header block) <- case truncateAfter of
            TruncateAfterSlot SlotNo
slotNo ->
              MaybeT IO (Header block) -> IO (Maybe (Header block))
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT IO (Header block) -> IO (Maybe (Header block)))
-> MaybeT IO (Header block) -> IO (Maybe (Header block))
forall a b. (a -> b) -> a -> b
$
                [MaybeT IO (Header block)] -> MaybeT IO (Header block)
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum ([MaybeT IO (Header block)] -> MaybeT IO (Header block))
-> [MaybeT IO (Header block)] -> MaybeT IO (Header block)
forall a b. (a -> b) -> a -> b
$
                  [SlotNo
slotNo, SlotNo
slotNo SlotNo -> SlotNo -> SlotNo
forall a. Num a => a -> a -> a
- SlotNo
1 .. SlotNo
0] [SlotNo]
-> (SlotNo -> MaybeT IO (Header block))
-> [MaybeT IO (Header block)]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \SlotNo
s -> do
                    pt <- SlotNo -> HeaderHash block -> RealPoint block
forall blk. SlotNo -> HeaderHash blk -> RealPoint blk
RealPoint SlotNo
s (HeaderHash block -> RealPoint block)
-> MaybeT IO (HeaderHash block) -> MaybeT IO (RealPoint block)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Maybe (HeaderHash block)) -> MaybeT IO (HeaderHash block)
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (Internal IO block -> SlotNo -> IO (Maybe (HeaderHash block))
forall (m :: * -> *) blk.
HasCallStack =>
Internal m blk -> SlotNo -> m (Maybe (HeaderHash blk))
getHashForSlot Internal IO block
internal SlotNo
s)
                    lift $ ImmutableDB.getKnownBlockComponent immutableDB GetHeader pt
            TruncateAfterBlock BlockNo
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 IO block
-> ResourceRegistry IO
-> BlockComponent block (Header block)
-> IO (Iterator IO block (Header block))
forall (m :: * -> *) blk b.
(MonadSTM m, MonadThrow m, HasHeader blk, HasCallStack) =>
ImmutableDB m blk
-> ResourceRegistry m
-> BlockComponent blk b
-> m (Iterator m blk b)
ImmutableDB.streamAll ImmutableDB IO block
immutableDB ResourceRegistry IO
registry BlockComponent block (Header block)
forall blk. BlockComponent blk (Header blk)
GetHeader
              findLast ((<= bno) . blockNo) iterator

          case ImmutableDB.headerToTip <$> mLastHdr of
            Maybe (Tip block)
Nothing -> String -> IO ()
forall a. HasCallStack => String -> IO a
forall (m :: * -> *) a.
(MonadFail m, HasCallStack) =>
String -> m a
fail String
"Couldn't find a point to truncate to!"
            Just Tip block
newTip -> do
              String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
                [String] -> String
forall a. Monoid a => [a] -> a
mconcat
                  [ String
"Truncating the ImmutableDB using the following block as the "
                  , String
"new tip:\n"
                  , String
"  "
                  , Tip block -> String
forall a. Show a => a -> String
show Tip block
newTip
                  ]
              Internal IO block -> WithOrigin (Tip block) -> IO ()
forall (m :: * -> *) blk.
HasCallStack =>
Internal m blk -> WithOrigin (Tip blk) -> m ()
deleteAfter Internal IO block
internal (Tip block -> WithOrigin (Tip block)
forall t. t -> WithOrigin t
At Tip block
newTip)
              -- Truncate the LeiosDb after the ImmutableDB. The other order
              -- can leave a cert-RB whose EB is gone.
              Maybe (String, String) -> ((String, String) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe (String, String)
mLeiosDbPaths (((String, String) -> IO ()) -> IO ())
-> ((String, String) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(String
volLeiosDbPath, String
immLeiosDbPath) ->
                (IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
forall (m :: * -> *) a b. MonadCatch m => m a -> m b -> m a
`onException` Handle -> String -> IO ()
hPutStrLn Handle
stderr (Tip block -> String
forall blk. Tip blk -> String
leiosDbCutFailed Tip block
newTip)) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                  -- Truncate both the volatile and the immutable LeiosDB
                  -- partitions, even though the volatile one likely does not
                  -- need truncation.
                  String -> SlotNo -> IO ()
truncateLeiosDbFile String
volLeiosDbPath (Tip block -> SlotNo
forall blk. Tip blk -> SlotNo
tipSlotNo Tip block
newTip)
                  String -> SlotNo -> IO ()
truncateLeiosDbFile String
immLeiosDbPath (Tip block -> SlotNo
forall blk. Tip blk -> SlotNo
tipSlotNo Tip block
newTip)
 where
  truncateLeiosDbFile :: String -> SlotNo -> IO ()
truncateLeiosDbFile String
path SlotNo
slot = do
    HasCallStack => String -> SlotNo -> IO ()
String -> SlotNo -> IO ()
truncateLeiosDbAfterSlot String
path SlotNo
slot
    HasCallStack => String -> IO ()
String -> IO ()
deleteDanglingTxs String
path
    HasCallStack => String -> IO ()
String -> IO ()
vacuumLeiosDb String
path

leiosDbCutFailed :: Tip blk -> String
leiosDbCutFailed :: forall blk. Tip blk -> String
leiosDbCutFailed Tip blk
newTip =
  [String] -> String
forall a. Monoid a => [a] -> a
mconcat
    [ String
"The ImmutableDB is truncated to slot "
    , String
slot
    , String
". The LeiosDb cut did not complete, so the LeiosDb still holds the EBs "
    , String
"announced after that slot. Nothing on the truncated chain reads them, "
    , String
"so you can leave them. To remove them, re-run with a "
    , String
"--truncate-after-slot below "
    , String
slot
    , String
": a re-run at "
    , String
slot
    , String
" reports \"Nothing to truncate\" and changes nothing."
    ]
 where
  slot :: String
slot = SlotNo -> String
forall a. Show a => a -> String
show (Tip blk -> SlotNo
forall blk. Tip blk -> SlotNo
tipSlotNo Tip blk
newTip)

-- | Given a predicate, and an iterator, find the last item for which
-- the predicate passes.
findLast :: Monad m => (a -> Bool) -> Iterator m blk a -> m (Maybe a)
findLast :: forall (m :: * -> *) a blk.
Monad m =>
(a -> Bool) -> Iterator m blk a -> m (Maybe a)
findLast a -> Bool
p Iterator m blk a
iter =
  Maybe a -> m (Maybe a)
go Maybe a
forall a. Maybe a
Nothing
 where
  go :: Maybe a -> m (Maybe a)
go Maybe a
acc =
    Iterator m blk a -> HasCallStack => m (IteratorResult a)
forall (m :: * -> *) blk b.
Iterator m blk b -> HasCallStack => m (IteratorResult b)
ImmutableDB.iteratorNext Iterator m blk a
iter m (IteratorResult a)
-> (IteratorResult a -> m (Maybe a)) -> m (Maybe a)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      IteratorResult a
IteratorExhausted -> do
        Iterator m blk a -> HasCallStack => m ()
forall (m :: * -> *) blk b.
Iterator m blk b -> HasCallStack => m ()
ImmutableDB.iteratorClose Iterator m blk a
iter
        Maybe a -> m (Maybe a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
acc
      IteratorResult a
a -> do
        if a -> Bool
p a
a then Maybe a -> m (Maybe a)
go (a -> Maybe a
forall a. a -> Maybe a
Just a
a) else Maybe a -> m (Maybe a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
acc

mkLock :: MonadMVar m => m (StrictMVar m ())
mkLock :: forall (m :: * -> *). MonadMVar m => m (StrictMVar m ())
mkLock = () -> m (StrictMVar m ())
forall (m :: * -> *) a.
(HasCallStack, MonadMVar m, NoThunks a) =>
a -> m (StrictMVar m a)
newMVar ()

mkVerboseTracer :: Show a => StrictMVar IO () -> Bool -> IO (Tracer IO a)
mkVerboseTracer :: forall a. Show a => StrictMVar IO () -> Bool -> IO (Tracer IO a)
mkVerboseTracer StrictMVar IO ()
_ Bool
False = Tracer IO a -> IO (Tracer IO a)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Tracer IO a
forall a. Monoid a => a
mempty
mkVerboseTracer StrictMVar IO ()
lock Bool
True = do
  startTime <- IO Time
forall (m :: * -> *). MonadMonotonicTime m => m Time
getMonotonicTime
  pure $ mkTracer $ \a
ev -> do
    IO () -> IO () -> IO () -> IO ()
forall a b c. IO a -> IO b -> IO c -> IO c
forall (m :: * -> *) a b c.
MonadThrow m =>
m a -> m b -> m c -> m c
bracket_ (StrictMVar IO () -> IO ()
forall (m :: * -> *) a. MonadMVar m => StrictMVar m a -> m a
takeMVar StrictMVar IO ()
lock) (StrictMVar IO () -> () -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadMVar m) =>
StrictMVar m a -> a -> m ()
putMVar StrictMVar IO ()
lock ()) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      traceTime <- IO Time
forall (m :: * -> *). MonadMonotonicTime m => m Time
getMonotonicTime
      let diff = Time -> Time -> DiffTime
diffTime Time
traceTime Time
startTime
      hPutStrLn stderr $ concat ["[", show diff, "] ", show ev]
      hFlush stderr

withDB ::
  (Node.RunNode block, IOLike m) =>
  ImmutableDbArgs Identity m block ->
  ((ImmutableDB m block, Internal m block) -> m a) ->
  m a
withDB :: forall block (m :: * -> *) a.
(RunNode block, IOLike m) =>
ImmutableDbArgs Identity m block
-> ((ImmutableDB m block, Internal m block) -> m a) -> m a
withDB ImmutableDbArgs Identity m block
immutableDBArgs =
  m (ImmutableDB m block, Internal m block)
-> ((ImmutableDB m block, Internal m block) -> m ())
-> ((ImmutableDB m block, Internal m block) -> m a)
-> m a
forall a b c. m a -> (a -> m b) -> (a -> m c) -> m c
forall (m :: * -> *) a b c.
MonadThrow m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket (ImmutableDbArgs Identity m block
-> m (ImmutableDB m block, Internal m block)
forall (m :: * -> *) blk.
(IOLike m, GetPrevHash blk, ConvertRawHash blk,
 ImmutableDbSerialiseConstraints blk, HasCallStack) =>
Complete ImmutableDbArgs m blk
-> m (ImmutableDB m blk, Internal m blk)
ImmutableDB.openDBInternal ImmutableDbArgs Identity m block
immutableDBArgs) (ImmutableDB m block -> m ()
forall (m :: * -> *) blk. HasCallStack => ImmutableDB m blk -> m ()
ImmutableDB.closeDB (ImmutableDB m block -> m ())
-> ((ImmutableDB m block, Internal m block) -> ImmutableDB m block)
-> (ImmutableDB m block, Internal m block)
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ImmutableDB m block, Internal m block) -> ImmutableDB m block
forall a b. (a, b) -> a
fst)