{-# LANGUAGE BangPatterns        #-}
{-# LANGUAGE DeriveGeneric       #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE KindSignatures      #-}
{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE MultiWayIf          #-}
{-# LANGUAGE NamedFieldPuns      #-}
{-# LANGUAGE RankNTypes          #-}
{-# LANGUAGE RecordWildCards     #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections       #-}
{-# LANGUAGE TypeApplications    #-}

module Ouroboros.Consensus.Storage.LedgerDB.OnDisk (
    -- * Opening the database
    InitFailure (..)
  , InitLog (..)
  , initLedgerDB
    -- ** Instantiate in-memory to @blk@
  , AnnLedgerError'
  , LedgerDB'
    -- ** Abstraction over the stream API
  , NextBlock (..)
  , StreamAPI (..)
    -- * Read from disk
  , readSnapshot
    -- * Write to disk
  , takeSnapshot
  , trimSnapshots
  , writeSnapshot
    -- * Low-level API (primarily exposed for testing)
  , deleteSnapshot
  , snapshotToFileName
  , snapshotToPath
    -- ** opaque
  , DiskSnapshot (..)
    -- * Trace events
  , ReplayGoal (..)
  , ReplayStart (..)
  , TraceEvent (..)
  , TraceReplayEvent (..)
  , decorateReplayTracerWithGoal
  ) where

import qualified Codec.CBOR.Write as CBOR
import           Codec.Serialise.Decoding (Decoder)
import           Codec.Serialise.Encoding (Encoding)
import           Control.Monad.Except
import           Control.Tracer
import qualified Data.List as List
import           Data.Maybe (isJust, mapMaybe)
import           Data.Ord (Down (..))
import           Data.Set (Set)
import qualified Data.Set as Set
import           Data.Word
import           GHC.Generics (Generic)
import           GHC.Stack
import           Text.Read (readMaybe)

import           Ouroboros.Network.Block (Point (Point))

import           Ouroboros.Consensus.Block
import           Ouroboros.Consensus.HeaderValidation
                     (HeaderState (headerStateTip), annTipPoint)
import           Ouroboros.Consensus.Ledger.Abstract
import           Ouroboros.Consensus.Ledger.Extended
import           Ouroboros.Consensus.Ledger.Inspect
import           Ouroboros.Consensus.Ledger.SupportsProtocol
import           Ouroboros.Consensus.Util.CBOR (ReadIncrementalErr,
                     readIncremental)
import           Ouroboros.Consensus.Util.IOLike

import           Ouroboros.Consensus.Storage.FS.API
import           Ouroboros.Consensus.Storage.FS.API.Types

import           Ouroboros.Consensus.Storage.LedgerDB.DiskPolicy
import           Ouroboros.Consensus.Storage.LedgerDB.InMemory

{-------------------------------------------------------------------------------
  Instantiate the in-memory DB to @blk@
-------------------------------------------------------------------------------}

type LedgerDB'       blk = LedgerDB       (ExtLedgerState blk)
type AnnLedgerError' blk = AnnLedgerError (ExtLedgerState blk) blk

{-------------------------------------------------------------------------------
  Abstraction over the streaming API provided by the Chain DB
-------------------------------------------------------------------------------}

-- | Next block returned during streaming
data NextBlock blk = NoMoreBlocks | NextBlock blk

-- | Stream blocks from the immutable DB
--
-- When we initialize the ledger DB, we try to find a snapshot close to the
-- tip of the immutable DB, and then stream blocks from the immutable DB to its
-- tip to bring the ledger up to date with the tip of the immutable DB.
--
-- In CPS form to enable the use of 'withXYZ' style iterator init functions.
data StreamAPI m blk = StreamAPI {
      -- | Start streaming after the specified block
      StreamAPI m blk
-> forall a.
   HasCallStack =>
   Point blk
   -> (Either (RealPoint blk) (m (NextBlock blk)) -> m a) -> m a
streamAfter :: forall a. HasCallStack
        => Point blk
        -- Reference to the block corresponding to the snapshot we found
        -- (or 'GenesisPoint' if we didn't find any)

        -> (Either (RealPoint blk) (m (NextBlock blk)) -> m a)
        -- Get the next block (by value)
        --
        -- Should be @Left pt@ if the snapshot we found is more recent than the
        -- tip of the immutable DB. Since we only store snapshots to disk for
        -- blocks in the immutable DB, this can only happen if the immutable DB
        -- got truncated due to disk corruption. The returned @pt@ is a
        -- 'RealPoint', not a 'Point', since it must always be possible to
        -- stream after genesis.
        -> m a
    }

-- | Stream all blocks
streamAll ::
     forall m blk e a. (Monad m, HasCallStack)
  => StreamAPI m blk
  -> Point blk             -- ^ Starting point for streaming
  -> (RealPoint blk -> e)  -- ^ Error when tip not found
  -> a                     -- ^ Starting point when tip /is/ found
  -> (blk -> a -> m a)     -- ^ Update function for each block
  -> ExceptT e m a
streamAll :: StreamAPI m blk
-> Point blk
-> (RealPoint blk -> e)
-> a
-> (blk -> a -> m a)
-> ExceptT e m a
streamAll StreamAPI{forall a.
HasCallStack =>
Point blk
-> (Either (RealPoint blk) (m (NextBlock blk)) -> m a) -> m a
streamAfter :: forall a.
HasCallStack =>
Point blk
-> (Either (RealPoint blk) (m (NextBlock blk)) -> m a) -> m a
streamAfter :: forall (m :: * -> *) blk.
StreamAPI m blk
-> forall a.
   HasCallStack =>
   Point blk
   -> (Either (RealPoint blk) (m (NextBlock blk)) -> m a) -> m a
..} Point blk
tip RealPoint blk -> e
notFound a
e blk -> a -> m a
f = m (Either e a) -> ExceptT e m a
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (m (Either e a) -> ExceptT e m a)
-> m (Either e a) -> ExceptT e m a
forall a b. (a -> b) -> a -> b
$
    Point blk
-> (Either (RealPoint blk) (m (NextBlock blk)) -> m (Either e a))
-> m (Either e a)
forall a.
HasCallStack =>
Point blk
-> (Either (RealPoint blk) (m (NextBlock blk)) -> m a) -> m a
streamAfter Point blk
tip ((Either (RealPoint blk) (m (NextBlock blk)) -> m (Either e a))
 -> m (Either e a))
-> (Either (RealPoint blk) (m (NextBlock blk)) -> m (Either e a))
-> m (Either e a)
forall a b. (a -> b) -> a -> b
$ \case
      Left RealPoint blk
tip' -> Either e a -> m (Either e a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either e a -> m (Either e a)) -> Either e a -> m (Either e a)
forall a b. (a -> b) -> a -> b
$ e -> Either e a
forall a b. a -> Either a b
Left (RealPoint blk -> e
notFound RealPoint blk
tip')

      Right m (NextBlock blk)
getNext -> do
        let go :: a -> m a
            go :: a -> m a
go a
a = do NextBlock blk
mNext <- m (NextBlock blk)
getNext
                      case NextBlock blk
mNext of
                        NextBlock blk
NoMoreBlocks -> a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
                        NextBlock blk
b  -> a -> m a
go (a -> m a) -> m a -> m a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< blk -> a -> m a
f blk
b a
a
        a -> Either e a
forall a b. b -> Either a b
Right (a -> Either e a) -> m a -> m (Either e a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> m a
go a
e

{-------------------------------------------------------------------------------
  Initialize the DB
-------------------------------------------------------------------------------}

-- | Initialization log
--
-- The initialization log records which snapshots from disk were considered,
-- in which order, and why some snapshots were rejected. It is primarily useful
-- for monitoring purposes.
data InitLog blk =
    -- | Defaulted to initialization from genesis
    --
    -- NOTE: Unless the blockchain is near genesis, we should see this /only/
    -- if data corrupted occurred.
    InitFromGenesis

    -- | Used a snapshot corresponding to the specified tip
  | InitFromSnapshot DiskSnapshot (RealPoint blk)

    -- | Initialization skipped a snapshot
    --
    -- We record the reason why it was skipped.
    --
    -- NOTE: We should /only/ see this if data corrupted occurred.
  | InitFailure DiskSnapshot (InitFailure blk) (InitLog blk)
  deriving (Int -> InitLog blk -> ShowS
[InitLog blk] -> ShowS
InitLog blk -> String
(Int -> InitLog blk -> ShowS)
-> (InitLog blk -> String)
-> ([InitLog blk] -> ShowS)
-> Show (InitLog blk)
forall blk. StandardHash blk => Int -> InitLog blk -> ShowS
forall blk. StandardHash blk => [InitLog blk] -> ShowS
forall blk. StandardHash blk => InitLog blk -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [InitLog blk] -> ShowS
$cshowList :: forall blk. StandardHash blk => [InitLog blk] -> ShowS
show :: InitLog blk -> String
$cshow :: forall blk. StandardHash blk => InitLog blk -> String
showsPrec :: Int -> InitLog blk -> ShowS
$cshowsPrec :: forall blk. StandardHash blk => Int -> InitLog blk -> ShowS
Show, InitLog blk -> InitLog blk -> Bool
(InitLog blk -> InitLog blk -> Bool)
-> (InitLog blk -> InitLog blk -> Bool) -> Eq (InitLog blk)
forall blk. StandardHash blk => InitLog blk -> InitLog blk -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: InitLog blk -> InitLog blk -> Bool
$c/= :: forall blk. StandardHash blk => InitLog blk -> InitLog blk -> Bool
== :: InitLog blk -> InitLog blk -> Bool
$c== :: forall blk. StandardHash blk => InitLog blk -> InitLog blk -> Bool
Eq, (forall x. InitLog blk -> Rep (InitLog blk) x)
-> (forall x. Rep (InitLog blk) x -> InitLog blk)
-> Generic (InitLog blk)
forall x. Rep (InitLog blk) x -> InitLog blk
forall x. InitLog blk -> Rep (InitLog blk) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall blk x. Rep (InitLog blk) x -> InitLog blk
forall blk x. InitLog blk -> Rep (InitLog blk) x
$cto :: forall blk x. Rep (InitLog blk) x -> InitLog blk
$cfrom :: forall blk x. InitLog blk -> Rep (InitLog blk) x
Generic)

-- | Initialize the ledger DB from the most recent snapshot on disk
--
-- If no such snapshot can be found, use the genesis ledger DB. Returns the
-- initialized DB as well as the block reference corresponding to the snapshot
-- we found on disk (the latter primarily for testing/monitoring purposes).
--
-- We do /not/ catch any exceptions thrown during streaming; should any be
-- thrown, it is the responsibility of the 'ChainDB' to catch these
-- and trigger (further) validation. We only discard snapshots if
--
-- * We cannot deserialise them, or
-- * they are /ahead/ of the chain
--
-- It is possible that the Ledger DB will not be able to roll back @k@ blocks
-- after initialization if the chain has been truncated (data corruption).
--
-- We do /not/ attempt to use multiple ledger states from disk to construct the
-- ledger DB. Instead we load only a /single/ ledger state from disk, and
-- /compute/ all subsequent ones. This is important, because the ledger states
-- obtained in this way will (hopefully) share much of their memory footprint
-- with their predecessors.
initLedgerDB ::
     forall m blk. (
         IOLike m
       , LedgerSupportsProtocol blk
       , InspectLedger blk
       , HasCallStack
       )
  => Tracer m (ReplayGoal blk -> TraceReplayEvent blk)
  -> Tracer m (TraceEvent blk)
  -> SomeHasFS m
  -> (forall s. Decoder s (ExtLedgerState blk))
  -> (forall s. Decoder s (HeaderHash blk))
  -> LedgerDbCfg (ExtLedgerState blk)
  -> m (ExtLedgerState blk) -- ^ Genesis ledger state
  -> StreamAPI m blk
  -> m (InitLog blk, LedgerDB' blk, Word64)
initLedgerDB :: Tracer m (ReplayGoal blk -> TraceReplayEvent blk)
-> Tracer m (TraceEvent blk)
-> SomeHasFS m
-> (forall s. Decoder s (ExtLedgerState blk))
-> (forall s. Decoder s (HeaderHash blk))
-> LedgerDbCfg (ExtLedgerState blk)
-> m (ExtLedgerState blk)
-> StreamAPI m blk
-> m (InitLog blk, LedgerDB' blk, Word64)
initLedgerDB Tracer m (ReplayGoal blk -> TraceReplayEvent blk)
replayTracer
             Tracer m (TraceEvent blk)
tracer
             SomeHasFS m
hasFS
             forall s. Decoder s (ExtLedgerState blk)
decLedger
             forall s. Decoder s (HeaderHash blk)
decHash
             LedgerDbCfg (ExtLedgerState blk)
cfg
             m (ExtLedgerState blk)
getGenesisLedger
             StreamAPI m blk
streamAPI = do
    [DiskSnapshot]
snapshots <- SomeHasFS m -> m [DiskSnapshot]
forall (m :: * -> *). Monad m => SomeHasFS m -> m [DiskSnapshot]
listSnapshots SomeHasFS m
hasFS
    (InitLog blk -> InitLog blk)
-> [DiskSnapshot] -> m (InitLog blk, LedgerDB' blk, Word64)
tryNewestFirst InitLog blk -> InitLog blk
forall a. a -> a
id [DiskSnapshot]
snapshots
  where
    tryNewestFirst :: (InitLog blk -> InitLog blk)
                   -> [DiskSnapshot]
                   -> m (InitLog blk, LedgerDB' blk, Word64)
    tryNewestFirst :: (InitLog blk -> InitLog blk)
-> [DiskSnapshot] -> m (InitLog blk, LedgerDB' blk, Word64)
tryNewestFirst InitLog blk -> InitLog blk
acc [] = do
        -- We're out of snapshots. Start at genesis
        Tracer m (ReplayGoal blk -> TraceReplayEvent blk)
-> (ReplayGoal blk -> TraceReplayEvent blk) -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (ReplayGoal blk -> TraceReplayEvent blk)
replayTracer ReplayGoal blk -> TraceReplayEvent blk
forall blk. ReplayGoal blk -> TraceReplayEvent blk
ReplayFromGenesis
        LedgerDB' blk
initDb <- ExtLedgerState blk -> LedgerDB' blk
forall l. GetTip l => l -> LedgerDB l
ledgerDbWithAnchor (ExtLedgerState blk -> LedgerDB' blk)
-> m (ExtLedgerState blk) -> m (LedgerDB' blk)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (ExtLedgerState blk)
getGenesisLedger
        let replayTracer' :: Tracer
  m (ReplayStart blk -> ReplayGoal blk -> TraceReplayEvent blk)
replayTracer' = Point blk
-> Tracer m (ReplayGoal blk -> TraceReplayEvent blk)
-> Tracer
     m (ReplayStart blk -> ReplayGoal blk -> TraceReplayEvent blk)
forall blk (m :: * -> *).
Point blk
-> Tracer m (ReplayGoal blk -> TraceReplayEvent blk)
-> Tracer
     m (ReplayStart blk -> ReplayGoal blk -> TraceReplayEvent blk)
decorateReplayTracerWithStart (WithOrigin (Block SlotNo (HeaderHash blk)) -> Point blk
forall block.
WithOrigin (Block SlotNo (HeaderHash block)) -> Point block
Point WithOrigin (Block SlotNo (HeaderHash blk))
forall t. WithOrigin t
Origin) Tracer m (ReplayGoal blk -> TraceReplayEvent blk)
replayTracer
        Either (InitFailure blk) (LedgerDB' blk, Word64)
ml     <- ExceptT (InitFailure blk) m (LedgerDB' blk, Word64)
-> m (Either (InitFailure blk) (LedgerDB' blk, Word64))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT (InitFailure blk) m (LedgerDB' blk, Word64)
 -> m (Either (InitFailure blk) (LedgerDB' blk, Word64)))
-> ExceptT (InitFailure blk) m (LedgerDB' blk, Word64)
-> m (Either (InitFailure blk) (LedgerDB' blk, Word64))
forall a b. (a -> b) -> a -> b
$ Tracer
  m (ReplayStart blk -> ReplayGoal blk -> TraceReplayEvent blk)
-> LedgerDbCfg (ExtLedgerState blk)
-> StreamAPI m blk
-> LedgerDB' blk
-> ExceptT (InitFailure blk) m (LedgerDB' blk, Word64)
forall (m :: * -> *) blk.
(Monad m, LedgerSupportsProtocol blk, InspectLedger blk,
 HasCallStack) =>
Tracer
  m (ReplayStart blk -> ReplayGoal blk -> TraceReplayEvent blk)
-> LedgerDbCfg (ExtLedgerState blk)
-> StreamAPI m blk
-> LedgerDB' blk
-> ExceptT (InitFailure blk) m (LedgerDB' blk, Word64)
initStartingWith Tracer
  m (ReplayStart blk -> ReplayGoal blk -> TraceReplayEvent blk)
replayTracer' LedgerDbCfg (ExtLedgerState blk)
cfg StreamAPI m blk
streamAPI LedgerDB' blk
initDb
        case Either (InitFailure blk) (LedgerDB' blk, Word64)
ml of
          Left InitFailure blk
_  -> String -> m (InitLog blk, LedgerDB' blk, Word64)
forall a. HasCallStack => String -> a
error String
"invariant violation: invalid current chain"
          Right (LedgerDB' blk
l, Word64
replayed) -> (InitLog blk, LedgerDB' blk, Word64)
-> m (InitLog blk, LedgerDB' blk, Word64)
forall (m :: * -> *) a. Monad m => a -> m a
return (InitLog blk -> InitLog blk
acc InitLog blk
forall blk. InitLog blk
InitFromGenesis, LedgerDB' blk
l, Word64
replayed)
    tryNewestFirst InitLog blk -> InitLog blk
acc (DiskSnapshot
s:[DiskSnapshot]
ss) = do
        -- If we fail to use this snapshot, delete it and try an older one
        Either (InitFailure blk) (RealPoint blk, LedgerDB' blk, Word64)
ml <- ExceptT (InitFailure blk) m (RealPoint blk, LedgerDB' blk, Word64)
-> m (Either
        (InitFailure blk) (RealPoint blk, LedgerDB' blk, Word64))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT (InitFailure blk) m (RealPoint blk, LedgerDB' blk, Word64)
 -> m (Either
         (InitFailure blk) (RealPoint blk, LedgerDB' blk, Word64)))
-> ExceptT
     (InitFailure blk) m (RealPoint blk, LedgerDB' blk, Word64)
-> m (Either
        (InitFailure blk) (RealPoint blk, LedgerDB' blk, Word64))
forall a b. (a -> b) -> a -> b
$ Tracer m (ReplayGoal blk -> TraceReplayEvent blk)
-> SomeHasFS m
-> (forall s. Decoder s (ExtLedgerState blk))
-> (forall s. Decoder s (HeaderHash blk))
-> LedgerDbCfg (ExtLedgerState blk)
-> StreamAPI m blk
-> DiskSnapshot
-> ExceptT
     (InitFailure blk) m (RealPoint blk, LedgerDB' blk, Word64)
forall (m :: * -> *) blk.
(IOLike m, LedgerSupportsProtocol blk, InspectLedger blk,
 HasCallStack) =>
Tracer m (ReplayGoal blk -> TraceReplayEvent blk)
-> SomeHasFS m
-> (forall s. Decoder s (ExtLedgerState blk))
-> (forall s. Decoder s (HeaderHash blk))
-> LedgerDbCfg (ExtLedgerState blk)
-> StreamAPI m blk
-> DiskSnapshot
-> ExceptT
     (InitFailure blk) m (RealPoint blk, LedgerDB' blk, Word64)
initFromSnapshot
                             Tracer m (ReplayGoal blk -> TraceReplayEvent blk)
replayTracer
                             SomeHasFS m
hasFS
                             forall s. Decoder s (ExtLedgerState blk)
decLedger
                             forall s. Decoder s (HeaderHash blk)
decHash
                             LedgerDbCfg (ExtLedgerState blk)
cfg
                             StreamAPI m blk
streamAPI
                             DiskSnapshot
s
        case Either (InitFailure blk) (RealPoint blk, LedgerDB' blk, Word64)
ml of
          Left InitFailure blk
err -> do
            Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (DiskSnapshot -> Bool
diskSnapshotIsTemporary DiskSnapshot
s) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
              -- We don't delete permanent snapshots, even if we couldn't parse
              -- them
              SomeHasFS m -> DiskSnapshot -> m ()
forall (m :: * -> *).
HasCallStack =>
SomeHasFS m -> DiskSnapshot -> m ()
deleteSnapshot SomeHasFS m
hasFS DiskSnapshot
s
            Tracer m (TraceEvent blk) -> TraceEvent blk -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (TraceEvent blk)
tracer (TraceEvent blk -> m ()) -> TraceEvent blk -> m ()
forall a b. (a -> b) -> a -> b
$ DiskSnapshot -> InitFailure blk -> TraceEvent blk
forall blk. DiskSnapshot -> InitFailure blk -> TraceEvent blk
InvalidSnapshot DiskSnapshot
s InitFailure blk
err
            (InitLog blk -> InitLog blk)
-> [DiskSnapshot] -> m (InitLog blk, LedgerDB' blk, Word64)
tryNewestFirst (InitLog blk -> InitLog blk
acc (InitLog blk -> InitLog blk)
-> (InitLog blk -> InitLog blk) -> InitLog blk -> InitLog blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DiskSnapshot -> InitFailure blk -> InitLog blk -> InitLog blk
forall blk.
DiskSnapshot -> InitFailure blk -> InitLog blk -> InitLog blk
InitFailure DiskSnapshot
s InitFailure blk
err) [DiskSnapshot]
ss
          Right (RealPoint blk
r, LedgerDB' blk
l, Word64
replayed) ->
            (InitLog blk, LedgerDB' blk, Word64)
-> m (InitLog blk, LedgerDB' blk, Word64)
forall (m :: * -> *) a. Monad m => a -> m a
return (InitLog blk -> InitLog blk
acc (DiskSnapshot -> RealPoint blk -> InitLog blk
forall blk. DiskSnapshot -> RealPoint blk -> InitLog blk
InitFromSnapshot DiskSnapshot
s RealPoint blk
r), LedgerDB' blk
l, Word64
replayed)

{-------------------------------------------------------------------------------
  Internal: initialize using the given snapshot
-------------------------------------------------------------------------------}

data InitFailure blk =
    -- | We failed to deserialise the snapshot
    --
    -- This can happen due to data corruption in the ledger DB.
    InitFailureRead ReadIncrementalErr

    -- | This snapshot is too recent (ahead of the tip of the chain)
  | InitFailureTooRecent (RealPoint blk)

    -- | This snapshot was of the ledger state at genesis, even though we never
    -- take snapshots at genesis, so this is unexpected.
  | InitFailureGenesis
  deriving (Int -> InitFailure blk -> ShowS
[InitFailure blk] -> ShowS
InitFailure blk -> String
(Int -> InitFailure blk -> ShowS)
-> (InitFailure blk -> String)
-> ([InitFailure blk] -> ShowS)
-> Show (InitFailure blk)
forall blk. StandardHash blk => Int -> InitFailure blk -> ShowS
forall blk. StandardHash blk => [InitFailure blk] -> ShowS
forall blk. StandardHash blk => InitFailure blk -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [InitFailure blk] -> ShowS
$cshowList :: forall blk. StandardHash blk => [InitFailure blk] -> ShowS
show :: InitFailure blk -> String
$cshow :: forall blk. StandardHash blk => InitFailure blk -> String
showsPrec :: Int -> InitFailure blk -> ShowS
$cshowsPrec :: forall blk. StandardHash blk => Int -> InitFailure blk -> ShowS
Show, InitFailure blk -> InitFailure blk -> Bool
(InitFailure blk -> InitFailure blk -> Bool)
-> (InitFailure blk -> InitFailure blk -> Bool)
-> Eq (InitFailure blk)
forall blk.
StandardHash blk =>
InitFailure blk -> InitFailure blk -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: InitFailure blk -> InitFailure blk -> Bool
$c/= :: forall blk.
StandardHash blk =>
InitFailure blk -> InitFailure blk -> Bool
== :: InitFailure blk -> InitFailure blk -> Bool
$c== :: forall blk.
StandardHash blk =>
InitFailure blk -> InitFailure blk -> Bool
Eq, (forall x. InitFailure blk -> Rep (InitFailure blk) x)
-> (forall x. Rep (InitFailure blk) x -> InitFailure blk)
-> Generic (InitFailure blk)
forall x. Rep (InitFailure blk) x -> InitFailure blk
forall x. InitFailure blk -> Rep (InitFailure blk) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall blk x. Rep (InitFailure blk) x -> InitFailure blk
forall blk x. InitFailure blk -> Rep (InitFailure blk) x
$cto :: forall blk x. Rep (InitFailure blk) x -> InitFailure blk
$cfrom :: forall blk x. InitFailure blk -> Rep (InitFailure blk) x
Generic)

-- | Attempt to initialize the ledger DB from the given snapshot
--
-- If the chain DB or ledger layer reports an error, the whole thing is aborted
-- and an error is returned. This should not throw any errors itself (ignoring
-- unexpected exceptions such as asynchronous exceptions, of course).
initFromSnapshot ::
     forall m blk. (
         IOLike m
       , LedgerSupportsProtocol blk
       , InspectLedger blk
       , HasCallStack
       )
  => Tracer m (ReplayGoal blk -> TraceReplayEvent blk)
  -> SomeHasFS m
  -> (forall s. Decoder s (ExtLedgerState blk))
  -> (forall s. Decoder s (HeaderHash blk))
  -> LedgerDbCfg (ExtLedgerState blk)
  -> StreamAPI m blk
  -> DiskSnapshot
  -> ExceptT (InitFailure blk) m (RealPoint blk, LedgerDB' blk, Word64)
initFromSnapshot :: Tracer m (ReplayGoal blk -> TraceReplayEvent blk)
-> SomeHasFS m
-> (forall s. Decoder s (ExtLedgerState blk))
-> (forall s. Decoder s (HeaderHash blk))
-> LedgerDbCfg (ExtLedgerState blk)
-> StreamAPI m blk
-> DiskSnapshot
-> ExceptT
     (InitFailure blk) m (RealPoint blk, LedgerDB' blk, Word64)
initFromSnapshot Tracer m (ReplayGoal blk -> TraceReplayEvent blk)
tracer SomeHasFS m
hasFS forall s. Decoder s (ExtLedgerState blk)
decLedger forall s. Decoder s (HeaderHash blk)
decHash LedgerDbCfg (ExtLedgerState blk)
cfg StreamAPI m blk
streamAPI DiskSnapshot
ss = do
    ExtLedgerState blk
initSS <- (ReadIncrementalErr -> InitFailure blk)
-> ExceptT ReadIncrementalErr m (ExtLedgerState blk)
-> ExceptT (InitFailure blk) m (ExtLedgerState blk)
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT ReadIncrementalErr -> InitFailure blk
forall blk. ReadIncrementalErr -> InitFailure blk
InitFailureRead (ExceptT ReadIncrementalErr m (ExtLedgerState blk)
 -> ExceptT (InitFailure blk) m (ExtLedgerState blk))
-> ExceptT ReadIncrementalErr m (ExtLedgerState blk)
-> ExceptT (InitFailure blk) m (ExtLedgerState blk)
forall a b. (a -> b) -> a -> b
$
                SomeHasFS m
-> (forall s. Decoder s (ExtLedgerState blk))
-> (forall s. Decoder s (HeaderHash blk))
-> DiskSnapshot
-> ExceptT ReadIncrementalErr m (ExtLedgerState blk)
forall (m :: * -> *) blk.
IOLike m =>
SomeHasFS m
-> (forall s. Decoder s (ExtLedgerState blk))
-> (forall s. Decoder s (HeaderHash blk))
-> DiskSnapshot
-> ExceptT ReadIncrementalErr m (ExtLedgerState blk)
readSnapshot SomeHasFS m
hasFS forall s. Decoder s (ExtLedgerState blk)
decLedger forall s. Decoder s (HeaderHash blk)
decHash DiskSnapshot
ss
    let initialPoint :: Point blk
initialPoint = Point blk
-> (AnnTip blk -> Point blk)
-> WithOrigin (AnnTip blk)
-> Point blk
forall b t. b -> (t -> b) -> WithOrigin t -> b
withOrigin (WithOrigin (Block SlotNo (HeaderHash blk)) -> Point blk
forall block.
WithOrigin (Block SlotNo (HeaderHash block)) -> Point block
Point WithOrigin (Block SlotNo (HeaderHash blk))
forall t. WithOrigin t
Origin) AnnTip blk -> Point blk
forall blk. HasAnnTip blk => AnnTip blk -> Point blk
annTipPoint (WithOrigin (AnnTip blk) -> Point blk)
-> WithOrigin (AnnTip blk) -> Point blk
forall a b. (a -> b) -> a -> b
$ HeaderState blk -> WithOrigin (AnnTip blk)
forall blk. HeaderState blk -> WithOrigin (AnnTip blk)
headerStateTip (HeaderState blk -> WithOrigin (AnnTip blk))
-> HeaderState blk -> WithOrigin (AnnTip blk)
forall a b. (a -> b) -> a -> b
$ ExtLedgerState blk -> HeaderState blk
forall blk. ExtLedgerState blk -> HeaderState blk
headerState (ExtLedgerState blk -> HeaderState blk)
-> ExtLedgerState blk -> HeaderState blk
forall a b. (a -> b) -> a -> b
$ ExtLedgerState blk
initSS
    case Point blk -> WithOrigin (RealPoint blk)
forall blk. Point blk -> WithOrigin (RealPoint blk)
pointToWithOriginRealPoint (Point (ExtLedgerState blk) -> Point blk
forall b b'.
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint (ExtLedgerState blk -> Point (ExtLedgerState blk)
forall l. GetTip l => l -> Point l
getTip ExtLedgerState blk
initSS)) of
      WithOrigin (RealPoint blk)
Origin        -> InitFailure blk
-> ExceptT
     (InitFailure blk) m (RealPoint blk, LedgerDB' blk, Word64)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError InitFailure blk
forall blk. InitFailure blk
InitFailureGenesis
      NotOrigin RealPoint blk
tip -> do
        m () -> ExceptT (InitFailure blk) m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> ExceptT (InitFailure blk) m ())
-> m () -> ExceptT (InitFailure blk) m ()
forall a b. (a -> b) -> a -> b
$ Tracer m (ReplayGoal blk -> TraceReplayEvent blk)
-> (ReplayGoal blk -> TraceReplayEvent blk) -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (ReplayGoal blk -> TraceReplayEvent blk)
tracer ((ReplayGoal blk -> TraceReplayEvent blk) -> m ())
-> (ReplayGoal blk -> TraceReplayEvent blk) -> m ()
forall a b. (a -> b) -> a -> b
$ DiskSnapshot
-> RealPoint blk
-> ReplayStart blk
-> ReplayGoal blk
-> TraceReplayEvent blk
forall blk.
DiskSnapshot
-> RealPoint blk
-> ReplayStart blk
-> ReplayGoal blk
-> TraceReplayEvent blk
ReplayFromSnapshot DiskSnapshot
ss RealPoint blk
tip (Point blk -> ReplayStart blk
forall blk. Point blk -> ReplayStart blk
ReplayStart Point blk
initialPoint)
        let tracer' :: Tracer
  m (ReplayStart blk -> ReplayGoal blk -> TraceReplayEvent blk)
tracer' = Point blk
-> Tracer m (ReplayGoal blk -> TraceReplayEvent blk)
-> Tracer
     m (ReplayStart blk -> ReplayGoal blk -> TraceReplayEvent blk)
forall blk (m :: * -> *).
Point blk
-> Tracer m (ReplayGoal blk -> TraceReplayEvent blk)
-> Tracer
     m (ReplayStart blk -> ReplayGoal blk -> TraceReplayEvent blk)
decorateReplayTracerWithStart Point blk
initialPoint Tracer m (ReplayGoal blk -> TraceReplayEvent blk)
tracer
        (LedgerDB' blk
initDB, Word64
replayed) <-
          Tracer
  m (ReplayStart blk -> ReplayGoal blk -> TraceReplayEvent blk)
-> LedgerDbCfg (ExtLedgerState blk)
-> StreamAPI m blk
-> LedgerDB' blk
-> ExceptT (InitFailure blk) m (LedgerDB' blk, Word64)
forall (m :: * -> *) blk.
(Monad m, LedgerSupportsProtocol blk, InspectLedger blk,
 HasCallStack) =>
Tracer
  m (ReplayStart blk -> ReplayGoal blk -> TraceReplayEvent blk)
-> LedgerDbCfg (ExtLedgerState blk)
-> StreamAPI m blk
-> LedgerDB' blk
-> ExceptT (InitFailure blk) m (LedgerDB' blk, Word64)
initStartingWith
            Tracer
  m (ReplayStart blk -> ReplayGoal blk -> TraceReplayEvent blk)
tracer'
            LedgerDbCfg (ExtLedgerState blk)
cfg
            StreamAPI m blk
streamAPI
            (ExtLedgerState blk -> LedgerDB' blk
forall l. GetTip l => l -> LedgerDB l
ledgerDbWithAnchor ExtLedgerState blk
initSS)
        (RealPoint blk, LedgerDB' blk, Word64)
-> ExceptT
     (InitFailure blk) m (RealPoint blk, LedgerDB' blk, Word64)
forall (m :: * -> *) a. Monad m => a -> m a
return (RealPoint blk
tip, LedgerDB' blk
initDB, Word64
replayed)

-- | Attempt to initialize the ledger DB starting from the given ledger DB
initStartingWith ::
     forall m blk. (
         Monad m
       , LedgerSupportsProtocol blk
       , InspectLedger blk
       , HasCallStack
       )
  => Tracer m (ReplayStart blk -> ReplayGoal blk -> TraceReplayEvent blk)
  -> LedgerDbCfg (ExtLedgerState blk)
  -> StreamAPI m blk
  -> LedgerDB' blk
  -> ExceptT (InitFailure blk) m (LedgerDB' blk, Word64)
initStartingWith :: Tracer
  m (ReplayStart blk -> ReplayGoal blk -> TraceReplayEvent blk)
-> LedgerDbCfg (ExtLedgerState blk)
-> StreamAPI m blk
-> LedgerDB' blk
-> ExceptT (InitFailure blk) m (LedgerDB' blk, Word64)
initStartingWith Tracer
  m (ReplayStart blk -> ReplayGoal blk -> TraceReplayEvent blk)
tracer LedgerDbCfg (ExtLedgerState blk)
cfg StreamAPI m blk
streamAPI LedgerDB' blk
initDb = do
    StreamAPI m blk
-> Point blk
-> (RealPoint blk -> InitFailure blk)
-> (LedgerDB' blk, Word64)
-> (blk -> (LedgerDB' blk, Word64) -> m (LedgerDB' blk, Word64))
-> ExceptT (InitFailure blk) m (LedgerDB' blk, Word64)
forall (m :: * -> *) blk e a.
(Monad m, HasCallStack) =>
StreamAPI m blk
-> Point blk
-> (RealPoint blk -> e)
-> a
-> (blk -> a -> m a)
-> ExceptT e m a
streamAll StreamAPI m blk
streamAPI (Point (ExtLedgerState blk) -> Point blk
forall b b'.
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint (LedgerDB' blk -> Point (ExtLedgerState blk)
forall l. GetTip l => LedgerDB l -> Point l
ledgerDbTip LedgerDB' blk
initDb))
      RealPoint blk -> InitFailure blk
forall blk. RealPoint blk -> InitFailure blk
InitFailureTooRecent
      (LedgerDB' blk
initDb, Word64
0)
      blk -> (LedgerDB' blk, Word64) -> m (LedgerDB' blk, Word64)
push
  where
    push :: blk -> (LedgerDB' blk, Word64) -> m (LedgerDB' blk, Word64)
    push :: blk -> (LedgerDB' blk, Word64) -> m (LedgerDB' blk, Word64)
push blk
blk !(!LedgerDB' blk
db, !Word64
replayed) = do
        !LedgerDB' blk
db' <- LedgerDbCfg (ExtLedgerState blk)
-> Ap m (ExtLedgerState blk) blk (() :: Constraint)
-> LedgerDB' blk
-> m (LedgerDB' blk)
forall (m :: * -> *) (c :: Constraint) l blk.
(ApplyBlock l blk, Monad m, c) =>
LedgerDbCfg l -> Ap m l blk c -> LedgerDB l -> m (LedgerDB l)
ledgerDbPush LedgerDbCfg (ExtLedgerState blk)
cfg (blk -> Ap m (ExtLedgerState blk) blk (() :: Constraint)
forall blk (m :: * -> *) l. blk -> Ap m l blk (() :: Constraint)
ReapplyVal blk
blk) LedgerDB' blk
db

        let replayed' :: Word64
            !replayed' :: Word64
replayed' = Word64
replayed Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
1

            events :: [LedgerEvent blk]
            events :: [LedgerEvent blk]
events = TopLevelConfig blk
-> LedgerState blk -> LedgerState blk -> [LedgerEvent blk]
forall blk.
InspectLedger blk =>
TopLevelConfig blk
-> LedgerState blk -> LedgerState blk -> [LedgerEvent blk]
inspectLedger
                       (ExtLedgerCfg blk -> TopLevelConfig blk
forall blk. ExtLedgerCfg blk -> TopLevelConfig blk
getExtLedgerCfg (LedgerDbCfg (ExtLedgerState blk) -> LedgerCfg (ExtLedgerState blk)
forall l. LedgerDbCfg l -> LedgerCfg l
ledgerDbCfg LedgerDbCfg (ExtLedgerState blk)
cfg))
                       (ExtLedgerState blk -> LedgerState blk
forall blk. ExtLedgerState blk -> LedgerState blk
ledgerState (LedgerDB' blk -> ExtLedgerState blk
forall l. GetTip l => LedgerDB l -> l
ledgerDbCurrent LedgerDB' blk
db))
                       (ExtLedgerState blk -> LedgerState blk
forall blk. ExtLedgerState blk -> LedgerState blk
ledgerState (LedgerDB' blk -> ExtLedgerState blk
forall l. GetTip l => LedgerDB l -> l
ledgerDbCurrent LedgerDB' blk
db'))

        Tracer
  m (ReplayStart blk -> ReplayGoal blk -> TraceReplayEvent blk)
-> (ReplayStart blk -> ReplayGoal blk -> TraceReplayEvent blk)
-> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer
  m (ReplayStart blk -> ReplayGoal blk -> TraceReplayEvent blk)
tracer (RealPoint blk
-> [LedgerEvent blk]
-> ReplayStart blk
-> ReplayGoal blk
-> TraceReplayEvent blk
forall blk.
RealPoint blk
-> [LedgerEvent blk]
-> ReplayStart blk
-> ReplayGoal blk
-> TraceReplayEvent blk
ReplayedBlock (blk -> RealPoint blk
forall blk. HasHeader blk => blk -> RealPoint blk
blockRealPoint blk
blk) [LedgerEvent blk]
events)
        (LedgerDB' blk, Word64) -> m (LedgerDB' blk, Word64)
forall (m :: * -> *) a. Monad m => a -> m a
return (LedgerDB' blk
db', Word64
replayed')

{-------------------------------------------------------------------------------
  Write to disk
-------------------------------------------------------------------------------}

-- | Take a snapshot of the /oldest ledger state/ in the ledger DB
--
-- We write the /oldest/ ledger state to disk because the intention is to only
-- write ledger states to disk that we know to be immutable. Primarily for
-- testing purposes, 'takeSnapshot' returns the block reference corresponding
-- to the snapshot that we wrote.
--
-- If a snapshot with the same number already exists on disk or if the tip is at
-- genesis, no snapshot is taken.
--
-- Note that an EBB can have the same slot number and thus snapshot number as
-- the block after it. This doesn't matter. The one block difference in the
-- ledger state doesn't warrant an additional snapshot. The number in the name
-- of the snapshot is only indicative, we don't rely on it being correct.
--
-- NOTE: This is a lower-level API that takes a snapshot independent from
-- whether this snapshot corresponds to a state that is more than @k@ back.
--
-- TODO: Should we delete the file if an error occurs during writing?
takeSnapshot ::
     forall m blk. (MonadThrow m, IsLedger (LedgerState blk))
  => Tracer m (TraceEvent blk)
  -> SomeHasFS m
  -> (ExtLedgerState blk -> Encoding)
  -> LedgerDB' blk -> m (Maybe (DiskSnapshot, RealPoint blk))
takeSnapshot :: Tracer m (TraceEvent blk)
-> SomeHasFS m
-> (ExtLedgerState blk -> Encoding)
-> LedgerDB' blk
-> m (Maybe (DiskSnapshot, RealPoint blk))
takeSnapshot Tracer m (TraceEvent blk)
tracer SomeHasFS m
hasFS ExtLedgerState blk -> Encoding
encLedger LedgerDB' blk
db =
    case Point blk -> WithOrigin (RealPoint blk)
forall blk. Point blk -> WithOrigin (RealPoint blk)
pointToWithOriginRealPoint (Point (ExtLedgerState blk) -> Point blk
forall b b'.
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint (ExtLedgerState blk -> Point (ExtLedgerState blk)
forall l. GetTip l => l -> Point l
getTip ExtLedgerState blk
oldest)) of
      WithOrigin (RealPoint blk)
Origin ->
        Maybe (DiskSnapshot, RealPoint blk)
-> m (Maybe (DiskSnapshot, RealPoint blk))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (DiskSnapshot, RealPoint blk)
forall a. Maybe a
Nothing
      NotOrigin RealPoint blk
tip -> do
        let number :: Word64
number   = SlotNo -> Word64
unSlotNo (RealPoint blk -> SlotNo
forall blk. RealPoint blk -> SlotNo
realPointSlot RealPoint blk
tip)
            snapshot :: DiskSnapshot
snapshot = Word64 -> Maybe String -> DiskSnapshot
DiskSnapshot Word64
number Maybe String
forall a. Maybe a
Nothing
        [DiskSnapshot]
snapshots <- SomeHasFS m -> m [DiskSnapshot]
forall (m :: * -> *). Monad m => SomeHasFS m -> m [DiskSnapshot]
listSnapshots SomeHasFS m
hasFS
        if (DiskSnapshot -> Bool) -> [DiskSnapshot] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
List.any ((Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
number) (Word64 -> Bool)
-> (DiskSnapshot -> Word64) -> DiskSnapshot -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DiskSnapshot -> Word64
dsNumber) [DiskSnapshot]
snapshots then
          Maybe (DiskSnapshot, RealPoint blk)
-> m (Maybe (DiskSnapshot, RealPoint blk))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (DiskSnapshot, RealPoint blk)
forall a. Maybe a
Nothing
        else do
          SomeHasFS m
-> (ExtLedgerState blk -> Encoding)
-> DiskSnapshot
-> ExtLedgerState blk
-> m ()
forall (m :: * -> *) blk.
MonadThrow m =>
SomeHasFS m
-> (ExtLedgerState blk -> Encoding)
-> DiskSnapshot
-> ExtLedgerState blk
-> m ()
writeSnapshot SomeHasFS m
hasFS ExtLedgerState blk -> Encoding
encLedger DiskSnapshot
snapshot ExtLedgerState blk
oldest
          Tracer m (TraceEvent blk) -> TraceEvent blk -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (TraceEvent blk)
tracer (TraceEvent blk -> m ()) -> TraceEvent blk -> m ()
forall a b. (a -> b) -> a -> b
$ DiskSnapshot -> RealPoint blk -> TraceEvent blk
forall blk. DiskSnapshot -> RealPoint blk -> TraceEvent blk
TookSnapshot DiskSnapshot
snapshot RealPoint blk
tip
          Maybe (DiskSnapshot, RealPoint blk)
-> m (Maybe (DiskSnapshot, RealPoint blk))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (DiskSnapshot, RealPoint blk)
 -> m (Maybe (DiskSnapshot, RealPoint blk)))
-> Maybe (DiskSnapshot, RealPoint blk)
-> m (Maybe (DiskSnapshot, RealPoint blk))
forall a b. (a -> b) -> a -> b
$ (DiskSnapshot, RealPoint blk)
-> Maybe (DiskSnapshot, RealPoint blk)
forall a. a -> Maybe a
Just (DiskSnapshot
snapshot, RealPoint blk
tip)
  where
    oldest :: ExtLedgerState blk
    oldest :: ExtLedgerState blk
oldest = LedgerDB' blk -> ExtLedgerState blk
forall l. LedgerDB l -> l
ledgerDbAnchor LedgerDB' blk
db

-- | Trim the number of on disk snapshots so that at most 'onDiskNumSnapshots'
-- snapshots are stored on disk. The oldest snapshots are deleted.
--
-- The deleted snapshots are returned.
trimSnapshots ::
     Monad m
  => Tracer m (TraceEvent r)
  -> SomeHasFS m
  -> DiskPolicy
  -> m [DiskSnapshot]
trimSnapshots :: Tracer m (TraceEvent r)
-> SomeHasFS m -> DiskPolicy -> m [DiskSnapshot]
trimSnapshots Tracer m (TraceEvent r)
tracer SomeHasFS m
hasFS DiskPolicy{Word
TimeSinceLast DiffTime -> Word64 -> Bool
onDiskShouldTakeSnapshot :: DiskPolicy -> TimeSinceLast DiffTime -> Word64 -> Bool
onDiskNumSnapshots :: DiskPolicy -> Word
onDiskShouldTakeSnapshot :: TimeSinceLast DiffTime -> Word64 -> Bool
onDiskNumSnapshots :: Word
..} = do
    -- We only trim temporary snapshots
    [DiskSnapshot]
snapshots <- (DiskSnapshot -> Bool) -> [DiskSnapshot] -> [DiskSnapshot]
forall a. (a -> Bool) -> [a] -> [a]
filter DiskSnapshot -> Bool
diskSnapshotIsTemporary ([DiskSnapshot] -> [DiskSnapshot])
-> m [DiskSnapshot] -> m [DiskSnapshot]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SomeHasFS m -> m [DiskSnapshot]
forall (m :: * -> *). Monad m => SomeHasFS m -> m [DiskSnapshot]
listSnapshots SomeHasFS m
hasFS
    -- The snapshot are most recent first, so we can simply drop from the
    -- front to get the snapshots that are "too" old.
    [DiskSnapshot]
-> (DiskSnapshot -> m DiskSnapshot) -> m [DiskSnapshot]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (Int -> [DiskSnapshot] -> [DiskSnapshot]
forall a. Int -> [a] -> [a]
drop (Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
onDiskNumSnapshots) [DiskSnapshot]
snapshots) ((DiskSnapshot -> m DiskSnapshot) -> m [DiskSnapshot])
-> (DiskSnapshot -> m DiskSnapshot) -> m [DiskSnapshot]
forall a b. (a -> b) -> a -> b
$ \DiskSnapshot
snapshot -> do
      SomeHasFS m -> DiskSnapshot -> m ()
forall (m :: * -> *).
HasCallStack =>
SomeHasFS m -> DiskSnapshot -> m ()
deleteSnapshot SomeHasFS m
hasFS DiskSnapshot
snapshot
      Tracer m (TraceEvent r) -> TraceEvent r -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (TraceEvent r)
tracer (TraceEvent r -> m ()) -> TraceEvent r -> m ()
forall a b. (a -> b) -> a -> b
$ DiskSnapshot -> TraceEvent r
forall blk. DiskSnapshot -> TraceEvent blk
DeletedSnapshot DiskSnapshot
snapshot
      DiskSnapshot -> m DiskSnapshot
forall (m :: * -> *) a. Monad m => a -> m a
return DiskSnapshot
snapshot

{-------------------------------------------------------------------------------
  Internal: reading from disk
-------------------------------------------------------------------------------}

data DiskSnapshot = DiskSnapshot {
      -- | Snapshots are numbered. We will try the snapshots with the highest
      -- number first.
      --
      -- When creating a snapshot, we use the slot number of the ledger state it
      -- corresponds to as the snapshot number. This gives an indication of how
      -- recent the snapshot is.
      --
      -- Note that the snapshot names are only indicative, we don't rely on the
      -- snapshot number matching the slot number of the corresponding ledger
      -- state. We only use the snapshots numbers to determine the order in
      -- which we try them.
      DiskSnapshot -> Word64
dsNumber :: Word64

      -- | Snapshots can optionally have a suffix, separated by the snapshot
      -- number with an underscore, e.g., @4492799_last_Byron@. This suffix acts
      -- as metadata for the operator of the node. Snapshots with a suffix will
      -- /not be trimmed/.
    , DiskSnapshot -> Maybe String
dsSuffix :: Maybe String
    }
  deriving (Int -> DiskSnapshot -> ShowS
[DiskSnapshot] -> ShowS
DiskSnapshot -> String
(Int -> DiskSnapshot -> ShowS)
-> (DiskSnapshot -> String)
-> ([DiskSnapshot] -> ShowS)
-> Show DiskSnapshot
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DiskSnapshot] -> ShowS
$cshowList :: [DiskSnapshot] -> ShowS
show :: DiskSnapshot -> String
$cshow :: DiskSnapshot -> String
showsPrec :: Int -> DiskSnapshot -> ShowS
$cshowsPrec :: Int -> DiskSnapshot -> ShowS
Show, DiskSnapshot -> DiskSnapshot -> Bool
(DiskSnapshot -> DiskSnapshot -> Bool)
-> (DiskSnapshot -> DiskSnapshot -> Bool) -> Eq DiskSnapshot
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DiskSnapshot -> DiskSnapshot -> Bool
$c/= :: DiskSnapshot -> DiskSnapshot -> Bool
== :: DiskSnapshot -> DiskSnapshot -> Bool
$c== :: DiskSnapshot -> DiskSnapshot -> Bool
Eq, Eq DiskSnapshot
Eq DiskSnapshot
-> (DiskSnapshot -> DiskSnapshot -> Ordering)
-> (DiskSnapshot -> DiskSnapshot -> Bool)
-> (DiskSnapshot -> DiskSnapshot -> Bool)
-> (DiskSnapshot -> DiskSnapshot -> Bool)
-> (DiskSnapshot -> DiskSnapshot -> Bool)
-> (DiskSnapshot -> DiskSnapshot -> DiskSnapshot)
-> (DiskSnapshot -> DiskSnapshot -> DiskSnapshot)
-> Ord DiskSnapshot
DiskSnapshot -> DiskSnapshot -> Bool
DiskSnapshot -> DiskSnapshot -> Ordering
DiskSnapshot -> DiskSnapshot -> DiskSnapshot
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: DiskSnapshot -> DiskSnapshot -> DiskSnapshot
$cmin :: DiskSnapshot -> DiskSnapshot -> DiskSnapshot
max :: DiskSnapshot -> DiskSnapshot -> DiskSnapshot
$cmax :: DiskSnapshot -> DiskSnapshot -> DiskSnapshot
>= :: DiskSnapshot -> DiskSnapshot -> Bool
$c>= :: DiskSnapshot -> DiskSnapshot -> Bool
> :: DiskSnapshot -> DiskSnapshot -> Bool
$c> :: DiskSnapshot -> DiskSnapshot -> Bool
<= :: DiskSnapshot -> DiskSnapshot -> Bool
$c<= :: DiskSnapshot -> DiskSnapshot -> Bool
< :: DiskSnapshot -> DiskSnapshot -> Bool
$c< :: DiskSnapshot -> DiskSnapshot -> Bool
compare :: DiskSnapshot -> DiskSnapshot -> Ordering
$ccompare :: DiskSnapshot -> DiskSnapshot -> Ordering
$cp1Ord :: Eq DiskSnapshot
Ord, (forall x. DiskSnapshot -> Rep DiskSnapshot x)
-> (forall x. Rep DiskSnapshot x -> DiskSnapshot)
-> Generic DiskSnapshot
forall x. Rep DiskSnapshot x -> DiskSnapshot
forall x. DiskSnapshot -> Rep DiskSnapshot x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep DiskSnapshot x -> DiskSnapshot
$cfrom :: forall x. DiskSnapshot -> Rep DiskSnapshot x
Generic)

-- | Named snapshot are permanent, they will never be deleted when trimming.
diskSnapshotIsPermanent :: DiskSnapshot -> Bool
diskSnapshotIsPermanent :: DiskSnapshot -> Bool
diskSnapshotIsPermanent = Maybe String -> Bool
forall a. Maybe a -> Bool
isJust (Maybe String -> Bool)
-> (DiskSnapshot -> Maybe String) -> DiskSnapshot -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DiskSnapshot -> Maybe String
dsSuffix

-- | The snapshots that are periodically created are temporary, they will be
-- deleted when trimming
diskSnapshotIsTemporary :: DiskSnapshot -> Bool
diskSnapshotIsTemporary :: DiskSnapshot -> Bool
diskSnapshotIsTemporary = Bool -> Bool
not (Bool -> Bool) -> (DiskSnapshot -> Bool) -> DiskSnapshot -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DiskSnapshot -> Bool
diskSnapshotIsPermanent

-- | Read snapshot from disk
readSnapshot ::
     forall m blk. IOLike m
  => SomeHasFS m
  -> (forall s. Decoder s (ExtLedgerState blk))
  -> (forall s. Decoder s (HeaderHash blk))
  -> DiskSnapshot
  -> ExceptT ReadIncrementalErr m (ExtLedgerState blk)
readSnapshot :: SomeHasFS m
-> (forall s. Decoder s (ExtLedgerState blk))
-> (forall s. Decoder s (HeaderHash blk))
-> DiskSnapshot
-> ExceptT ReadIncrementalErr m (ExtLedgerState blk)
readSnapshot SomeHasFS m
hasFS forall s. Decoder s (ExtLedgerState blk)
decLedger forall s. Decoder s (HeaderHash blk)
decHash =
      m (Either ReadIncrementalErr (ExtLedgerState blk))
-> ExceptT ReadIncrementalErr m (ExtLedgerState blk)
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT
    (m (Either ReadIncrementalErr (ExtLedgerState blk))
 -> ExceptT ReadIncrementalErr m (ExtLedgerState blk))
-> (DiskSnapshot
    -> m (Either ReadIncrementalErr (ExtLedgerState blk)))
-> DiskSnapshot
-> ExceptT ReadIncrementalErr m (ExtLedgerState blk)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeHasFS m
-> (forall s. Decoder s (ExtLedgerState blk))
-> FsPath
-> m (Either ReadIncrementalErr (ExtLedgerState blk))
forall (m :: * -> *) a.
IOLike m =>
SomeHasFS m
-> (forall s. Decoder s a)
-> FsPath
-> m (Either ReadIncrementalErr a)
readIncremental SomeHasFS m
hasFS forall s. Decoder s (ExtLedgerState blk)
decoder
    (FsPath -> m (Either ReadIncrementalErr (ExtLedgerState blk)))
-> (DiskSnapshot -> FsPath)
-> DiskSnapshot
-> m (Either ReadIncrementalErr (ExtLedgerState blk))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DiskSnapshot -> FsPath
snapshotToPath
  where
    decoder :: Decoder s (ExtLedgerState blk)
    decoder :: Decoder s (ExtLedgerState blk)
decoder = Proxy blk
-> (forall s. Decoder s (ExtLedgerState blk))
-> (forall s. Decoder s (HeaderHash blk))
-> forall s. Decoder s (ExtLedgerState blk)
forall l blk.
Proxy blk
-> (forall s. Decoder s l)
-> (forall s. Decoder s (HeaderHash blk))
-> forall s. Decoder s l
decodeSnapshotBackwardsCompatible (Proxy blk
forall k (t :: k). Proxy t
Proxy @blk) forall s. Decoder s (ExtLedgerState blk)
decLedger forall s. Decoder s (HeaderHash blk)
decHash

-- | Write snapshot to disk
writeSnapshot ::
     forall m blk. MonadThrow m
  => SomeHasFS m
  -> (ExtLedgerState blk -> Encoding)
  -> DiskSnapshot
  -> ExtLedgerState blk -> m ()
writeSnapshot :: SomeHasFS m
-> (ExtLedgerState blk -> Encoding)
-> DiskSnapshot
-> ExtLedgerState blk
-> m ()
writeSnapshot (SomeHasFS HasFS m h
hasFS) ExtLedgerState blk -> Encoding
encLedger DiskSnapshot
ss ExtLedgerState blk
cs = do
    HasFS m h -> FsPath -> OpenMode -> (Handle h -> m ()) -> m ()
forall (m :: * -> *) h a.
(HasCallStack, MonadThrow m) =>
HasFS m h -> FsPath -> OpenMode -> (Handle h -> m a) -> m a
withFile HasFS m h
hasFS (DiskSnapshot -> FsPath
snapshotToPath DiskSnapshot
ss) (AllowExisting -> OpenMode
WriteMode AllowExisting
MustBeNew) ((Handle h -> m ()) -> m ()) -> (Handle h -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \Handle h
h ->
      m Word64 -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m Word64 -> m ()) -> m Word64 -> m ()
forall a b. (a -> b) -> a -> b
$ HasFS m h -> Handle h -> Builder -> m Word64
forall (m :: * -> *) h.
(HasCallStack, Monad m) =>
HasFS m h -> Handle h -> Builder -> m Word64
hPut HasFS m h
hasFS Handle h
h (Builder -> m Word64) -> Builder -> m Word64
forall a b. (a -> b) -> a -> b
$ Encoding -> Builder
CBOR.toBuilder (ExtLedgerState blk -> Encoding
encode ExtLedgerState blk
cs)
  where
    encode :: ExtLedgerState blk -> Encoding
    encode :: ExtLedgerState blk -> Encoding
encode = (ExtLedgerState blk -> Encoding) -> ExtLedgerState blk -> Encoding
forall l. (l -> Encoding) -> l -> Encoding
encodeSnapshot ExtLedgerState blk -> Encoding
encLedger

-- | Delete snapshot from disk
deleteSnapshot :: HasCallStack => SomeHasFS m -> DiskSnapshot -> m ()
deleteSnapshot :: SomeHasFS m -> DiskSnapshot -> m ()
deleteSnapshot (SomeHasFS HasFS{m String
HasCallStack => Bool -> FsPath -> m ()
HasCallStack => Handle h -> m Bool
HasCallStack => Handle h -> m Word64
HasCallStack => Handle h -> m ()
HasCallStack => Handle h -> Word64 -> m ()
HasCallStack => Handle h -> Word64 -> m ByteString
HasCallStack => Handle h -> Word64 -> AbsOffset -> m ByteString
HasCallStack => Handle h -> ByteString -> m Word64
HasCallStack => Handle h -> SeekMode -> Int64 -> m ()
HasCallStack => FsPath -> m Bool
HasCallStack => FsPath -> m ()
HasCallStack => FsPath -> m (Set String)
HasCallStack => FsPath -> FsPath -> m ()
HasCallStack => FsPath -> OpenMode -> m (Handle h)
FsPath -> FsErrorPath
mkFsErrorPath :: forall (m :: * -> *) h. HasFS m h -> FsPath -> FsErrorPath
renameFile :: forall (m :: * -> *) h.
HasFS m h -> HasCallStack => FsPath -> FsPath -> m ()
removeFile :: forall (m :: * -> *) h. HasFS m h -> HasCallStack => FsPath -> m ()
doesFileExist :: forall (m :: * -> *) h.
HasFS m h -> HasCallStack => FsPath -> m Bool
doesDirectoryExist :: forall (m :: * -> *) h.
HasFS m h -> HasCallStack => FsPath -> m Bool
listDirectory :: forall (m :: * -> *) h.
HasFS m h -> HasCallStack => FsPath -> m (Set String)
createDirectoryIfMissing :: forall (m :: * -> *) h.
HasFS m h -> HasCallStack => Bool -> FsPath -> m ()
createDirectory :: forall (m :: * -> *) h. HasFS m h -> HasCallStack => FsPath -> m ()
hGetSize :: forall (m :: * -> *) h.
HasFS m h -> HasCallStack => Handle h -> m Word64
hTruncate :: forall (m :: * -> *) h.
HasFS m h -> HasCallStack => Handle h -> Word64 -> m ()
hPutSome :: forall (m :: * -> *) h.
HasFS m h -> HasCallStack => Handle h -> ByteString -> m Word64
hGetSomeAt :: forall (m :: * -> *) h.
HasFS m h
-> HasCallStack => Handle h -> Word64 -> AbsOffset -> m ByteString
hGetSome :: forall (m :: * -> *) h.
HasFS m h -> HasCallStack => Handle h -> Word64 -> m ByteString
hSeek :: forall (m :: * -> *) h.
HasFS m h -> HasCallStack => Handle h -> SeekMode -> Int64 -> m ()
hIsOpen :: forall (m :: * -> *) h.
HasFS m h -> HasCallStack => Handle h -> m Bool
hClose :: forall (m :: * -> *) h.
HasFS m h -> HasCallStack => Handle h -> m ()
hOpen :: forall (m :: * -> *) h.
HasFS m h -> HasCallStack => FsPath -> OpenMode -> m (Handle h)
dumpState :: forall (m :: * -> *) h. HasFS m h -> m String
mkFsErrorPath :: FsPath -> FsErrorPath
renameFile :: HasCallStack => FsPath -> FsPath -> m ()
removeFile :: HasCallStack => FsPath -> m ()
doesFileExist :: HasCallStack => FsPath -> m Bool
doesDirectoryExist :: HasCallStack => FsPath -> m Bool
listDirectory :: HasCallStack => FsPath -> m (Set String)
createDirectoryIfMissing :: HasCallStack => Bool -> FsPath -> m ()
createDirectory :: HasCallStack => FsPath -> m ()
hGetSize :: HasCallStack => Handle h -> m Word64
hTruncate :: HasCallStack => Handle h -> Word64 -> m ()
hPutSome :: HasCallStack => Handle h -> ByteString -> m Word64
hGetSomeAt :: HasCallStack => Handle h -> Word64 -> AbsOffset -> m ByteString
hGetSome :: HasCallStack => Handle h -> Word64 -> m ByteString
hSeek :: HasCallStack => Handle h -> SeekMode -> Int64 -> m ()
hIsOpen :: HasCallStack => Handle h -> m Bool
hClose :: HasCallStack => Handle h -> m ()
hOpen :: HasCallStack => FsPath -> OpenMode -> m (Handle h)
dumpState :: m String
..}) = HasCallStack => FsPath -> m ()
FsPath -> m ()
removeFile (FsPath -> m ())
-> (DiskSnapshot -> FsPath) -> DiskSnapshot -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DiskSnapshot -> FsPath
snapshotToPath

-- | List on-disk snapshots, highest number first.
listSnapshots :: Monad m => SomeHasFS m -> m [DiskSnapshot]
listSnapshots :: SomeHasFS m -> m [DiskSnapshot]
listSnapshots (SomeHasFS HasFS{m String
HasCallStack => Bool -> FsPath -> m ()
HasCallStack => Handle h -> m Bool
HasCallStack => Handle h -> m Word64
HasCallStack => Handle h -> m ()
HasCallStack => Handle h -> Word64 -> m ()
HasCallStack => Handle h -> Word64 -> m ByteString
HasCallStack => Handle h -> Word64 -> AbsOffset -> m ByteString
HasCallStack => Handle h -> ByteString -> m Word64
HasCallStack => Handle h -> SeekMode -> Int64 -> m ()
HasCallStack => FsPath -> m Bool
HasCallStack => FsPath -> m ()
HasCallStack => FsPath -> m (Set String)
HasCallStack => FsPath -> FsPath -> m ()
HasCallStack => FsPath -> OpenMode -> m (Handle h)
FsPath -> FsErrorPath
mkFsErrorPath :: FsPath -> FsErrorPath
renameFile :: HasCallStack => FsPath -> FsPath -> m ()
removeFile :: HasCallStack => FsPath -> m ()
doesFileExist :: HasCallStack => FsPath -> m Bool
doesDirectoryExist :: HasCallStack => FsPath -> m Bool
listDirectory :: HasCallStack => FsPath -> m (Set String)
createDirectoryIfMissing :: HasCallStack => Bool -> FsPath -> m ()
createDirectory :: HasCallStack => FsPath -> m ()
hGetSize :: HasCallStack => Handle h -> m Word64
hTruncate :: HasCallStack => Handle h -> Word64 -> m ()
hPutSome :: HasCallStack => Handle h -> ByteString -> m Word64
hGetSomeAt :: HasCallStack => Handle h -> Word64 -> AbsOffset -> m ByteString
hGetSome :: HasCallStack => Handle h -> Word64 -> m ByteString
hSeek :: HasCallStack => Handle h -> SeekMode -> Int64 -> m ()
hIsOpen :: HasCallStack => Handle h -> m Bool
hClose :: HasCallStack => Handle h -> m ()
hOpen :: HasCallStack => FsPath -> OpenMode -> m (Handle h)
dumpState :: m String
mkFsErrorPath :: forall (m :: * -> *) h. HasFS m h -> FsPath -> FsErrorPath
renameFile :: forall (m :: * -> *) h.
HasFS m h -> HasCallStack => FsPath -> FsPath -> m ()
removeFile :: forall (m :: * -> *) h. HasFS m h -> HasCallStack => FsPath -> m ()
doesFileExist :: forall (m :: * -> *) h.
HasFS m h -> HasCallStack => FsPath -> m Bool
doesDirectoryExist :: forall (m :: * -> *) h.
HasFS m h -> HasCallStack => FsPath -> m Bool
listDirectory :: forall (m :: * -> *) h.
HasFS m h -> HasCallStack => FsPath -> m (Set String)
createDirectoryIfMissing :: forall (m :: * -> *) h.
HasFS m h -> HasCallStack => Bool -> FsPath -> m ()
createDirectory :: forall (m :: * -> *) h. HasFS m h -> HasCallStack => FsPath -> m ()
hGetSize :: forall (m :: * -> *) h.
HasFS m h -> HasCallStack => Handle h -> m Word64
hTruncate :: forall (m :: * -> *) h.
HasFS m h -> HasCallStack => Handle h -> Word64 -> m ()
hPutSome :: forall (m :: * -> *) h.
HasFS m h -> HasCallStack => Handle h -> ByteString -> m Word64
hGetSomeAt :: forall (m :: * -> *) h.
HasFS m h
-> HasCallStack => Handle h -> Word64 -> AbsOffset -> m ByteString
hGetSome :: forall (m :: * -> *) h.
HasFS m h -> HasCallStack => Handle h -> Word64 -> m ByteString
hSeek :: forall (m :: * -> *) h.
HasFS m h -> HasCallStack => Handle h -> SeekMode -> Int64 -> m ()
hIsOpen :: forall (m :: * -> *) h.
HasFS m h -> HasCallStack => Handle h -> m Bool
hClose :: forall (m :: * -> *) h.
HasFS m h -> HasCallStack => Handle h -> m ()
hOpen :: forall (m :: * -> *) h.
HasFS m h -> HasCallStack => FsPath -> OpenMode -> m (Handle h)
dumpState :: forall (m :: * -> *) h. HasFS m h -> m String
..}) =
    Set String -> [DiskSnapshot]
aux (Set String -> [DiskSnapshot])
-> m (Set String) -> m [DiskSnapshot]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HasCallStack => FsPath -> m (Set String)
FsPath -> m (Set String)
listDirectory ([String] -> FsPath
mkFsPath [])
  where
    aux :: Set String -> [DiskSnapshot]
    aux :: Set String -> [DiskSnapshot]
aux = (DiskSnapshot -> Down Word64) -> [DiskSnapshot] -> [DiskSnapshot]
forall b a. Ord b => (a -> b) -> [a] -> [a]
List.sortOn (Word64 -> Down Word64
forall a. a -> Down a
Down (Word64 -> Down Word64)
-> (DiskSnapshot -> Word64) -> DiskSnapshot -> Down Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DiskSnapshot -> Word64
dsNumber) ([DiskSnapshot] -> [DiskSnapshot])
-> (Set String -> [DiskSnapshot]) -> Set String -> [DiskSnapshot]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Maybe DiskSnapshot) -> [String] -> [DiskSnapshot]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe String -> Maybe DiskSnapshot
snapshotFromPath ([String] -> [DiskSnapshot])
-> (Set String -> [String]) -> Set String -> [DiskSnapshot]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set String -> [String]
forall a. Set a -> [a]
Set.toList

snapshotToFileName :: DiskSnapshot -> String
snapshotToFileName :: DiskSnapshot -> String
snapshotToFileName DiskSnapshot { Word64
dsNumber :: Word64
dsNumber :: DiskSnapshot -> Word64
dsNumber, Maybe String
dsSuffix :: Maybe String
dsSuffix :: DiskSnapshot -> Maybe String
dsSuffix } =
    Word64 -> String
forall a. Show a => a -> String
show Word64
dsNumber String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
suffix
  where
    suffix :: String
suffix = case Maybe String
dsSuffix of
      Maybe String
Nothing -> String
""
      Just String
s  -> String
"_" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
s

snapshotToPath :: DiskSnapshot -> FsPath
snapshotToPath :: DiskSnapshot -> FsPath
snapshotToPath = [String] -> FsPath
mkFsPath ([String] -> FsPath)
-> (DiskSnapshot -> [String]) -> DiskSnapshot -> FsPath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> [String] -> [String]
forall a. a -> [a] -> [a]
:[]) (String -> [String])
-> (DiskSnapshot -> String) -> DiskSnapshot -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DiskSnapshot -> String
snapshotToFileName

snapshotFromPath :: String -> Maybe DiskSnapshot
snapshotFromPath :: String -> Maybe DiskSnapshot
snapshotFromPath String
fileName = do
    Word64
number <- String -> Maybe Word64
forall a. Read a => String -> Maybe a
readMaybe String
prefix
    DiskSnapshot -> Maybe DiskSnapshot
forall (m :: * -> *) a. Monad m => a -> m a
return (DiskSnapshot -> Maybe DiskSnapshot)
-> DiskSnapshot -> Maybe DiskSnapshot
forall a b. (a -> b) -> a -> b
$ Word64 -> Maybe String -> DiskSnapshot
DiskSnapshot Word64
number Maybe String
suffix'
  where
    (String
prefix, String
suffix) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_') String
fileName

    suffix' :: Maybe String
    suffix' :: Maybe String
suffix' = case String
suffix of
      String
""      -> Maybe String
forall a. Maybe a
Nothing
      Char
_ : String
str -> String -> Maybe String
forall a. a -> Maybe a
Just String
str

{-------------------------------------------------------------------------------
  Trace events
-------------------------------------------------------------------------------}

-- | Add the tip of the Immutable DB to the trace event
--
-- Between the tip of the immutable DB and the point of the starting block,
-- the node could (if it so desired) easily compute a "percentage complete".
decorateReplayTracerWithGoal
  :: Point blk -- ^ Tip of the ImmutableDB
  -> Tracer m (TraceReplayEvent blk)
  -> Tracer m (ReplayGoal blk -> TraceReplayEvent blk)
decorateReplayTracerWithGoal :: Point blk
-> Tracer m (TraceReplayEvent blk)
-> Tracer m (ReplayGoal blk -> TraceReplayEvent blk)
decorateReplayTracerWithGoal Point blk
immTip = ((ReplayGoal blk -> TraceReplayEvent blk) -> TraceReplayEvent blk)
-> Tracer m (TraceReplayEvent blk)
-> Tracer m (ReplayGoal blk -> TraceReplayEvent blk)
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap ((ReplayGoal blk -> TraceReplayEvent blk)
-> ReplayGoal blk -> TraceReplayEvent blk
forall a b. (a -> b) -> a -> b
$ (Point blk -> ReplayGoal blk
forall blk. Point blk -> ReplayGoal blk
ReplayGoal Point blk
immTip))

-- | Add the block at which a replay started.
--
-- This allows to compute a "percentage complete" when tracing the events.
decorateReplayTracerWithStart
  :: Point blk -- ^ Starting point of the replay
  -> Tracer m (ReplayGoal blk -> TraceReplayEvent blk)
  -> Tracer m (ReplayStart blk -> ReplayGoal blk -> TraceReplayEvent blk)
decorateReplayTracerWithStart :: Point blk
-> Tracer m (ReplayGoal blk -> TraceReplayEvent blk)
-> Tracer
     m (ReplayStart blk -> ReplayGoal blk -> TraceReplayEvent blk)
decorateReplayTracerWithStart Point blk
start = ((ReplayStart blk -> ReplayGoal blk -> TraceReplayEvent blk)
 -> ReplayGoal blk -> TraceReplayEvent blk)
-> Tracer m (ReplayGoal blk -> TraceReplayEvent blk)
-> Tracer
     m (ReplayStart blk -> ReplayGoal blk -> TraceReplayEvent blk)
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap ((ReplayStart blk -> ReplayGoal blk -> TraceReplayEvent blk)
-> ReplayStart blk -> ReplayGoal blk -> TraceReplayEvent blk
forall a b. (a -> b) -> a -> b
$ (Point blk -> ReplayStart blk
forall blk. Point blk -> ReplayStart blk
ReplayStart Point blk
start))

data TraceEvent blk
  = InvalidSnapshot DiskSnapshot (InitFailure blk)
    -- ^ An on disk snapshot was skipped because it was invalid.
  | TookSnapshot DiskSnapshot (RealPoint blk)
    -- ^ A snapshot was written to disk.
  | DeletedSnapshot DiskSnapshot
    -- ^ An old or invalid on-disk snapshot was deleted
  deriving ((forall x. TraceEvent blk -> Rep (TraceEvent blk) x)
-> (forall x. Rep (TraceEvent blk) x -> TraceEvent blk)
-> Generic (TraceEvent blk)
forall x. Rep (TraceEvent blk) x -> TraceEvent blk
forall x. TraceEvent blk -> Rep (TraceEvent blk) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall blk x. Rep (TraceEvent blk) x -> TraceEvent blk
forall blk x. TraceEvent blk -> Rep (TraceEvent blk) x
$cto :: forall blk x. Rep (TraceEvent blk) x -> TraceEvent blk
$cfrom :: forall blk x. TraceEvent blk -> Rep (TraceEvent blk) x
Generic, TraceEvent blk -> TraceEvent blk -> Bool
(TraceEvent blk -> TraceEvent blk -> Bool)
-> (TraceEvent blk -> TraceEvent blk -> Bool)
-> Eq (TraceEvent blk)
forall blk.
StandardHash blk =>
TraceEvent blk -> TraceEvent blk -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TraceEvent blk -> TraceEvent blk -> Bool
$c/= :: forall blk.
StandardHash blk =>
TraceEvent blk -> TraceEvent blk -> Bool
== :: TraceEvent blk -> TraceEvent blk -> Bool
$c== :: forall blk.
StandardHash blk =>
TraceEvent blk -> TraceEvent blk -> Bool
Eq, Int -> TraceEvent blk -> ShowS
[TraceEvent blk] -> ShowS
TraceEvent blk -> String
(Int -> TraceEvent blk -> ShowS)
-> (TraceEvent blk -> String)
-> ([TraceEvent blk] -> ShowS)
-> Show (TraceEvent blk)
forall blk. StandardHash blk => Int -> TraceEvent blk -> ShowS
forall blk. StandardHash blk => [TraceEvent blk] -> ShowS
forall blk. StandardHash blk => TraceEvent blk -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TraceEvent blk] -> ShowS
$cshowList :: forall blk. StandardHash blk => [TraceEvent blk] -> ShowS
show :: TraceEvent blk -> String
$cshow :: forall blk. StandardHash blk => TraceEvent blk -> String
showsPrec :: Int -> TraceEvent blk -> ShowS
$cshowsPrec :: forall blk. StandardHash blk => Int -> TraceEvent blk -> ShowS
Show)

-- | Which point the replay started from
newtype ReplayStart blk = ReplayStart (Point blk) deriving (ReplayStart blk -> ReplayStart blk -> Bool
(ReplayStart blk -> ReplayStart blk -> Bool)
-> (ReplayStart blk -> ReplayStart blk -> Bool)
-> Eq (ReplayStart blk)
forall blk.
StandardHash blk =>
ReplayStart blk -> ReplayStart blk -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ReplayStart blk -> ReplayStart blk -> Bool
$c/= :: forall blk.
StandardHash blk =>
ReplayStart blk -> ReplayStart blk -> Bool
== :: ReplayStart blk -> ReplayStart blk -> Bool
$c== :: forall blk.
StandardHash blk =>
ReplayStart blk -> ReplayStart blk -> Bool
Eq, Int -> ReplayStart blk -> ShowS
[ReplayStart blk] -> ShowS
ReplayStart blk -> String
(Int -> ReplayStart blk -> ShowS)
-> (ReplayStart blk -> String)
-> ([ReplayStart blk] -> ShowS)
-> Show (ReplayStart blk)
forall blk. StandardHash blk => Int -> ReplayStart blk -> ShowS
forall blk. StandardHash blk => [ReplayStart blk] -> ShowS
forall blk. StandardHash blk => ReplayStart blk -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ReplayStart blk] -> ShowS
$cshowList :: forall blk. StandardHash blk => [ReplayStart blk] -> ShowS
show :: ReplayStart blk -> String
$cshow :: forall blk. StandardHash blk => ReplayStart blk -> String
showsPrec :: Int -> ReplayStart blk -> ShowS
$cshowsPrec :: forall blk. StandardHash blk => Int -> ReplayStart blk -> ShowS
Show)

-- | Which point the replay is expected to end at
newtype ReplayGoal blk = ReplayGoal (Point blk) deriving (ReplayGoal blk -> ReplayGoal blk -> Bool
(ReplayGoal blk -> ReplayGoal blk -> Bool)
-> (ReplayGoal blk -> ReplayGoal blk -> Bool)
-> Eq (ReplayGoal blk)
forall blk.
StandardHash blk =>
ReplayGoal blk -> ReplayGoal blk -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ReplayGoal blk -> ReplayGoal blk -> Bool
$c/= :: forall blk.
StandardHash blk =>
ReplayGoal blk -> ReplayGoal blk -> Bool
== :: ReplayGoal blk -> ReplayGoal blk -> Bool
$c== :: forall blk.
StandardHash blk =>
ReplayGoal blk -> ReplayGoal blk -> Bool
Eq, Int -> ReplayGoal blk -> ShowS
[ReplayGoal blk] -> ShowS
ReplayGoal blk -> String
(Int -> ReplayGoal blk -> ShowS)
-> (ReplayGoal blk -> String)
-> ([ReplayGoal blk] -> ShowS)
-> Show (ReplayGoal blk)
forall blk. StandardHash blk => Int -> ReplayGoal blk -> ShowS
forall blk. StandardHash blk => [ReplayGoal blk] -> ShowS
forall blk. StandardHash blk => ReplayGoal blk -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ReplayGoal blk] -> ShowS
$cshowList :: forall blk. StandardHash blk => [ReplayGoal blk] -> ShowS
show :: ReplayGoal blk -> String
$cshow :: forall blk. StandardHash blk => ReplayGoal blk -> String
showsPrec :: Int -> ReplayGoal blk -> ShowS
$cshowsPrec :: forall blk. StandardHash blk => Int -> ReplayGoal blk -> ShowS
Show)

-- | Events traced while replaying blocks against the ledger to bring it up to
-- date w.r.t. the tip of the ImmutableDB during initialisation. As this
-- process takes a while, we trace events to inform higher layers of our
-- progress.
data TraceReplayEvent blk
  = -- | There were no LedgerDB snapshots on disk, so we're replaying all blocks
    -- starting from Genesis against the initial ledger.
    ReplayFromGenesis
        (ReplayGoal blk)  -- ^ the block at the tip of the ImmutableDB
    -- | There was a LedgerDB snapshot on disk corresponding to the given tip.
    -- We're replaying more recent blocks against it.
  | ReplayFromSnapshot
        DiskSnapshot
        (RealPoint blk)
        (ReplayStart blk) -- ^ the block at which this replay started
        (ReplayGoal blk)  -- ^ the block at the tip of the ImmutableDB
  -- | We replayed the given block (reference) on the genesis snapshot during
  -- the initialisation of the LedgerDB. Used during ImmutableDB replay.
  | ReplayedBlock
        (RealPoint blk)   -- ^ the block being replayed
        [LedgerEvent blk]
        (ReplayStart blk) -- ^ the block at which this replay started
        (ReplayGoal blk)  -- ^ the block at the tip of the ImmutableDB
  deriving ((forall x. TraceReplayEvent blk -> Rep (TraceReplayEvent blk) x)
-> (forall x. Rep (TraceReplayEvent blk) x -> TraceReplayEvent blk)
-> Generic (TraceReplayEvent blk)
forall x. Rep (TraceReplayEvent blk) x -> TraceReplayEvent blk
forall x. TraceReplayEvent blk -> Rep (TraceReplayEvent blk) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall blk x. Rep (TraceReplayEvent blk) x -> TraceReplayEvent blk
forall blk x. TraceReplayEvent blk -> Rep (TraceReplayEvent blk) x
$cto :: forall blk x. Rep (TraceReplayEvent blk) x -> TraceReplayEvent blk
$cfrom :: forall blk x. TraceReplayEvent blk -> Rep (TraceReplayEvent blk) x
Generic, TraceReplayEvent blk -> TraceReplayEvent blk -> Bool
(TraceReplayEvent blk -> TraceReplayEvent blk -> Bool)
-> (TraceReplayEvent blk -> TraceReplayEvent blk -> Bool)
-> Eq (TraceReplayEvent blk)
forall blk.
(StandardHash blk, InspectLedger blk) =>
TraceReplayEvent blk -> TraceReplayEvent blk -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TraceReplayEvent blk -> TraceReplayEvent blk -> Bool
$c/= :: forall blk.
(StandardHash blk, InspectLedger blk) =>
TraceReplayEvent blk -> TraceReplayEvent blk -> Bool
== :: TraceReplayEvent blk -> TraceReplayEvent blk -> Bool
$c== :: forall blk.
(StandardHash blk, InspectLedger blk) =>
TraceReplayEvent blk -> TraceReplayEvent blk -> Bool
Eq, Int -> TraceReplayEvent blk -> ShowS
[TraceReplayEvent blk] -> ShowS
TraceReplayEvent blk -> String
(Int -> TraceReplayEvent blk -> ShowS)
-> (TraceReplayEvent blk -> String)
-> ([TraceReplayEvent blk] -> ShowS)
-> Show (TraceReplayEvent blk)
forall blk.
(StandardHash blk, InspectLedger blk) =>
Int -> TraceReplayEvent blk -> ShowS
forall blk.
(StandardHash blk, InspectLedger blk) =>
[TraceReplayEvent blk] -> ShowS
forall blk.
(StandardHash blk, InspectLedger blk) =>
TraceReplayEvent blk -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TraceReplayEvent blk] -> ShowS
$cshowList :: forall blk.
(StandardHash blk, InspectLedger blk) =>
[TraceReplayEvent blk] -> ShowS
show :: TraceReplayEvent blk -> String
$cshow :: forall blk.
(StandardHash blk, InspectLedger blk) =>
TraceReplayEvent blk -> String
showsPrec :: Int -> TraceReplayEvent blk -> ShowS
$cshowsPrec :: forall blk.
(StandardHash blk, InspectLedger blk) =>
Int -> TraceReplayEvent blk -> ShowS
Show)