{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE UndecidableInstances #-}

module Cardano.Tools.DBImmutaliser.Run (
    Opts (..)
  , run
    -- * Setup
  , DBDirs (..)
  , withDBs
    -- * Immutalise
  , TraceImmutalisationEvent (..)
  , immutalise
  ) where

import qualified Cardano.Tools.DBAnalyser.Block.Cardano as Cardano
import           Cardano.Tools.DBAnalyser.HasAnalysis (mkProtocolInfo)
import           Control.ResourceRegistry
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.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.
(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 ->
      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)

{-------------------------------------------------------------------------------
  Setup
-------------------------------------------------------------------------------}

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.
(MonadSTM m, MonadMask m, MonadThread 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.
(MonadSTM m, MonadMask m, MonadThread 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
        }

{-------------------------------------------------------------------------------
  Immutalise
-------------------------------------------------------------------------------}

data TraceImmutalisationEvent blk =
    TraceStartImmutalisation
      -- | Tip of the ImmutableDB.
      (WithOrigin (Tip blk))
      -- | 'MaxSlotNo' of the VolatileDB.
      MaxSlotNo
  | -- | No blocks in the VolatileDB extend the immutable tip.
    TraceNoVolatileCandidate
  | -- | Found a volatile candidate extending the immutable tip.
    TraceFoundCandidate
      -- | Hash of the candidate tip.
      (HeaderHash blk)
      -- | Blocks to be added to the ImmutableDB.
      Int
      -- | 'SelectView' of the candidate tip.
      (SelectView (BlockProtocol blk))
  | TraceCopiedtoImmutableDB
      -- | New tip of the ImmutableDB.
      (WithOrigin (Tip blk))

deriving stock instance
  ( ConsensusProtocol (BlockProtocol blk)
  , StandardHash blk
  ) => Show (TraceImmutalisationEvent blk)

-- data ImmutalisationException =

-- | Copy a specific chain from the given 'VolatileDB' to the 'ImmutableDB',
-- such that other tools that only work with an 'ImmutableDB' can process the
-- corresponding blocks.
--
-- This function requires exclusive access to the databases.
--
-- Currently, this will pick the best (according to the 'SelectView') chain
-- extending the immutable tip, and it will _not_ do any kind of validation.
--
-- Future work might include customizing this behavior, like:
--
--   * picking the best _valid_ chain (requires reading a ledger snapshot and/or
--     replaying)
--
--   * picking a chain that contains particular points (user input)
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

        -- Copy the candidate blocks from volDB to immDB.
        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