{-# 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.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 Ouroboros.Consensus.Util.ResourceRegistry (runWithTempRegistry,
withRegistry)
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.
(IOLike 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
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)
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.
(IOLike 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)