{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE UndecidableInstances #-}
module Cardano.Tools.DBImmutaliser.Run (
Opts (..)
, run
, DBDirs (..)
, withDBs
, TraceImmutalisationEvent (..)
, immutalise
) where
import qualified Cardano.Tools.DBAnalyser.Block.Cardano as Cardano
import Cardano.Tools.DBAnalyser.HasAnalysis (mkProtocolInfo)
import Control.Tracer (Tracer, stdoutTracer, traceWith)
import Data.Foldable (for_)
import Data.Functor.Contravariant ((>$<))
import Data.List.NonEmpty (NonEmpty)
import qualified Data.List.NonEmpty as NE
import Data.Semigroup (Arg (..), ArgMax, Max (..))
import Data.Traversable (for)
import Ouroboros.Consensus.Block
import Ouroboros.Consensus.Config
import Ouroboros.Consensus.Ledger.SupportsProtocol
import Ouroboros.Consensus.Node.InitStorage
import Ouroboros.Consensus.Node.ProtocolInfo (ProtocolInfo (..))
import Ouroboros.Consensus.Protocol.Abstract
import qualified Ouroboros.Consensus.Storage.ChainDB.Impl.Paths as Paths
import Ouroboros.Consensus.Storage.Common (BlockComponent (..))
import Ouroboros.Consensus.Storage.ImmutableDB (ImmutableDB,
ImmutableDbArgs (..), Tip, tipToPoint)
import qualified Ouroboros.Consensus.Storage.ImmutableDB as ImmutableDB
import Ouroboros.Consensus.Storage.VolatileDB (VolatileDB,
VolatileDbArgs (..))
import qualified Ouroboros.Consensus.Storage.VolatileDB.API as VolatileDB
import qualified Ouroboros.Consensus.Storage.VolatileDB.Impl as VolatileDB
import Ouroboros.Consensus.Util.Args
import Ouroboros.Consensus.Util.IOLike
import Ouroboros.Consensus.Util.ResourceRegistry
import Ouroboros.Network.Block (MaxSlotNo)
import System.FS.API (SomeHasFS (..))
import System.FS.API.Types (MountPoint (..))
import System.FS.IO (ioHasFS)
data Opts = Opts {
Opts -> DBDirs FilePath
dbDirs :: DBDirs FilePath
, Opts -> FilePath
configFile :: FilePath
}
run :: Opts -> IO ()
run :: Opts -> IO ()
run Opts {DBDirs FilePath
dbDirs :: Opts -> DBDirs FilePath
dbDirs :: DBDirs FilePath
dbDirs, FilePath
configFile :: Opts -> FilePath
configFile :: FilePath
configFile} = do
let dbDirs' :: DBDirs (SomeHasFS IO)
dbDirs' = HasFS IO HandleIO -> SomeHasFS IO
forall h (m :: * -> *). Eq h => HasFS m h -> SomeHasFS m
SomeHasFS (HasFS IO HandleIO -> SomeHasFS IO)
-> (FilePath -> HasFS IO HandleIO) -> FilePath -> SomeHasFS IO
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MountPoint -> HasFS IO HandleIO
forall (m :: * -> *).
(MonadIO m, PrimState IO ~ PrimState m) =>
MountPoint -> HasFS m HandleIO
ioHasFS (MountPoint -> HasFS IO HandleIO)
-> (FilePath -> MountPoint) -> FilePath -> HasFS IO HandleIO
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> MountPoint
MountPoint (FilePath -> SomeHasFS IO)
-> DBDirs FilePath -> DBDirs (SomeHasFS IO)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DBDirs FilePath
dbDirs
args :: Args (CardanoBlock StandardCrypto)
args = FilePath
-> Maybe PBftSignatureThreshold
-> Args (CardanoBlock StandardCrypto)
Cardano.CardanoBlockArgs FilePath
configFile Maybe PBftSignatureThreshold
forall a. Maybe a
Nothing
ProtocolInfo{pInfoConfig :: forall b. ProtocolInfo b -> TopLevelConfig b
pInfoConfig = TopLevelConfig (CardanoBlock StandardCrypto)
cfg} <- Args (CardanoBlock StandardCrypto)
-> IO (ProtocolInfo (CardanoBlock StandardCrypto))
forall blk.
HasProtocolInfo blk =>
Args blk -> IO (ProtocolInfo blk)
mkProtocolInfo Args (CardanoBlock StandardCrypto)
args
(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 ->
TopLevelConfig (CardanoBlock StandardCrypto)
-> ResourceRegistry IO
-> DBDirs (SomeHasFS IO)
-> (ImmutableDB IO (CardanoBlock StandardCrypto)
-> VolatileDB IO (CardanoBlock StandardCrypto) -> IO ())
-> IO ()
forall (m :: * -> *) blk a.
(IOLike m, ConvertRawHash blk, LedgerSupportsProtocol blk,
ImmutableDbSerialiseConstraints blk,
VolatileDbSerialiseConstraints blk, NodeInitStorage blk) =>
TopLevelConfig blk
-> ResourceRegistry m
-> DBDirs (SomeHasFS m)
-> (ImmutableDB m blk -> VolatileDB m blk -> m a)
-> m a
withDBs TopLevelConfig (CardanoBlock StandardCrypto)
cfg ResourceRegistry IO
registry DBDirs (SomeHasFS IO)
dbDirs' ((ImmutableDB IO (CardanoBlock StandardCrypto)
-> VolatileDB IO (CardanoBlock StandardCrypto) -> IO ())
-> IO ())
-> (ImmutableDB IO (CardanoBlock StandardCrypto)
-> VolatileDB IO (CardanoBlock StandardCrypto) -> IO ())
-> IO ()
forall a b. (a -> b) -> a -> b
$
BlockConfig (CardanoBlock StandardCrypto)
-> Tracer
IO (TraceImmutalisationEvent (CardanoBlock StandardCrypto))
-> ImmutableDB IO (CardanoBlock StandardCrypto)
-> VolatileDB IO (CardanoBlock StandardCrypto)
-> IO ()
forall (m :: * -> *) blk.
(IOLike m, BlockSupportsProtocol blk) =>
BlockConfig blk
-> Tracer m (TraceImmutalisationEvent blk)
-> ImmutableDB m blk
-> VolatileDB m blk
-> m ()
immutalise (TopLevelConfig (CardanoBlock StandardCrypto)
-> BlockConfig (CardanoBlock StandardCrypto)
forall blk. TopLevelConfig blk -> BlockConfig blk
configBlock TopLevelConfig (CardanoBlock StandardCrypto)
cfg) (TraceImmutalisationEvent (CardanoBlock StandardCrypto) -> FilePath
forall a. Show a => a -> FilePath
show (TraceImmutalisationEvent (CardanoBlock StandardCrypto)
-> FilePath)
-> Tracer IO FilePath
-> Tracer
IO (TraceImmutalisationEvent (CardanoBlock StandardCrypto))
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
>$< Tracer IO FilePath
forall (m :: * -> *). MonadIO m => Tracer m FilePath
stdoutTracer)
data DBDirs a = DBDirs {
forall a. DBDirs a -> a
immDBDir :: a
, forall a. DBDirs a -> a
volDBDir :: a
}
deriving stock ((forall a b. (a -> b) -> DBDirs a -> DBDirs b)
-> (forall a b. a -> DBDirs b -> DBDirs a) -> Functor DBDirs
forall a b. a -> DBDirs b -> DBDirs a
forall a b. (a -> b) -> DBDirs a -> DBDirs b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> DBDirs a -> DBDirs b
fmap :: forall a b. (a -> b) -> DBDirs a -> DBDirs b
$c<$ :: forall a b. a -> DBDirs b -> DBDirs a
<$ :: forall a b. a -> DBDirs b -> DBDirs a
Functor, (forall m. Monoid m => DBDirs m -> m)
-> (forall m a. Monoid m => (a -> m) -> DBDirs a -> m)
-> (forall m a. Monoid m => (a -> m) -> DBDirs a -> m)
-> (forall a b. (a -> b -> b) -> b -> DBDirs a -> b)
-> (forall a b. (a -> b -> b) -> b -> DBDirs a -> b)
-> (forall b a. (b -> a -> b) -> b -> DBDirs a -> b)
-> (forall b a. (b -> a -> b) -> b -> DBDirs a -> b)
-> (forall a. (a -> a -> a) -> DBDirs a -> a)
-> (forall a. (a -> a -> a) -> DBDirs a -> a)
-> (forall a. DBDirs a -> [a])
-> (forall a. DBDirs a -> Bool)
-> (forall a. DBDirs a -> Int)
-> (forall a. Eq a => a -> DBDirs a -> Bool)
-> (forall a. Ord a => DBDirs a -> a)
-> (forall a. Ord a => DBDirs a -> a)
-> (forall a. Num a => DBDirs a -> a)
-> (forall a. Num a => DBDirs a -> a)
-> Foldable DBDirs
forall a. Eq a => a -> DBDirs a -> Bool
forall a. Num a => DBDirs a -> a
forall a. Ord a => DBDirs a -> a
forall m. Monoid m => DBDirs m -> m
forall a. DBDirs a -> Bool
forall a. DBDirs a -> Int
forall a. DBDirs a -> [a]
forall a. (a -> a -> a) -> DBDirs a -> a
forall m a. Monoid m => (a -> m) -> DBDirs a -> m
forall b a. (b -> a -> b) -> b -> DBDirs a -> b
forall a b. (a -> b -> b) -> b -> DBDirs a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
$cfold :: forall m. Monoid m => DBDirs m -> m
fold :: forall m. Monoid m => DBDirs m -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> DBDirs a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> DBDirs a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> DBDirs a -> m
foldMap' :: forall m a. Monoid m => (a -> m) -> DBDirs a -> m
$cfoldr :: forall a b. (a -> b -> b) -> b -> DBDirs a -> b
foldr :: forall a b. (a -> b -> b) -> b -> DBDirs a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> DBDirs a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> DBDirs a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> DBDirs a -> b
foldl :: forall b a. (b -> a -> b) -> b -> DBDirs a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> DBDirs a -> b
foldl' :: forall b a. (b -> a -> b) -> b -> DBDirs a -> b
$cfoldr1 :: forall a. (a -> a -> a) -> DBDirs a -> a
foldr1 :: forall a. (a -> a -> a) -> DBDirs a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> DBDirs a -> a
foldl1 :: forall a. (a -> a -> a) -> DBDirs a -> a
$ctoList :: forall a. DBDirs a -> [a]
toList :: forall a. DBDirs a -> [a]
$cnull :: forall a. DBDirs a -> Bool
null :: forall a. DBDirs a -> Bool
$clength :: forall a. DBDirs a -> Int
length :: forall a. DBDirs a -> Int
$celem :: forall a. Eq a => a -> DBDirs a -> Bool
elem :: forall a. Eq a => a -> DBDirs a -> Bool
$cmaximum :: forall a. Ord a => DBDirs a -> a
maximum :: forall a. Ord a => DBDirs a -> a
$cminimum :: forall a. Ord a => DBDirs a -> a
minimum :: forall a. Ord a => DBDirs a -> a
$csum :: forall a. Num a => DBDirs a -> a
sum :: forall a. Num a => DBDirs a -> a
$cproduct :: forall a. Num a => DBDirs a -> a
product :: forall a. Num a => DBDirs a -> a
Foldable, Functor DBDirs
Foldable DBDirs
(Functor DBDirs, Foldable DBDirs) =>
(forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> DBDirs a -> f (DBDirs b))
-> (forall (f :: * -> *) a.
Applicative f =>
DBDirs (f a) -> f (DBDirs a))
-> (forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> DBDirs a -> m (DBDirs b))
-> (forall (m :: * -> *) a.
Monad m =>
DBDirs (m a) -> m (DBDirs a))
-> Traversable DBDirs
forall (t :: * -> *).
(Functor t, Foldable t) =>
(forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a. Monad m => DBDirs (m a) -> m (DBDirs a)
forall (f :: * -> *) a.
Applicative f =>
DBDirs (f a) -> f (DBDirs a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> DBDirs a -> m (DBDirs b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> DBDirs a -> f (DBDirs b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> DBDirs a -> f (DBDirs b)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> DBDirs a -> f (DBDirs b)
$csequenceA :: forall (f :: * -> *) a.
Applicative f =>
DBDirs (f a) -> f (DBDirs a)
sequenceA :: forall (f :: * -> *) a.
Applicative f =>
DBDirs (f a) -> f (DBDirs a)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> DBDirs a -> m (DBDirs b)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> DBDirs a -> m (DBDirs b)
$csequence :: forall (m :: * -> *) a. Monad m => DBDirs (m a) -> m (DBDirs a)
sequence :: forall (m :: * -> *) a. Monad m => DBDirs (m a) -> m (DBDirs a)
Traversable)
withDBs ::
forall m blk a.
( IOLike m
, ConvertRawHash blk
, LedgerSupportsProtocol blk
, ImmutableDB.ImmutableDbSerialiseConstraints blk
, VolatileDB.VolatileDbSerialiseConstraints blk
, NodeInitStorage blk
)
=> TopLevelConfig blk
-> ResourceRegistry m
-> DBDirs (SomeHasFS m)
-> (ImmutableDB m blk -> VolatileDB m blk -> m a)
-> m a
withDBs :: forall (m :: * -> *) blk a.
(IOLike m, ConvertRawHash blk, LedgerSupportsProtocol blk,
ImmutableDbSerialiseConstraints blk,
VolatileDbSerialiseConstraints blk, NodeInitStorage blk) =>
TopLevelConfig blk
-> ResourceRegistry m
-> DBDirs (SomeHasFS m)
-> (ImmutableDB m blk -> VolatileDB m blk -> m a)
-> m a
withDBs TopLevelConfig blk
cfg ResourceRegistry m
registry DBDirs (SomeHasFS m)
dbDirs ImmutableDB m blk -> VolatileDB m blk -> m a
f =
m (ImmutableDB m blk) -> (ImmutableDB m blk -> m a) -> m a
forall (m :: * -> *) blk a.
(HasCallStack, MonadThrow m) =>
m (ImmutableDB m blk) -> (ImmutableDB m blk -> m a) -> m a
ImmutableDB.withDB (Complete ImmutableDbArgs m blk
-> (forall st.
WithTempRegistry st m (ImmutableDB m blk, st)
-> m (ImmutableDB m blk))
-> m (ImmutableDB m blk)
forall (m :: * -> *) blk ans.
(IOLike m, GetPrevHash blk, ConvertRawHash blk,
ImmutableDbSerialiseConstraints blk, HasCallStack) =>
Complete ImmutableDbArgs m blk
-> (forall st.
WithTempRegistry st m (ImmutableDB m blk, st) -> ans)
-> ans
ImmutableDB.openDB Complete ImmutableDbArgs m blk
immDBArgs WithTempRegistry st m (ImmutableDB m blk, st)
-> m (ImmutableDB m blk)
forall st.
WithTempRegistry st m (ImmutableDB m blk, st)
-> m (ImmutableDB m blk)
forall (m :: * -> *) st a.
(IOLike m, HasCallStack) =>
WithTempRegistry st m (a, st) -> m a
runWithTempRegistry) ((ImmutableDB m blk -> m a) -> m a)
-> (ImmutableDB m blk -> m a) -> m a
forall a b. (a -> b) -> a -> b
$ \ImmutableDB m blk
immDB ->
m (VolatileDB m blk) -> (VolatileDB m blk -> m a) -> m a
forall (m :: * -> *) blk a.
(HasCallStack, MonadThrow m) =>
m (VolatileDB m blk) -> (VolatileDB m blk -> m a) -> m a
VolatileDB.withDB (Complete VolatileDbArgs m blk
-> (forall st.
WithTempRegistry st m (VolatileDB m blk, st)
-> m (VolatileDB m blk))
-> m (VolatileDB m blk)
forall (m :: * -> *) blk ans.
(HasCallStack, IOLike m, GetPrevHash blk,
VolatileDbSerialiseConstraints blk) =>
Complete VolatileDbArgs m blk
-> (forall st. WithTempRegistry st m (VolatileDB m blk, st) -> ans)
-> ans
VolatileDB.openDB Complete VolatileDbArgs m blk
volDBArgs WithTempRegistry st m (VolatileDB m blk, st)
-> m (VolatileDB m blk)
forall st.
WithTempRegistry st m (VolatileDB m blk, st)
-> m (VolatileDB m blk)
forall (m :: * -> *) st a.
(IOLike m, HasCallStack) =>
WithTempRegistry st m (a, st) -> m a
runWithTempRegistry) ((VolatileDB m blk -> m a) -> m a)
-> (VolatileDB m blk -> m a) -> m a
forall a b. (a -> b) -> a -> b
$ \VolatileDB m blk
volDB -> do
ImmutableDB m blk -> VolatileDB m blk -> m a
f ImmutableDB m blk
immDB VolatileDB m blk
volDB
where
codecCfg :: CodecConfig blk
codecCfg = TopLevelConfig blk -> CodecConfig blk
forall blk. TopLevelConfig blk -> CodecConfig blk
configCodec TopLevelConfig blk
cfg
storageCfg :: StorageConfig blk
storageCfg = TopLevelConfig blk -> StorageConfig blk
forall blk. TopLevelConfig blk -> StorageConfig blk
configStorage TopLevelConfig blk
cfg
immDBArgs :: Complete ImmutableDbArgs m blk
immDBArgs :: Complete ImmutableDbArgs m blk
immDBArgs = Incomplete ImmutableDbArgs m blk
forall (m :: * -> *) blk.
Applicative m =>
Incomplete ImmutableDbArgs m blk
ImmutableDB.defaultArgs {
immCheckIntegrity = nodeCheckIntegrity storageCfg
, immChunkInfo = nodeImmutableDbChunkInfo storageCfg
, immCodecConfig = codecCfg
, immRegistry = registry
, immHasFS = immDBDir dbDirs
}
volDBArgs :: Complete VolatileDbArgs m blk
volDBArgs :: Complete VolatileDbArgs m blk
volDBArgs = Incomplete VolatileDbArgs m blk
forall (m :: * -> *) blk.
Applicative m =>
Incomplete VolatileDbArgs m blk
VolatileDB.defaultArgs {
volCheckIntegrity = nodeCheckIntegrity (configStorage cfg)
, volCodecConfig = codecCfg
, volHasFS = volDBDir dbDirs
}
data TraceImmutalisationEvent blk =
TraceStartImmutalisation
(WithOrigin (Tip blk))
MaxSlotNo
|
TraceNoVolatileCandidate
|
TraceFoundCandidate
(HeaderHash blk)
Int
(SelectView (BlockProtocol blk))
| TraceCopiedtoImmutableDB
(WithOrigin (Tip blk))
deriving stock instance
( ConsensusProtocol (BlockProtocol blk)
, StandardHash blk
) => Show (TraceImmutalisationEvent blk)
immutalise ::
forall m blk.
( IOLike m
, BlockSupportsProtocol blk
)
=> BlockConfig blk
-> Tracer m (TraceImmutalisationEvent blk)
-> ImmutableDB m blk
-> VolatileDB m blk
-> m ()
immutalise :: forall (m :: * -> *) blk.
(IOLike m, BlockSupportsProtocol blk) =>
BlockConfig blk
-> Tracer m (TraceImmutalisationEvent blk)
-> ImmutableDB m blk
-> VolatileDB m blk
-> m ()
immutalise BlockConfig blk
bcfg Tracer m (TraceImmutalisationEvent blk)
tracer ImmutableDB m blk
immDB VolatileDB m blk
volDB = do
WithOrigin (Tip blk)
immTip <- STM m (WithOrigin (Tip blk)) -> m (WithOrigin (Tip blk))
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (WithOrigin (Tip blk)) -> m (WithOrigin (Tip blk)))
-> STM m (WithOrigin (Tip blk)) -> m (WithOrigin (Tip blk))
forall a b. (a -> b) -> a -> b
$ ImmutableDB m blk -> STM m (WithOrigin (Tip blk))
forall (m :: * -> *) blk.
HasCallStack =>
ImmutableDB m blk -> STM m (WithOrigin (Tip blk))
ImmutableDB.getTip ImmutableDB m blk
immDB
MaxSlotNo
volMaxSlotNo <- STM m MaxSlotNo -> m MaxSlotNo
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m MaxSlotNo -> m MaxSlotNo) -> STM m MaxSlotNo -> m MaxSlotNo
forall a b. (a -> b) -> a -> b
$ VolatileDB m blk -> HasCallStack => STM m MaxSlotNo
forall (m :: * -> *) blk.
VolatileDB m blk -> HasCallStack => STM m MaxSlotNo
VolatileDB.getMaxSlotNo VolatileDB m blk
volDB
Tracer m (TraceImmutalisationEvent blk)
-> TraceImmutalisationEvent blk -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (TraceImmutalisationEvent blk)
tracer (TraceImmutalisationEvent blk -> m ())
-> TraceImmutalisationEvent blk -> m ()
forall a b. (a -> b) -> a -> b
$ WithOrigin (Tip blk) -> MaxSlotNo -> TraceImmutalisationEvent blk
forall blk.
WithOrigin (Tip blk) -> MaxSlotNo -> TraceImmutalisationEvent blk
TraceStartImmutalisation WithOrigin (Tip blk)
immTip MaxSlotNo
volMaxSlotNo
ChainHash blk -> Set (HeaderHash blk)
succsOf <- STM m (ChainHash blk -> Set (HeaderHash blk))
-> m (ChainHash blk -> Set (HeaderHash blk))
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (ChainHash blk -> Set (HeaderHash blk))
-> m (ChainHash blk -> Set (HeaderHash blk)))
-> STM m (ChainHash blk -> Set (HeaderHash blk))
-> m (ChainHash blk -> Set (HeaderHash blk))
forall a b. (a -> b) -> a -> b
$ VolatileDB m blk
-> HasCallStack => STM m (ChainHash blk -> Set (HeaderHash blk))
forall (m :: * -> *) blk.
VolatileDB m blk
-> HasCallStack => STM m (ChainHash blk -> Set (HeaderHash blk))
VolatileDB.filterByPredecessor VolatileDB m blk
volDB
let candidates :: [NonEmpty (HeaderHash blk)]
candidates =
(ChainHash blk -> Set (HeaderHash blk))
-> Maybe Word64 -> Point blk -> [NonEmpty (HeaderHash blk)]
forall blk.
(ChainHash blk -> Set (HeaderHash blk))
-> Maybe Word64 -> Point blk -> [NonEmpty (HeaderHash blk)]
Paths.maximalCandidates ChainHash blk -> Set (HeaderHash blk)
succsOf Maybe Word64
forall a. Maybe a
Nothing (WithOrigin (Tip blk) -> Point blk
forall blk. WithOrigin (Tip blk) -> Point blk
tipToPoint WithOrigin (Tip blk)
immTip)
[(NonEmpty (HeaderHash blk), Header blk)]
candidatesAndTipHdrs <- [NonEmpty (HeaderHash blk)]
-> (NonEmpty (HeaderHash blk)
-> m (NonEmpty (HeaderHash blk), Header blk))
-> m [(NonEmpty (HeaderHash blk), Header blk)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [NonEmpty (HeaderHash blk)]
candidates ((NonEmpty (HeaderHash blk)
-> m (NonEmpty (HeaderHash blk), Header blk))
-> m [(NonEmpty (HeaderHash blk), Header blk)])
-> (NonEmpty (HeaderHash blk)
-> m (NonEmpty (HeaderHash blk), Header blk))
-> m [(NonEmpty (HeaderHash blk), Header blk)]
forall a b. (a -> b) -> a -> b
$ \NonEmpty (HeaderHash blk)
candidate -> do
Header blk
tipHdr <-
VolatileDB m blk
-> BlockComponent blk (Header blk)
-> HeaderHash blk
-> m (Header blk)
forall (m :: * -> *) blk b.
(MonadThrow m, HasHeader blk) =>
VolatileDB m blk -> BlockComponent blk b -> HeaderHash blk -> m b
VolatileDB.getKnownBlockComponent VolatileDB m blk
volDB BlockComponent blk (Header blk)
forall blk. BlockComponent blk (Header blk)
GetHeader (NonEmpty (HeaderHash blk) -> HeaderHash blk
forall a. NonEmpty a -> a
NE.last NonEmpty (HeaderHash blk)
candidate)
(NonEmpty (HeaderHash blk), Header blk)
-> m (NonEmpty (HeaderHash blk), Header blk)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NonEmpty (HeaderHash blk)
candidate, Header blk
tipHdr)
let mBestCandidate ::
Maybe (ArgMax (SelectView (BlockProtocol blk)) (NonEmpty (HeaderHash blk)))
mBestCandidate :: Maybe
(ArgMax
(SelectView (BlockProtocol blk)) (NonEmpty (HeaderHash blk)))
mBestCandidate = [Maybe
(ArgMax
(SelectView (BlockProtocol blk)) (NonEmpty (HeaderHash blk)))]
-> Maybe
(ArgMax
(SelectView (BlockProtocol blk)) (NonEmpty (HeaderHash blk)))
forall a. Monoid a => [a] -> a
mconcat ([Maybe
(ArgMax
(SelectView (BlockProtocol blk)) (NonEmpty (HeaderHash blk)))]
-> Maybe
(ArgMax
(SelectView (BlockProtocol blk)) (NonEmpty (HeaderHash blk))))
-> [Maybe
(ArgMax
(SelectView (BlockProtocol blk)) (NonEmpty (HeaderHash blk)))]
-> Maybe
(ArgMax
(SelectView (BlockProtocol blk)) (NonEmpty (HeaderHash blk)))
forall a b. (a -> b) -> a -> b
$ do
(NonEmpty (HeaderHash blk)
candidate, Header blk
tipHdr) <- [(NonEmpty (HeaderHash blk), Header blk)]
candidatesAndTipHdrs
Maybe
(ArgMax
(SelectView (BlockProtocol blk)) (NonEmpty (HeaderHash blk)))
-> [Maybe
(ArgMax
(SelectView (BlockProtocol blk)) (NonEmpty (HeaderHash blk)))]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe
(ArgMax
(SelectView (BlockProtocol blk)) (NonEmpty (HeaderHash blk)))
-> [Maybe
(ArgMax
(SelectView (BlockProtocol blk)) (NonEmpty (HeaderHash blk)))])
-> Maybe
(ArgMax
(SelectView (BlockProtocol blk)) (NonEmpty (HeaderHash blk)))
-> [Maybe
(ArgMax
(SelectView (BlockProtocol blk)) (NonEmpty (HeaderHash blk)))]
forall a b. (a -> b) -> a -> b
$ ArgMax (SelectView (BlockProtocol blk)) (NonEmpty (HeaderHash blk))
-> Maybe
(ArgMax
(SelectView (BlockProtocol blk)) (NonEmpty (HeaderHash blk)))
forall a. a -> Maybe a
Just (ArgMax
(SelectView (BlockProtocol blk)) (NonEmpty (HeaderHash blk))
-> Maybe
(ArgMax
(SelectView (BlockProtocol blk)) (NonEmpty (HeaderHash blk))))
-> ArgMax
(SelectView (BlockProtocol blk)) (NonEmpty (HeaderHash blk))
-> Maybe
(ArgMax
(SelectView (BlockProtocol blk)) (NonEmpty (HeaderHash blk)))
forall a b. (a -> b) -> a -> b
$ Arg (SelectView (BlockProtocol blk)) (NonEmpty (HeaderHash blk))
-> ArgMax
(SelectView (BlockProtocol blk)) (NonEmpty (HeaderHash blk))
forall a. a -> Max a
Max (Arg (SelectView (BlockProtocol blk)) (NonEmpty (HeaderHash blk))
-> ArgMax
(SelectView (BlockProtocol blk)) (NonEmpty (HeaderHash blk)))
-> Arg (SelectView (BlockProtocol blk)) (NonEmpty (HeaderHash blk))
-> ArgMax
(SelectView (BlockProtocol blk)) (NonEmpty (HeaderHash blk))
forall a b. (a -> b) -> a -> b
$ SelectView (BlockProtocol blk)
-> NonEmpty (HeaderHash blk)
-> Arg (SelectView (BlockProtocol blk)) (NonEmpty (HeaderHash blk))
forall a b. a -> b -> Arg a b
Arg (BlockConfig blk -> Header blk -> SelectView (BlockProtocol blk)
forall blk.
BlockSupportsProtocol blk =>
BlockConfig blk -> Header blk -> SelectView (BlockProtocol blk)
selectView BlockConfig blk
bcfg Header blk
tipHdr) NonEmpty (HeaderHash blk)
candidate
case Maybe
(ArgMax
(SelectView (BlockProtocol blk)) (NonEmpty (HeaderHash blk)))
mBestCandidate of
Maybe
(ArgMax
(SelectView (BlockProtocol blk)) (NonEmpty (HeaderHash blk)))
Nothing -> do
Tracer m (TraceImmutalisationEvent blk)
-> TraceImmutalisationEvent blk -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (TraceImmutalisationEvent blk)
tracer TraceImmutalisationEvent blk
forall blk. TraceImmutalisationEvent blk
TraceNoVolatileCandidate
Just (Max (Arg SelectView (BlockProtocol blk)
sv NonEmpty (HeaderHash blk)
candidate)) -> do
Tracer m (TraceImmutalisationEvent blk)
-> TraceImmutalisationEvent blk -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (TraceImmutalisationEvent blk)
tracer (TraceImmutalisationEvent blk -> m ())
-> TraceImmutalisationEvent blk -> m ()
forall a b. (a -> b) -> a -> b
$ HeaderHash blk
-> Int
-> SelectView (BlockProtocol blk)
-> TraceImmutalisationEvent blk
forall blk.
HeaderHash blk
-> Int
-> SelectView (BlockProtocol blk)
-> TraceImmutalisationEvent blk
TraceFoundCandidate
(NonEmpty (HeaderHash blk) -> HeaderHash blk
forall a. NonEmpty a -> a
NE.last NonEmpty (HeaderHash blk)
candidate)
(NonEmpty (HeaderHash blk) -> Int
forall a. NonEmpty a -> Int
NE.length NonEmpty (HeaderHash blk)
candidate)
SelectView (BlockProtocol blk)
sv
NonEmpty (HeaderHash blk) -> (HeaderHash blk -> m ()) -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ NonEmpty (HeaderHash blk)
candidate ((HeaderHash blk -> m ()) -> m ())
-> (HeaderHash blk -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \HeaderHash blk
hdrHash -> do
blk
blk <- VolatileDB m blk
-> BlockComponent blk blk -> HeaderHash blk -> m blk
forall (m :: * -> *) blk b.
(MonadThrow m, HasHeader blk) =>
VolatileDB m blk -> BlockComponent blk b -> HeaderHash blk -> m b
VolatileDB.getKnownBlockComponent VolatileDB m blk
volDB BlockComponent blk blk
forall blk. BlockComponent blk blk
GetBlock HeaderHash blk
hdrHash
ImmutableDB m blk -> blk -> m ()
forall (m :: * -> *) blk.
HasCallStack =>
ImmutableDB m blk -> blk -> m ()
ImmutableDB.appendBlock ImmutableDB m blk
immDB blk
blk
WithOrigin (Tip blk)
newImmTip <- STM m (WithOrigin (Tip blk)) -> m (WithOrigin (Tip blk))
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (WithOrigin (Tip blk)) -> m (WithOrigin (Tip blk)))
-> STM m (WithOrigin (Tip blk)) -> m (WithOrigin (Tip blk))
forall a b. (a -> b) -> a -> b
$ ImmutableDB m blk -> STM m (WithOrigin (Tip blk))
forall (m :: * -> *) blk.
HasCallStack =>
ImmutableDB m blk -> STM m (WithOrigin (Tip blk))
ImmutableDB.getTip ImmutableDB m blk
immDB
Tracer m (TraceImmutalisationEvent blk)
-> TraceImmutalisationEvent blk -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (TraceImmutalisationEvent blk)
tracer (TraceImmutalisationEvent blk -> m ())
-> TraceImmutalisationEvent blk -> m ()
forall a b. (a -> b) -> a -> b
$ WithOrigin (Tip blk) -> TraceImmutalisationEvent blk
forall blk. WithOrigin (Tip blk) -> TraceImmutalisationEvent blk
TraceCopiedtoImmutableDB WithOrigin (Tip blk)
newImmTip