{-# 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.IOLike
import           Prelude hiding (truncate)
import           System.IO

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
    StrictMVar IO ()
lock <- IO (StrictMVar IO ())
forall (m :: * -> *). MonadMVar m => m (StrictMVar m ())
mkLock
    Tracer IO (TraceEvent block)
immutableDBTracer <- StrictMVar IO () -> Bool -> IO (Tracer IO (TraceEvent block))
forall a. Show a => StrictMVar IO () -> Bool -> IO (Tracer IO a)
mkTracer StrictMVar IO ()
lock Bool
verbose
    ProtocolInfo {
      pInfoConfig :: forall b. ProtocolInfo b -> TopLevelConfig b
pInfoConfig = TopLevelConfig block
config
    } <- Args block -> IO (ProtocolInfo block)
forall blk.
HasProtocolInfo blk =>
Args blk -> IO (ProtocolInfo blk)
mkProtocolInfo Args block
args
    let
      fs :: SomeHasFS IO
fs = String -> RelativeMountPoint -> SomeHasFS IO
Node.stdMkChainDbHasFS String
dbDir (String -> RelativeMountPoint
RelativeMountPoint String
"immutable")
      chunkInfo :: ChunkInfo
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 :: ImmutableDbArgs Identity IO block
      immutableDBArgs :: ImmutableDbArgs Identity 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
          }

    ImmutableDbArgs Identity IO block
-> ((ImmutableDB IO block, Internal IO block) -> IO ()) -> IO ()
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 IO block
immutableDBArgs (((ImmutableDB IO block, Internal IO block) -> IO ()) -> IO ())
-> ((ImmutableDB IO block, Internal IO block) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(ImmutableDB IO block
immutableDB, Internal IO block
internal) -> do
      WithOrigin (Tip block)
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 :: Bool
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 Bool
truncationBeyondTip
      then String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Nothing to truncate, tip stays at " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> WithOrigin (Tip block) -> String
forall a. Show a => a -> String
show WithOrigin (Tip block)
tip
      else do
        Maybe (Header block)
mLastHdr :: Maybe (Header block) <- case TruncateAfter
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
              RealPoint block
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)
              IO (Header block) -> MaybeT IO (Header block)
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO (Header block) -> MaybeT IO (Header block))
-> IO (Header block) -> MaybeT IO (Header block)
forall a b. (a -> b) -> a -> b
$ ImmutableDB IO block
-> BlockComponent block (Header block)
-> RealPoint block
-> IO (Header block)
forall (m :: * -> *) blk b.
(MonadThrow m, HasHeader blk) =>
ImmutableDB m blk -> BlockComponent blk b -> RealPoint blk -> m b
ImmutableDB.getKnownBlockComponent ImmutableDB IO block
immutableDB BlockComponent block (Header block)
forall blk. BlockComponent blk (Header blk)
GetHeader RealPoint block
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 IO block (Header block)
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
            (Header block -> Bool)
-> Iterator IO block (Header block) -> IO (Maybe (Header block))
forall (m :: * -> *) a blk.
Monad m =>
(a -> Bool) -> Iterator m blk a -> m (Maybe a)
findLast ((BlockNo -> BlockNo -> Bool
forall a. Ord a => a -> a -> Bool
<= BlockNo
bno) (BlockNo -> Bool)
-> (Header block -> BlockNo) -> Header block -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Header block -> BlockNo
forall b. HasHeader b => b -> BlockNo
blockNo) Iterator IO block (Header block)
iterator

        case Header block -> Tip block
forall blk. GetHeader blk => Header blk -> Tip blk
ImmutableDB.headerToTip (Header block -> Tip block)
-> Maybe (Header block) -> Maybe (Tip block)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Header block)
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
  Time
startTime <- IO Time
forall (m :: * -> *). MonadMonotonicTime m => m Time
getMonotonicTime
  Tracer IO a -> IO (Tracer IO a)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Tracer IO a -> IO (Tracer IO a))
-> Tracer IO a -> IO (Tracer IO a)
forall a b. (a -> b) -> a -> b
$ (a -> IO ()) -> Tracer IO a
forall (m :: * -> *) a. (a -> m ()) -> Tracer m a
Tracer ((a -> IO ()) -> Tracer IO a) -> (a -> IO ()) -> Tracer IO a
forall a b. (a -> b) -> a -> b
$ \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
      Time
traceTime <- IO Time
forall (m :: * -> *). MonadMonotonicTime m => m Time
getMonotonicTime
      let diff :: DiffTime
diff = Time -> Time -> DiffTime
diffTime Time
traceTime Time
startTime
      Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [String
"[", DiffTime -> String
forall a. Show a => a -> String
show DiffTime
diff, String
"] ", a -> String
forall a. Show a => a -> String
show a
ev]
      Handle -> IO ()
hFlush Handle
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)