{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# 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 Control.Monad
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Maybe (MaybeT (..))
import Control.ResourceRegistry (runWithTempRegistry, 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.Util.Args
import Ouroboros.Consensus.Util.IOLike
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
  (ResourceRegistry IO -> IO ()) -> IO ()
forall (m :: * -> *) a.
(MonadSTM m, MonadMask m, MonadThread m, HasCallStack) =>
(ResourceRegistry m -> m a) -> m a
withRegistry ((ResourceRegistry IO -> IO ()) -> IO ())
-> (ResourceRegistry IO -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ResourceRegistry IO
registry -> do
    lock <- IO (StrictMVar IO ())
forall (m :: * -> *). MonadMVar m => m (StrictMVar m ())
mkLock
    immutableDBTracer <- mkTracer 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.
Applicative 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. String -> IO a
forall (m :: * -> *) a. MonadFail m => 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)

-- | 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 ()

mkTracer :: Show a => StrictMVar IO () -> Bool -> IO (Tracer IO a)
mkTracer :: forall a. Show a => StrictMVar IO () -> Bool -> IO (Tracer IO a)
mkTracer 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
mkTracer StrictMVar IO ()
lock Bool
True = do
  startTime <- IO Time
forall (m :: * -> *). MonadMonotonicTime m => m Time
getMonotonicTime
  pure $ Tracer $ \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
-> (forall h.
    WithTempRegistry
      (OpenState m block h)
      m
      ((ImmutableDB m block, Internal m block), OpenState m block h)
    -> m (ImmutableDB m block, Internal m block))
-> m (ImmutableDB m block, Internal m block)
forall (m :: * -> *) blk ans.
(IOLike m, GetPrevHash blk, ConvertRawHash blk,
 ImmutableDbSerialiseConstraints blk, HasCallStack) =>
Complete ImmutableDbArgs m blk
-> (forall h.
    WithTempRegistry
      (OpenState m blk h)
      m
      ((ImmutableDB m blk, Internal m blk), OpenState m blk h)
    -> ans)
-> ans
ImmutableDB.openDBInternal ImmutableDbArgs Identity m block
immutableDBArgs WithTempRegistry
  (OpenState m block h)
  m
  ((ImmutableDB m block, Internal m block), OpenState m block h)
-> m (ImmutableDB m block, Internal m block)
forall h.
WithTempRegistry
  (OpenState m block h)
  m
  ((ImmutableDB m block, Internal m block), OpenState m block h)
-> m (ImmutableDB m block, Internal m block)
forall (m :: * -> *) st a.
(MonadSTM m, MonadMask m, MonadThread m, HasCallStack) =>
WithTempRegistry st m (a, st) -> m a
runWithTempRegistry) (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)