{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

-- | Snapshots
--
-- Snapshotting a ledger state means saving a copy of the state to disk, so that
-- a later start of a cardano-node can use such a snapshot as a starting point
-- instead of having to replay from Genesis.
--
-- A snapshot is identified by the slot number of the ledger state it contains
-- and possibly has a suffix in the name. The consensus logic will not delete a
-- snapshot if it has a suffix. This can be used to store important
-- snapshots. The suffix can be manually added to the snapshot by renaming the
-- folder (see the caveats in 'snapshotManager' for the LSM backend). It will
-- also be added automatically by some tools such as db-analyser.
--
-- In general snapshots will be stored in the @./ledger@ directory inside the
-- ChainDB directory, but each LedgerDB backend is free to store it somewhere
-- else. Management of snapshots is done through the 'SnapshotManager'
-- record (see the 'snapshotManager' functions on each backend).
--
-- Snapshots cosists of two parts:
--
--  - the ledger state tables: location and format differs among backends,
--
--  - the rest of the ledger state: a CBOR serialization of an @ExtLedgerState
--    blk EmptyMK@, stored in the @./state@ file in the snapshot directory.
--
-- V2 backends will provide means of loading a snapshot via the method
-- 'openStateRefFromSnapshot'.
module Ouroboros.Consensus.Storage.LedgerDB.Snapshots
  ( -- * Snapshots
    CRCError (..)
  , DiskSnapshot (..)
  , MetadataErr (..)
  , ReadSnapshotErr (..)
  , SnapshotBackend (..)
  , SnapshotFailure (..)
  , SnapshotMetadata (..)
  , SnapshotPolicyArgs (..)
  , TablesCodecVersion (..)
  , NumOfDiskSnapshots (..)
  , defaultSnapshotPolicyArgs
  , mithrilSnapshotPolicyArgs

    -- * Codec
  , readExtLedgerState
  , writeExtLedgerState

    -- * Paths
  , diskSnapshotIsTemporary
  , snapshotFromPath
  , snapshotToChecksumPath
  , snapshotToStatePath
  , snapshotToDirName
  , snapshotToDirPath
  , snapshotToMetadataPath

    -- * Management
  , SnapshotManager (..)
  , defaultDeleteSnapshotIfTemporary
  , defaultListSnapshots
  , trimSnapshots
  , loadSnapshotMetadata
  , writeSnapshotMetadata

    -- * Policy
  , SnapshotPolicy (..)
  , SnapshotDelayRange (..)
  , SnapshotSelectorContext (..)
  , SnapshotFrequency (..)
  , SnapshotFrequencyArgs (..)
  , defaultSnapshotPolicy
  , mithrilEpochSize
  , sanityCheckSnapshotPolicyArgs
  , pattern DoDiskSnapshotChecksum
  , pattern NoDoDiskSnapshotChecksum

    -- * Tracing
  , TraceSnapshotEvent (..)

    -- * Re-exports
  , Flag (..)

    -- * Testing
  , decodeLBackwardsCompatible
  , destroySnapshots
  , encodeL
  , snapshotsMapM_
  ) where

import Cardano.Ledger.BaseTypes
import Codec.CBOR.Decoding
import Codec.CBOR.Encoding
import qualified Codec.CBOR.Write as CBOR
import qualified Codec.Serialise.Decoding as Dec
import Control.Monad
import qualified Control.Monad as Monad
import Control.Monad.Class.MonadTime.SI
import Control.Monad.Except
import Control.Tracer
import Data.Aeson (FromJSON (..), ToJSON (..), (.:), (.=))
import qualified Data.Aeson as Aeson
import Data.Aeson.Types (Parser)
import Data.Functor.Identity
import qualified Data.List as List
import Data.List.NonEmpty (NonEmpty)
import Data.Maybe (catMaybes, isJust, mapMaybe, maybeToList)
import Data.Ord
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Time.Clock (secondsToDiffTime)
import Data.Word
import GHC.Generics
import NoThunks.Class
import Ouroboros.Consensus.Block
import Ouroboros.Consensus.Ledger.Abstract (EmptyMK)
import Ouroboros.Consensus.Ledger.Extended
import Ouroboros.Consensus.Util (Flag (..), lastMaybe)
import Ouroboros.Consensus.Util.CBOR
  ( ReadIncrementalErr
  , decodeWithOrigin
  , readIncremental
  )
import Ouroboros.Consensus.Util.CRC
import Ouroboros.Consensus.Util.CallStack
import Ouroboros.Consensus.Util.Enclose
import Ouroboros.Consensus.Util.IOLike
import Ouroboros.Consensus.Util.Versioned
import System.FS.API
import System.FS.API.Lazy
import System.FS.CRC
import Text.Read (readMaybe)

-- | Name of a disk snapshot.
--
--   The snapshot itself might not yet exist on disk.
data DiskSnapshot = DiskSnapshot
  { DiskSnapshot -> Word64
dsNumber :: Word64
  -- ^ 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 -> Maybe [Char]
dsSuffix :: Maybe String
  -- ^ 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 deleted/.
  }
  deriving (Int -> DiskSnapshot -> ShowS
[DiskSnapshot] -> ShowS
DiskSnapshot -> [Char]
(Int -> DiskSnapshot -> ShowS)
-> (DiskSnapshot -> [Char])
-> ([DiskSnapshot] -> ShowS)
-> Show DiskSnapshot
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DiskSnapshot -> ShowS
showsPrec :: Int -> DiskSnapshot -> ShowS
$cshow :: DiskSnapshot -> [Char]
show :: DiskSnapshot -> [Char]
$cshowList :: [DiskSnapshot] -> ShowS
showList :: [DiskSnapshot] -> ShowS
Show, DiskSnapshot -> DiskSnapshot -> Bool
(DiskSnapshot -> DiskSnapshot -> Bool)
-> (DiskSnapshot -> DiskSnapshot -> Bool) -> Eq DiskSnapshot
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DiskSnapshot -> DiskSnapshot -> Bool
== :: DiskSnapshot -> DiskSnapshot -> Bool
$c/= :: DiskSnapshot -> DiskSnapshot -> Bool
/= :: DiskSnapshot -> DiskSnapshot -> Bool
Eq, (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
$cfrom :: forall x. DiskSnapshot -> Rep DiskSnapshot x
from :: forall x. DiskSnapshot -> Rep DiskSnapshot x
$cto :: forall x. Rep DiskSnapshot x -> DiskSnapshot
to :: forall x. Rep DiskSnapshot x -> DiskSnapshot
Generic)

data SnapshotFailure blk
  = -- | We failed to deserialise the snapshot
    --
    -- This can happen due to data corruption in the ledger DB or if the codecs
    -- changed.
    InitFailureRead ReadSnapshotErr
  | -- | This snapshot is too recent (ahead of the tip of the immutable chain)
    InitFailureTooRecent DiskSnapshot (Point 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 -> SnapshotFailure blk -> ShowS
[SnapshotFailure blk] -> ShowS
SnapshotFailure blk -> [Char]
(Int -> SnapshotFailure blk -> ShowS)
-> (SnapshotFailure blk -> [Char])
-> ([SnapshotFailure blk] -> ShowS)
-> Show (SnapshotFailure blk)
forall blk. StandardHash blk => Int -> SnapshotFailure blk -> ShowS
forall blk. StandardHash blk => [SnapshotFailure blk] -> ShowS
forall blk. StandardHash blk => SnapshotFailure blk -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall blk. StandardHash blk => Int -> SnapshotFailure blk -> ShowS
showsPrec :: Int -> SnapshotFailure blk -> ShowS
$cshow :: forall blk. StandardHash blk => SnapshotFailure blk -> [Char]
show :: SnapshotFailure blk -> [Char]
$cshowList :: forall blk. StandardHash blk => [SnapshotFailure blk] -> ShowS
showList :: [SnapshotFailure blk] -> ShowS
Show, SnapshotFailure blk -> SnapshotFailure blk -> Bool
(SnapshotFailure blk -> SnapshotFailure blk -> Bool)
-> (SnapshotFailure blk -> SnapshotFailure blk -> Bool)
-> Eq (SnapshotFailure blk)
forall blk.
StandardHash blk =>
SnapshotFailure blk -> SnapshotFailure blk -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall blk.
StandardHash blk =>
SnapshotFailure blk -> SnapshotFailure blk -> Bool
== :: SnapshotFailure blk -> SnapshotFailure blk -> Bool
$c/= :: forall blk.
StandardHash blk =>
SnapshotFailure blk -> SnapshotFailure blk -> Bool
/= :: SnapshotFailure blk -> SnapshotFailure blk -> Bool
Eq, (forall x. SnapshotFailure blk -> Rep (SnapshotFailure blk) x)
-> (forall x. Rep (SnapshotFailure blk) x -> SnapshotFailure blk)
-> Generic (SnapshotFailure blk)
forall x. Rep (SnapshotFailure blk) x -> SnapshotFailure blk
forall x. SnapshotFailure blk -> Rep (SnapshotFailure blk) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall blk x. Rep (SnapshotFailure blk) x -> SnapshotFailure blk
forall blk x. SnapshotFailure blk -> Rep (SnapshotFailure blk) x
$cfrom :: forall blk x. SnapshotFailure blk -> Rep (SnapshotFailure blk) x
from :: forall x. SnapshotFailure blk -> Rep (SnapshotFailure blk) x
$cto :: forall blk x. Rep (SnapshotFailure blk) x -> SnapshotFailure blk
to :: forall x. Rep (SnapshotFailure blk) x -> SnapshotFailure blk
Generic)

data ReadSnapshotErr
  = -- | Error while de-serialising data
    ReadSnapshotFailed ReadIncrementalErr
  | -- | Checksum of read snapshot differs from the one tracked by
    --   its corresponding metadata file
    ReadSnapshotDataCorruption
  | -- | An error occurred while reading the snapshot metadata file
    ReadMetadataError FsPath MetadataErr
  | -- | We were given a legacy snapshot
    ReadSnapshotIsLegacy
  deriving (ReadSnapshotErr -> ReadSnapshotErr -> Bool
(ReadSnapshotErr -> ReadSnapshotErr -> Bool)
-> (ReadSnapshotErr -> ReadSnapshotErr -> Bool)
-> Eq ReadSnapshotErr
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ReadSnapshotErr -> ReadSnapshotErr -> Bool
== :: ReadSnapshotErr -> ReadSnapshotErr -> Bool
$c/= :: ReadSnapshotErr -> ReadSnapshotErr -> Bool
/= :: ReadSnapshotErr -> ReadSnapshotErr -> Bool
Eq, Int -> ReadSnapshotErr -> ShowS
[ReadSnapshotErr] -> ShowS
ReadSnapshotErr -> [Char]
(Int -> ReadSnapshotErr -> ShowS)
-> (ReadSnapshotErr -> [Char])
-> ([ReadSnapshotErr] -> ShowS)
-> Show ReadSnapshotErr
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ReadSnapshotErr -> ShowS
showsPrec :: Int -> ReadSnapshotErr -> ShowS
$cshow :: ReadSnapshotErr -> [Char]
show :: ReadSnapshotErr -> [Char]
$cshowList :: [ReadSnapshotErr] -> ShowS
showList :: [ReadSnapshotErr] -> ShowS
Show)

data TablesCodecVersion
  = -- | Used in cardano-node 10.7. Previous versions have no codec version.
    -- [ {_ (txid, big-endian txix) => txout} ]
    TablesCodecVersion1
  deriving (TablesCodecVersion -> TablesCodecVersion -> Bool
(TablesCodecVersion -> TablesCodecVersion -> Bool)
-> (TablesCodecVersion -> TablesCodecVersion -> Bool)
-> Eq TablesCodecVersion
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TablesCodecVersion -> TablesCodecVersion -> Bool
== :: TablesCodecVersion -> TablesCodecVersion -> Bool
$c/= :: TablesCodecVersion -> TablesCodecVersion -> Bool
/= :: TablesCodecVersion -> TablesCodecVersion -> Bool
Eq, Int -> TablesCodecVersion -> ShowS
[TablesCodecVersion] -> ShowS
TablesCodecVersion -> [Char]
(Int -> TablesCodecVersion -> ShowS)
-> (TablesCodecVersion -> [Char])
-> ([TablesCodecVersion] -> ShowS)
-> Show TablesCodecVersion
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TablesCodecVersion -> ShowS
showsPrec :: Int -> TablesCodecVersion -> ShowS
$cshow :: TablesCodecVersion -> [Char]
show :: TablesCodecVersion -> [Char]
$cshowList :: [TablesCodecVersion] -> ShowS
showList :: [TablesCodecVersion] -> ShowS
Show)

instance ToJSON TablesCodecVersion where
  toJSON :: TablesCodecVersion -> Value
toJSON TablesCodecVersion
TablesCodecVersion1 = Scientific -> Value
Aeson.Number Scientific
1

instance FromJSON TablesCodecVersion where
  parseJSON :: Value -> Parser TablesCodecVersion
parseJSON Value
v = Word8 -> Parser TablesCodecVersion
enforceVersion (Word8 -> Parser TablesCodecVersion)
-> Parser Word8 -> Parser TablesCodecVersion
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Value -> Parser Word8
forall a. FromJSON a => Value -> Parser a
parseJSON Value
v

enforceVersion :: Word8 -> Parser TablesCodecVersion
enforceVersion :: Word8 -> Parser TablesCodecVersion
enforceVersion Word8
v = case Word8
v of
  Word8
1 -> TablesCodecVersion -> Parser TablesCodecVersion
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TablesCodecVersion
TablesCodecVersion1
  Word8
_ -> [Char] -> Parser TablesCodecVersion
forall a. HasCallStack => [Char] -> Parser a
forall (m :: * -> *) a.
(MonadFail m, HasCallStack) =>
[Char] -> m a
fail [Char]
"Unknown or outdated tables codec version"

data SnapshotMetadata = SnapshotMetadata
  { SnapshotMetadata -> SnapshotBackend
snapshotBackend :: SnapshotBackend
  , SnapshotMetadata -> CRC
snapshotChecksum :: CRC
  , SnapshotMetadata -> TablesCodecVersion
snapshotTablesCodecVersion :: TablesCodecVersion
  }
  deriving (SnapshotMetadata -> SnapshotMetadata -> Bool
(SnapshotMetadata -> SnapshotMetadata -> Bool)
-> (SnapshotMetadata -> SnapshotMetadata -> Bool)
-> Eq SnapshotMetadata
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SnapshotMetadata -> SnapshotMetadata -> Bool
== :: SnapshotMetadata -> SnapshotMetadata -> Bool
$c/= :: SnapshotMetadata -> SnapshotMetadata -> Bool
/= :: SnapshotMetadata -> SnapshotMetadata -> Bool
Eq, Int -> SnapshotMetadata -> ShowS
[SnapshotMetadata] -> ShowS
SnapshotMetadata -> [Char]
(Int -> SnapshotMetadata -> ShowS)
-> (SnapshotMetadata -> [Char])
-> ([SnapshotMetadata] -> ShowS)
-> Show SnapshotMetadata
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SnapshotMetadata -> ShowS
showsPrec :: Int -> SnapshotMetadata -> ShowS
$cshow :: SnapshotMetadata -> [Char]
show :: SnapshotMetadata -> [Char]
$cshowList :: [SnapshotMetadata] -> ShowS
showList :: [SnapshotMetadata] -> ShowS
Show)

instance ToJSON SnapshotMetadata where
  toJSON :: SnapshotMetadata -> Value
toJSON SnapshotMetadata
sm =
    [(Key, Value)] -> Value
Aeson.object
      [ Key
"backend" Key -> SnapshotBackend -> (Key, Value)
forall v. ToJSON v => Key -> v -> (Key, Value)
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= SnapshotMetadata -> SnapshotBackend
snapshotBackend SnapshotMetadata
sm
      , Key
"checksum" Key -> Word32 -> (Key, Value)
forall v. ToJSON v => Key -> v -> (Key, Value)
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= CRC -> Word32
getCRC (SnapshotMetadata -> CRC
snapshotChecksum SnapshotMetadata
sm)
      , Key
"tablesCodecVersion" Key -> TablesCodecVersion -> (Key, Value)
forall v. ToJSON v => Key -> v -> (Key, Value)
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= SnapshotMetadata -> TablesCodecVersion
snapshotTablesCodecVersion SnapshotMetadata
sm
      ]

instance FromJSON SnapshotMetadata where
  parseJSON :: Value -> Parser SnapshotMetadata
parseJSON = [Char]
-> (Object -> Parser SnapshotMetadata)
-> Value
-> Parser SnapshotMetadata
forall a. [Char] -> (Object -> Parser a) -> Value -> Parser a
Aeson.withObject [Char]
"SnapshotMetadata" ((Object -> Parser SnapshotMetadata)
 -> Value -> Parser SnapshotMetadata)
-> (Object -> Parser SnapshotMetadata)
-> Value
-> Parser SnapshotMetadata
forall a b. (a -> b) -> a -> b
$ \Object
o ->
    SnapshotBackend -> CRC -> TablesCodecVersion -> SnapshotMetadata
SnapshotMetadata
      (SnapshotBackend -> CRC -> TablesCodecVersion -> SnapshotMetadata)
-> Parser SnapshotBackend
-> Parser (CRC -> TablesCodecVersion -> SnapshotMetadata)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser SnapshotBackend
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"backend"
      Parser (CRC -> TablesCodecVersion -> SnapshotMetadata)
-> Parser CRC -> Parser (TablesCodecVersion -> SnapshotMetadata)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Word32 -> CRC) -> Parser Word32 -> Parser CRC
forall a b. (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Word32 -> CRC
CRC (Object
o Object -> Key -> Parser Word32
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"checksum")
      Parser (TablesCodecVersion -> SnapshotMetadata)
-> Parser TablesCodecVersion -> Parser SnapshotMetadata
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser TablesCodecVersion
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"tablesCodecVersion"

data SnapshotBackend
  = UTxOHDMemSnapshot
  | UTxOHDLMDBSnapshot
  | UTxOHDLSMSnapshot
  deriving (SnapshotBackend -> SnapshotBackend -> Bool
(SnapshotBackend -> SnapshotBackend -> Bool)
-> (SnapshotBackend -> SnapshotBackend -> Bool)
-> Eq SnapshotBackend
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SnapshotBackend -> SnapshotBackend -> Bool
== :: SnapshotBackend -> SnapshotBackend -> Bool
$c/= :: SnapshotBackend -> SnapshotBackend -> Bool
/= :: SnapshotBackend -> SnapshotBackend -> Bool
Eq, Int -> SnapshotBackend -> ShowS
[SnapshotBackend] -> ShowS
SnapshotBackend -> [Char]
(Int -> SnapshotBackend -> ShowS)
-> (SnapshotBackend -> [Char])
-> ([SnapshotBackend] -> ShowS)
-> Show SnapshotBackend
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SnapshotBackend -> ShowS
showsPrec :: Int -> SnapshotBackend -> ShowS
$cshow :: SnapshotBackend -> [Char]
show :: SnapshotBackend -> [Char]
$cshowList :: [SnapshotBackend] -> ShowS
showList :: [SnapshotBackend] -> ShowS
Show)

instance ToJSON SnapshotBackend where
  toJSON :: SnapshotBackend -> Value
toJSON = \case
    SnapshotBackend
UTxOHDMemSnapshot -> Value
"utxohd-mem"
    SnapshotBackend
UTxOHDLMDBSnapshot -> Value
"utxohd-lmdb"
    SnapshotBackend
UTxOHDLSMSnapshot -> Value
"utxohd-lsm"

instance FromJSON SnapshotBackend where
  parseJSON :: Value -> Parser SnapshotBackend
parseJSON = [Char]
-> (Text -> Parser SnapshotBackend)
-> Value
-> Parser SnapshotBackend
forall a. [Char] -> (Text -> Parser a) -> Value -> Parser a
Aeson.withText [Char]
"SnapshotBackend" ((Text -> Parser SnapshotBackend)
 -> Value -> Parser SnapshotBackend)
-> (Text -> Parser SnapshotBackend)
-> Value
-> Parser SnapshotBackend
forall a b. (a -> b) -> a -> b
$ \case
    Text
"utxohd-mem" -> SnapshotBackend -> Parser SnapshotBackend
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SnapshotBackend
UTxOHDMemSnapshot
    Text
"utxohd-lmdb" -> SnapshotBackend -> Parser SnapshotBackend
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SnapshotBackend
UTxOHDLMDBSnapshot
    Text
"utxohd-lsm" -> SnapshotBackend -> Parser SnapshotBackend
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SnapshotBackend
UTxOHDLSMSnapshot
    Text
_ -> [Char] -> Parser SnapshotBackend
forall a. HasCallStack => [Char] -> Parser a
forall (m :: * -> *) a.
(MonadFail m, HasCallStack) =>
[Char] -> m a
fail [Char]
"unknown SnapshotBackend"

data MetadataErr
  = -- | The metadata file does not exist
    MetadataFileDoesNotExist
  | -- | The metadata file is invalid and does not deserialize
    MetadataInvalid String
  | -- | The metadata file has the incorrect backend
    MetadataBackendMismatch
  deriving (MetadataErr -> MetadataErr -> Bool
(MetadataErr -> MetadataErr -> Bool)
-> (MetadataErr -> MetadataErr -> Bool) -> Eq MetadataErr
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: MetadataErr -> MetadataErr -> Bool
== :: MetadataErr -> MetadataErr -> Bool
$c/= :: MetadataErr -> MetadataErr -> Bool
/= :: MetadataErr -> MetadataErr -> Bool
Eq, Int -> MetadataErr -> ShowS
[MetadataErr] -> ShowS
MetadataErr -> [Char]
(Int -> MetadataErr -> ShowS)
-> (MetadataErr -> [Char])
-> ([MetadataErr] -> ShowS)
-> Show MetadataErr
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> MetadataErr -> ShowS
showsPrec :: Int -> MetadataErr -> ShowS
$cshow :: MetadataErr -> [Char]
show :: MetadataErr -> [Char]
$cshowList :: [MetadataErr] -> ShowS
showList :: [MetadataErr] -> ShowS
Show)

-- | Management of snapshots for the different LedgerDB backends.
data SnapshotManager m blk st = SnapshotManager
  { forall (m :: * -> *) blk st.
SnapshotManager m blk st -> m [DiskSnapshot]
listSnapshots :: m [DiskSnapshot]
  , forall (m :: * -> *) blk st.
SnapshotManager m blk st -> DiskSnapshot -> m ()
deleteSnapshotIfTemporary :: DiskSnapshot -> m ()
  , forall (m :: * -> *) blk st.
SnapshotManager m blk st
-> Maybe [Char] -> st -> m (Maybe (DiskSnapshot, RealPoint blk))
takeSnapshot ::
      Maybe String ->
      -- \^ The (possibly empty) suffix for the snapshot name
      st ->
      -- \^ The state needed for taking the snapshot:
      -- - In V1: this will be the DbChangelog and the Backing store
      -- - In V2: this will be a StateRef
      m (Maybe (DiskSnapshot, RealPoint blk))
      -- \^ If a Snapshot was taken, its information and the point at which it
      -- was taken.
  }

-- | Named snapshot are permanent, they will never be deleted even if failing to
-- deserialize.
diskSnapshotIsPermanent :: DiskSnapshot -> Bool
diskSnapshotIsPermanent :: DiskSnapshot -> Bool
diskSnapshotIsPermanent = Maybe [Char] -> Bool
forall a. Maybe a -> Bool
isJust (Maybe [Char] -> Bool)
-> (DiskSnapshot -> Maybe [Char]) -> DiskSnapshot -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DiskSnapshot -> Maybe [Char]
dsSuffix

-- | The snapshots that are periodically created are temporary, they will be
-- deleted when trimming or if they fail to deserialize.
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

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

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

-- | List on-disk snapshots, highest number first.
defaultListSnapshots :: Monad m => SomeHasFS m -> m [DiskSnapshot]
defaultListSnapshots :: forall (m :: * -> *). Monad m => SomeHasFS m -> m [DiskSnapshot]
defaultListSnapshots (SomeHasFS HasFS{HasCallStack => FsPath -> m (Set [Char])
listDirectory :: HasCallStack => FsPath -> m (Set [Char])
listDirectory :: forall (m :: * -> *) h.
HasFS m h -> HasCallStack => FsPath -> m (Set [Char])
listDirectory}) =
  Set [Char] -> [DiskSnapshot]
aux (Set [Char] -> [DiskSnapshot])
-> m (Set [Char]) -> m [DiskSnapshot]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HasCallStack => FsPath -> m (Set [Char])
FsPath -> m (Set [Char])
listDirectory ([[Char]] -> FsPath
mkFsPath [])
 where
  aux :: Set String -> [DiskSnapshot]
  aux :: Set [Char] -> [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 [Char] -> [DiskSnapshot]) -> Set [Char] -> [DiskSnapshot]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char] -> Maybe DiskSnapshot) -> [[Char]] -> [DiskSnapshot]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe [Char] -> Maybe DiskSnapshot
snapshotFromPath ([[Char]] -> [DiskSnapshot])
-> (Set [Char] -> [[Char]]) -> Set [Char] -> [DiskSnapshot]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set [Char] -> [[Char]]
forall a. Set a -> [a]
Set.toList

-- | Delete snapshot from disk
defaultDeleteSnapshotIfTemporary ::
  forall m blk.
  (MonadCatch m, HasCallStack) =>
  SomeHasFS m -> Tracer m (TraceSnapshotEvent blk) -> DiskSnapshot -> m ()
defaultDeleteSnapshotIfTemporary :: forall (m :: * -> *) blk.
(MonadCatch m, HasCallStack) =>
SomeHasFS m
-> Tracer m (TraceSnapshotEvent blk) -> DiskSnapshot -> m ()
defaultDeleteSnapshotIfTemporary (SomeHasFS HasFS{HasCallStack => FsPath -> m Bool
doesDirectoryExist :: HasCallStack => FsPath -> m Bool
doesDirectoryExist :: forall (m :: * -> *) h.
HasFS m h -> HasCallStack => FsPath -> m Bool
doesDirectoryExist, HasCallStack => FsPath -> m ()
removeDirectoryRecursive :: HasCallStack => FsPath -> m ()
removeDirectoryRecursive :: forall (m :: * -> *) h. HasFS m h -> HasCallStack => FsPath -> m ()
removeDirectoryRecursive}) Tracer m (TraceSnapshotEvent blk)
tracer DiskSnapshot
ss =
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (DiskSnapshot -> Bool
diskSnapshotIsTemporary DiskSnapshot
ss) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ m (Either SomeException ()) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m (Either SomeException ()) -> m ())
-> m (Either SomeException ()) -> m ()
forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
try @m @SomeException (m () -> m (Either SomeException ()))
-> m () -> m (Either SomeException ())
forall a b. (a -> b) -> a -> b
$ do
    let p :: FsPath
p = DiskSnapshot -> FsPath
snapshotToDirPath DiskSnapshot
ss
    exists <- HasCallStack => FsPath -> m Bool
FsPath -> m Bool
doesDirectoryExist FsPath
p
    when exists (removeDirectoryRecursive p)
    traceWith tracer (DeletedSnapshot ss)

-- | Write a snapshot metadata JSON file.
writeSnapshotMetadata ::
  MonadThrow m =>
  SomeHasFS m ->
  DiskSnapshot ->
  SnapshotMetadata ->
  m ()
writeSnapshotMetadata :: forall (m :: * -> *).
MonadThrow m =>
SomeHasFS m -> DiskSnapshot -> SnapshotMetadata -> m ()
writeSnapshotMetadata (SomeHasFS HasFS m h
hasFS) DiskSnapshot
ds SnapshotMetadata
meta = do
  let metadataPath :: FsPath
metadataPath = DiskSnapshot -> FsPath
snapshotToMetadataPath DiskSnapshot
ds
  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 FsPath
metadataPath (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 ()
Monad.void (m Word64 -> m ()) -> m Word64 -> m ()
forall a b. (a -> b) -> a -> b
$ HasFS m h -> Handle h -> ByteString -> m Word64
forall (m :: * -> *) h.
(HasCallStack, Monad m) =>
HasFS m h -> Handle h -> ByteString -> m Word64
hPutAll HasFS m h
hasFS Handle h
h (ByteString -> m Word64) -> ByteString -> m Word64
forall a b. (a -> b) -> a -> b
$ SnapshotMetadata -> ByteString
forall a. ToJSON a => a -> ByteString
Aeson.encode SnapshotMetadata
meta

-- | Load a snapshot metadata JSON file.
--
--   - Fails with 'MetadataFileDoesNotExist' when the file doesn't exist;
--   - Fails with 'MetadataInvalid' when the contents of the file cannot be
--     deserialised correctly
loadSnapshotMetadata ::
  IOLike m =>
  SomeHasFS m ->
  DiskSnapshot ->
  ExceptT MetadataErr m SnapshotMetadata
loadSnapshotMetadata :: forall (m :: * -> *).
IOLike m =>
SomeHasFS m
-> DiskSnapshot -> ExceptT MetadataErr m SnapshotMetadata
loadSnapshotMetadata (SomeHasFS HasFS m h
hasFS) DiskSnapshot
ds = m (Either MetadataErr SnapshotMetadata)
-> ExceptT MetadataErr m SnapshotMetadata
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (m (Either MetadataErr SnapshotMetadata)
 -> ExceptT MetadataErr m SnapshotMetadata)
-> m (Either MetadataErr SnapshotMetadata)
-> ExceptT MetadataErr m SnapshotMetadata
forall a b. (a -> b) -> a -> b
$ do
  let metadataPath :: FsPath
metadataPath = DiskSnapshot -> FsPath
snapshotToMetadataPath DiskSnapshot
ds
  exists <- HasFS m h -> HasCallStack => FsPath -> m Bool
forall (m :: * -> *) h.
HasFS m h -> HasCallStack => FsPath -> m Bool
doesFileExist HasFS m h
hasFS FsPath
metadataPath
  if not exists
    then pure $ Left MetadataFileDoesNotExist
    else do
      withFile hasFS metadataPath ReadMode $ \Handle h
h -> do
        bs <- HasFS m h -> Handle h -> m ByteString
forall (m :: * -> *) h.
Monad m =>
HasFS m h -> Handle h -> m ByteString
hGetAll HasFS m h
hasFS Handle h
h
        case Aeson.eitherDecode bs of
          Left [Char]
decodeErr -> Either MetadataErr SnapshotMetadata
-> m (Either MetadataErr SnapshotMetadata)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either MetadataErr SnapshotMetadata
 -> m (Either MetadataErr SnapshotMetadata))
-> Either MetadataErr SnapshotMetadata
-> m (Either MetadataErr SnapshotMetadata)
forall a b. (a -> b) -> a -> b
$ MetadataErr -> Either MetadataErr SnapshotMetadata
forall a b. a -> Either a b
Left (MetadataErr -> Either MetadataErr SnapshotMetadata)
-> MetadataErr -> Either MetadataErr SnapshotMetadata
forall a b. (a -> b) -> a -> b
$ [Char] -> MetadataErr
MetadataInvalid [Char]
decodeErr
          Right SnapshotMetadata
meta -> Either MetadataErr SnapshotMetadata
-> m (Either MetadataErr SnapshotMetadata)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either MetadataErr SnapshotMetadata
 -> m (Either MetadataErr SnapshotMetadata))
-> Either MetadataErr SnapshotMetadata
-> m (Either MetadataErr SnapshotMetadata)
forall a b. (a -> b) -> a -> b
$ SnapshotMetadata -> Either MetadataErr SnapshotMetadata
forall a b. b -> Either a b
Right SnapshotMetadata
meta

snapshotsMapM_ :: Monad m => SnapshotManager m blk st -> (DiskSnapshot -> m a) -> m ()
snapshotsMapM_ :: forall (m :: * -> *) blk st a.
Monad m =>
SnapshotManager m blk st -> (DiskSnapshot -> m a) -> m ()
snapshotsMapM_ SnapshotManager m blk st
snapManager DiskSnapshot -> m a
f =
  (DiskSnapshot -> m a) -> [DiskSnapshot] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ DiskSnapshot -> m a
f ([DiskSnapshot] -> m ()) -> m [DiskSnapshot] -> m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< SnapshotManager m blk st -> m [DiskSnapshot]
forall (m :: * -> *) blk st.
SnapshotManager m blk st -> m [DiskSnapshot]
listSnapshots SnapshotManager m blk st
snapManager

-- | Testing only! Destroy all snapshots in the DB.
destroySnapshots :: Monad m => SnapshotManager m blk st -> m ()
destroySnapshots :: forall (m :: * -> *) blk st.
Monad m =>
SnapshotManager m blk st -> m ()
destroySnapshots SnapshotManager m blk st
snapManager =
  SnapshotManager m blk st -> (DiskSnapshot -> m ()) -> m ()
forall (m :: * -> *) blk st a.
Monad m =>
SnapshotManager m blk st -> (DiskSnapshot -> m a) -> m ()
snapshotsMapM_
    SnapshotManager m blk st
snapManager
    (SnapshotManager m blk st -> DiskSnapshot -> m ()
forall (m :: * -> *) blk st.
SnapshotManager m blk st -> DiskSnapshot -> m ()
deleteSnapshotIfTemporary SnapshotManager m blk st
snapManager)

-- | Read an extended ledger state from disk
readExtLedgerState ::
  forall m blk.
  IOLike m =>
  SomeHasFS m ->
  (forall s. Decoder s (ExtLedgerState blk EmptyMK)) ->
  (forall s. Decoder s (HeaderHash blk)) ->
  FsPath ->
  ExceptT ReadIncrementalErr m (ExtLedgerState blk EmptyMK, CRC)
readExtLedgerState :: forall (m :: * -> *) blk.
IOLike m =>
SomeHasFS m
-> (forall s. Decoder s (ExtLedgerState blk EmptyMK))
-> (forall s. Decoder s (HeaderHash blk))
-> FsPath
-> ExceptT ReadIncrementalErr m (ExtLedgerState blk EmptyMK, CRC)
readExtLedgerState SomeHasFS m
hasFS forall s. Decoder s (ExtLedgerState blk EmptyMK)
decLedger forall s. Decoder s (HeaderHash blk)
decHash =
  do
    ExceptT
    (m (Either ReadIncrementalErr (ExtLedgerState blk EmptyMK, CRC))
 -> ExceptT ReadIncrementalErr m (ExtLedgerState blk EmptyMK, CRC))
-> (FsPath
    -> m (Either ReadIncrementalErr (ExtLedgerState blk EmptyMK, CRC)))
-> FsPath
-> ExceptT ReadIncrementalErr m (ExtLedgerState blk EmptyMK, CRC)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Either
   ReadIncrementalErr (ExtLedgerState blk EmptyMK, Identity CRC)
 -> Either ReadIncrementalErr (ExtLedgerState blk EmptyMK, CRC))
-> m (Either
        ReadIncrementalErr (ExtLedgerState blk EmptyMK, Identity CRC))
-> m (Either ReadIncrementalErr (ExtLedgerState blk EmptyMK, CRC))
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((ExtLedgerState blk EmptyMK, Identity CRC)
 -> (ExtLedgerState blk EmptyMK, CRC))
-> Either
     ReadIncrementalErr (ExtLedgerState blk EmptyMK, Identity CRC)
-> Either ReadIncrementalErr (ExtLedgerState blk EmptyMK, CRC)
forall a b.
(a -> b)
-> Either ReadIncrementalErr a -> Either ReadIncrementalErr b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Identity CRC -> CRC)
-> (ExtLedgerState blk EmptyMK, Identity CRC)
-> (ExtLedgerState blk EmptyMK, CRC)
forall a b.
(a -> b)
-> (ExtLedgerState blk EmptyMK, a)
-> (ExtLedgerState blk EmptyMK, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Identity CRC -> CRC
forall a. Identity a -> a
runIdentity))
    (m (Either
      ReadIncrementalErr (ExtLedgerState blk EmptyMK, Identity CRC))
 -> m (Either ReadIncrementalErr (ExtLedgerState blk EmptyMK, CRC)))
-> (FsPath
    -> m (Either
            ReadIncrementalErr (ExtLedgerState blk EmptyMK, Identity CRC)))
-> FsPath
-> m (Either ReadIncrementalErr (ExtLedgerState blk EmptyMK, CRC))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeHasFS m
-> (CRC -> Identity CRC)
-> Decoder (PrimState m) (ExtLedgerState blk EmptyMK)
-> FsPath
-> m (Either
        ReadIncrementalErr (ExtLedgerState blk EmptyMK, Identity CRC))
forall (m :: * -> *) (f :: * -> *) a.
(IOLike m, Functor f) =>
SomeHasFS m
-> (CRC -> f CRC)
-> Decoder (PrimState m) a
-> FsPath
-> m (Either ReadIncrementalErr (a, f CRC))
readIncremental SomeHasFS m
hasFS CRC -> Identity CRC
forall a. a -> Identity a
Identity Decoder (PrimState m) (ExtLedgerState blk EmptyMK)
forall s. Decoder s (ExtLedgerState blk EmptyMK)
decoder
 where
  decoder :: Decoder s (ExtLedgerState blk EmptyMK)
  decoder :: forall s. Decoder s (ExtLedgerState blk EmptyMK)
decoder = Proxy blk
-> (forall s. Decoder s (ExtLedgerState blk EmptyMK))
-> (forall s. Decoder s (HeaderHash blk))
-> forall s. Decoder s (ExtLedgerState blk EmptyMK)
forall l blk.
Proxy blk
-> (forall s. Decoder s l)
-> (forall s. Decoder s (HeaderHash blk))
-> forall s. Decoder s l
decodeLBackwardsCompatible (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @blk) Decoder s (ExtLedgerState blk EmptyMK)
forall s. Decoder s (ExtLedgerState blk EmptyMK)
decLedger Decoder s (HeaderHash blk)
forall s. Decoder s (HeaderHash blk)
decHash

-- | Write an extended ledger state to disk
writeExtLedgerState ::
  forall m blk.
  MonadThrow m =>
  SomeHasFS m ->
  (ExtLedgerState blk EmptyMK -> Encoding) ->
  FsPath ->
  ExtLedgerState blk EmptyMK ->
  m CRC
writeExtLedgerState :: forall (m :: * -> *) blk.
MonadThrow m =>
SomeHasFS m
-> (ExtLedgerState blk EmptyMK -> Encoding)
-> FsPath
-> ExtLedgerState blk EmptyMK
-> m CRC
writeExtLedgerState (SomeHasFS HasFS m h
hasFS) ExtLedgerState blk EmptyMK -> Encoding
encLedger FsPath
path ExtLedgerState blk EmptyMK
cs = do
  HasFS m h -> FsPath -> OpenMode -> (Handle h -> m CRC) -> m CRC
forall (m :: * -> *) h a.
(HasCallStack, MonadThrow m) =>
HasFS m h -> FsPath -> OpenMode -> (Handle h -> m a) -> m a
withFile HasFS m h
hasFS FsPath
path (AllowExisting -> OpenMode
WriteMode AllowExisting
MustBeNew) ((Handle h -> m CRC) -> m CRC) -> (Handle h -> m CRC) -> m CRC
forall a b. (a -> b) -> a -> b
$ \Handle h
h ->
    (Word64, CRC) -> CRC
forall a b. (a, b) -> b
snd ((Word64, CRC) -> CRC) -> m (Word64, CRC) -> m CRC
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HasFS m h -> Handle h -> ByteString -> m (Word64, CRC)
forall (m :: * -> *) h.
(HasCallStack, Monad m) =>
HasFS m h -> Handle h -> ByteString -> m (Word64, CRC)
hPutAllCRC HasFS m h
hasFS Handle h
h (Encoding -> ByteString
CBOR.toLazyByteString (Encoding -> ByteString) -> Encoding -> ByteString
forall a b. (a -> b) -> a -> b
$ ExtLedgerState blk EmptyMK -> Encoding
encoder ExtLedgerState blk EmptyMK
cs)
 where
  encoder :: ExtLedgerState blk EmptyMK -> Encoding
  encoder :: ExtLedgerState blk EmptyMK -> Encoding
encoder = (ExtLedgerState blk EmptyMK -> Encoding)
-> ExtLedgerState blk EmptyMK -> Encoding
forall l. (l -> Encoding) -> l -> Encoding
encodeL ExtLedgerState blk EmptyMK -> Encoding
encLedger

-- | 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 =>
  SnapshotManager m blk st ->
  SnapshotPolicy ->
  m [DiskSnapshot]
trimSnapshots :: forall (m :: * -> *) blk st.
Monad m =>
SnapshotManager m blk st -> SnapshotPolicy -> m [DiskSnapshot]
trimSnapshots SnapshotManager m blk st
snapManager SnapshotPolicy{NumOfDiskSnapshots
onDiskNumSnapshots :: SnapshotPolicy -> NumOfDiskSnapshots
onDiskNumSnapshots :: NumOfDiskSnapshots
onDiskNumSnapshots} = do
  -- We only trim temporary snapshots
  ss <- (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
<$> SnapshotManager m blk st -> m [DiskSnapshot]
forall (m :: * -> *) blk st.
SnapshotManager m blk st -> m [DiskSnapshot]
listSnapshots SnapshotManager m blk st
snapManager
  -- The snapshot are most recent first, so we can simply drop from the
  -- front to get the snapshots that are "too" old.
  let ssTooOld = Int -> [DiskSnapshot] -> [DiskSnapshot]
forall a. Int -> [a] -> [a]
drop (Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word -> Int)
-> (NumOfDiskSnapshots -> Word) -> NumOfDiskSnapshots -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NumOfDiskSnapshots -> Word
getNumOfDiskSnapshots (NumOfDiskSnapshots -> Int) -> NumOfDiskSnapshots -> Int
forall a b. (a -> b) -> a -> b
$ NumOfDiskSnapshots
onDiskNumSnapshots) [DiskSnapshot]
ss
  mapM
    ( \DiskSnapshot
s -> do
        SnapshotManager m blk st -> DiskSnapshot -> m ()
forall (m :: * -> *) blk st.
SnapshotManager m blk st -> DiskSnapshot -> m ()
deleteSnapshotIfTemporary SnapshotManager m blk st
snapManager DiskSnapshot
s
        DiskSnapshot -> m DiskSnapshot
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure DiskSnapshot
s
    )
    ssTooOld

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

snapshotToChecksumPath :: DiskSnapshot -> FsPath
snapshotToChecksumPath :: DiskSnapshot -> FsPath
snapshotToChecksumPath = [[Char]] -> FsPath
mkFsPath ([[Char]] -> FsPath)
-> (DiskSnapshot -> [[Char]]) -> DiskSnapshot -> FsPath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\[Char]
x -> [[Char]
x, [Char]
"checksum"]) ([Char] -> [[Char]])
-> (DiskSnapshot -> [Char]) -> DiskSnapshot -> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DiskSnapshot -> [Char]
snapshotToDirName

snapshotToMetadataPath :: DiskSnapshot -> FsPath
snapshotToMetadataPath :: DiskSnapshot -> FsPath
snapshotToMetadataPath = [[Char]] -> FsPath
mkFsPath ([[Char]] -> FsPath)
-> (DiskSnapshot -> [[Char]]) -> DiskSnapshot -> FsPath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\[Char]
x -> [[Char]
x, [Char]
"meta"]) ([Char] -> [[Char]])
-> (DiskSnapshot -> [Char]) -> DiskSnapshot -> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DiskSnapshot -> [Char]
snapshotToDirName

-- | The path within the LedgerDB's filesystem to the snapshot's directory
snapshotToDirPath :: DiskSnapshot -> FsPath
snapshotToDirPath :: DiskSnapshot -> FsPath
snapshotToDirPath = [[Char]] -> FsPath
mkFsPath ([[Char]] -> FsPath)
-> (DiskSnapshot -> [[Char]]) -> DiskSnapshot -> FsPath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: []) ([Char] -> [[Char]])
-> (DiskSnapshot -> [Char]) -> DiskSnapshot -> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DiskSnapshot -> [Char]
snapshotToDirName

-- | The path within the LedgerDB's filesystem to the file that contains the
-- snapshot's serialized ledger state
snapshotToStatePath :: DiskSnapshot -> FsPath
snapshotToStatePath :: DiskSnapshot -> FsPath
snapshotToStatePath = [[Char]] -> FsPath
mkFsPath ([[Char]] -> FsPath)
-> (DiskSnapshot -> [[Char]]) -> DiskSnapshot -> FsPath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\[Char]
x -> [[Char]
x, [Char]
"state"]) ([Char] -> [[Char]])
-> (DiskSnapshot -> [Char]) -> DiskSnapshot -> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DiskSnapshot -> [Char]
snapshotToDirName

-- | Version 1: uses versioning ('Ouroboros.Consensus.Util.Versioned') and only
-- encodes the ledger state @l@.
snapshotEncodingVersion1 :: VersionNumber
snapshotEncodingVersion1 :: VersionNumber
snapshotEncodingVersion1 = VersionNumber
1

-- | Encoder to be used in combination with 'decodeSnapshotBackwardsCompatible'.
encodeL :: (l -> Encoding) -> l -> Encoding
encodeL :: forall l. (l -> Encoding) -> l -> Encoding
encodeL l -> Encoding
encodeLedger l
l =
  VersionNumber -> Encoding -> Encoding
encodeVersion VersionNumber
snapshotEncodingVersion1 (l -> Encoding
encodeLedger l
l)

-- | To remain backwards compatible with existing snapshots stored on disk, we
-- must accept the old format as well as the new format.
--
-- The old format:
--
-- * The tip: @WithOrigin (RealPoint blk)@
--
-- * The chain length: @Word64@
--
-- * The ledger state: @l@
--
-- The new format is described by 'snapshotEncodingVersion1'.
--
-- This decoder will accept and ignore them. The encoder ('encodeSnapshot') will
-- no longer encode them.
decodeLBackwardsCompatible ::
  forall l blk.
  Proxy blk ->
  (forall s. Decoder s l) ->
  (forall s. Decoder s (HeaderHash blk)) ->
  forall s.
  Decoder s l
decodeLBackwardsCompatible :: forall l blk.
Proxy blk
-> (forall s. Decoder s l)
-> (forall s. Decoder s (HeaderHash blk))
-> forall s. Decoder s l
decodeLBackwardsCompatible Proxy blk
_ forall s. Decoder s l
decodeLedger forall s. Decoder s (HeaderHash blk)
decodeHash =
  (forall s. Maybe Int -> Decoder s l)
-> [(VersionNumber, VersionDecoder l)] -> forall s. Decoder s l
forall a.
(forall s. Maybe Int -> Decoder s a)
-> [(VersionNumber, VersionDecoder a)] -> forall s. Decoder s a
decodeVersionWithHook
    Maybe Int -> Decoder s l
Maybe Int -> forall s. Decoder s l
forall s. Maybe Int -> Decoder s l
decodeOldFormat
    [(VersionNumber
snapshotEncodingVersion1, (forall s. Decoder s l) -> VersionDecoder l
forall a. (forall s. Decoder s a) -> VersionDecoder a
Decode Decoder s l
forall s. Decoder s l
decodeVersion1)]
 where
  decodeVersion1 :: forall s. Decoder s l
  decodeVersion1 :: forall s. Decoder s l
decodeVersion1 = Decoder s l
forall s. Decoder s l
decodeLedger

  decodeOldFormat :: Maybe Int -> forall s. Decoder s l
  decodeOldFormat :: Maybe Int -> forall s. Decoder s l
decodeOldFormat (Just Int
3) = do
    _ <-
      WithOrigin (RealPoint blk) -> Point blk
forall blk. WithOrigin (RealPoint blk) -> Point blk
withOriginRealPointToPoint
        (WithOrigin (RealPoint blk) -> Point blk)
-> Decoder s (WithOrigin (RealPoint blk)) -> Decoder s (Point blk)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s (RealPoint blk) -> Decoder s (WithOrigin (RealPoint blk))
forall s a. Decoder s a -> Decoder s (WithOrigin a)
decodeWithOrigin (forall blk.
(forall s. Decoder s (HeaderHash blk))
-> forall s. Decoder s (RealPoint blk)
decodeRealPoint @blk Decoder s (HeaderHash blk)
forall s. Decoder s (HeaderHash blk)
decodeHash)
    _ <- Dec.decodeWord64
    decodeLedger
  decodeOldFormat Maybe Int
mbListLen =
    [Char] -> Decoder s l
forall a. HasCallStack => [Char] -> Decoder s a
forall (m :: * -> *) a.
(MonadFail m, HasCallStack) =>
[Char] -> m a
fail ([Char] -> Decoder s l) -> [Char] -> Decoder s l
forall a b. (a -> b) -> a -> b
$
      [Char]
"decodeSnapshotBackwardsCompatible: invalid start "
        [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Maybe Int -> [Char]
forall a. Show a => a -> [Char]
show Maybe Int
mbListLen

{-------------------------------------------------------------------------------
  Policy
-------------------------------------------------------------------------------}

-- | Number of snapshots to be stored on disk. See the
-- @'SnapshotPolicy'@ documentation for more information.
newtype NumOfDiskSnapshots
  = NumOfDiskSnapshots {NumOfDiskSnapshots -> Word
getNumOfDiskSnapshots :: Word}
  deriving stock (NumOfDiskSnapshots -> NumOfDiskSnapshots -> Bool
(NumOfDiskSnapshots -> NumOfDiskSnapshots -> Bool)
-> (NumOfDiskSnapshots -> NumOfDiskSnapshots -> Bool)
-> Eq NumOfDiskSnapshots
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: NumOfDiskSnapshots -> NumOfDiskSnapshots -> Bool
== :: NumOfDiskSnapshots -> NumOfDiskSnapshots -> Bool
$c/= :: NumOfDiskSnapshots -> NumOfDiskSnapshots -> Bool
/= :: NumOfDiskSnapshots -> NumOfDiskSnapshots -> Bool
Eq, (forall x. NumOfDiskSnapshots -> Rep NumOfDiskSnapshots x)
-> (forall x. Rep NumOfDiskSnapshots x -> NumOfDiskSnapshots)
-> Generic NumOfDiskSnapshots
forall x. Rep NumOfDiskSnapshots x -> NumOfDiskSnapshots
forall x. NumOfDiskSnapshots -> Rep NumOfDiskSnapshots x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. NumOfDiskSnapshots -> Rep NumOfDiskSnapshots x
from :: forall x. NumOfDiskSnapshots -> Rep NumOfDiskSnapshots x
$cto :: forall x. Rep NumOfDiskSnapshots x -> NumOfDiskSnapshots
to :: forall x. Rep NumOfDiskSnapshots x -> NumOfDiskSnapshots
Generic, Int -> NumOfDiskSnapshots -> ShowS
[NumOfDiskSnapshots] -> ShowS
NumOfDiskSnapshots -> [Char]
(Int -> NumOfDiskSnapshots -> ShowS)
-> (NumOfDiskSnapshots -> [Char])
-> ([NumOfDiskSnapshots] -> ShowS)
-> Show NumOfDiskSnapshots
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> NumOfDiskSnapshots -> ShowS
showsPrec :: Int -> NumOfDiskSnapshots -> ShowS
$cshow :: NumOfDiskSnapshots -> [Char]
show :: NumOfDiskSnapshots -> [Char]
$cshowList :: [NumOfDiskSnapshots] -> ShowS
showList :: [NumOfDiskSnapshots] -> ShowS
Show)

-- | Type-safe flag to regulate the checksum policy of the ledger state snapshots.
--
-- These patterns are exposed to cardano-node and will be passed as part of @'SnapshotPolicy'@.
pattern DoDiskSnapshotChecksum, NoDoDiskSnapshotChecksum :: Flag "DoDiskSnapshotChecksum"
pattern $bDoDiskSnapshotChecksum :: Flag "DoDiskSnapshotChecksum"
$mDoDiskSnapshotChecksum :: forall {r}.
Flag "DoDiskSnapshotChecksum" -> ((# #) -> r) -> ((# #) -> r) -> r
DoDiskSnapshotChecksum = Flag True
pattern $bNoDoDiskSnapshotChecksum :: Flag "DoDiskSnapshotChecksum"
$mNoDoDiskSnapshotChecksum :: forall {r}.
Flag "DoDiskSnapshotChecksum" -> ((# #) -> r) -> ((# #) -> r) -> r
NoDoDiskSnapshotChecksum = Flag False

-- | Snapshots policy
--
-- We only write ledger states that are older than @k@ blocks to disk (that is,
-- snapshots that are guaranteed valid). The on-disk policy determines how often
-- we write to disk and how many checkpoints we keep.
data SnapshotPolicy = SnapshotPolicy
  { SnapshotPolicy -> NumOfDiskSnapshots
onDiskNumSnapshots :: NumOfDiskSnapshots
  -- ^ How many snapshots do we want to keep on disk?
  --
  -- A higher number of on-disk snapshots is primarily a safe-guard against
  -- disk corruption: it trades disk space for reliability.
  --
  -- Examples:
  --
  -- * @0@: Delete the snapshot immediately after writing.
  --        Probably not a useful value :-D
  -- * @1@: Delete the previous snapshot immediately after writing the next
  --        Dangerous policy: if for some reason the deletion happens before
  --        the new snapshot is written entirely to disk (we don't @fsync@),
  --        we have no choice but to start at the genesis snapshot on the
  --        next startup.
  -- * @2@: Always keep 2 snapshots around. This means that when we write
  --        the next snapshot, we delete the oldest one, leaving the middle
  --        one available in case of truncation of the write. This is
  --        probably a sane value in most circumstances.
  , SnapshotPolicy -> SnapshotSelectorContext -> [SlotNo]
onDiskSnapshotSelector :: SnapshotSelectorContext -> [SlotNo]
  -- ^ Select the slots to take a snapshot for, in increasing order. Must be a
  -- sublist of 'sscSnapshotSlots'.
  --
  -- See also 'defaultSnapshotPolicy'
  , SnapshotPolicy -> SnapshotDelayRange
onDiskSnapshotDelayRange :: SnapshotDelayRange
  -- ^ Minimum and maximum durations of the random delay between requesting
  -- a snapshot and taking that snapshot.
  }
  deriving [[Char]] -> SnapshotPolicy -> IO (Maybe ThunkInfo)
Proxy SnapshotPolicy -> [Char]
([[Char]] -> SnapshotPolicy -> IO (Maybe ThunkInfo))
-> ([[Char]] -> SnapshotPolicy -> IO (Maybe ThunkInfo))
-> (Proxy SnapshotPolicy -> [Char])
-> NoThunks SnapshotPolicy
forall a.
([[Char]] -> a -> IO (Maybe ThunkInfo))
-> ([[Char]] -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> [Char])
-> NoThunks a
$cnoThunks :: [[Char]] -> SnapshotPolicy -> IO (Maybe ThunkInfo)
noThunks :: [[Char]] -> SnapshotPolicy -> IO (Maybe ThunkInfo)
$cwNoThunks :: [[Char]] -> SnapshotPolicy -> IO (Maybe ThunkInfo)
wNoThunks :: [[Char]] -> SnapshotPolicy -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy SnapshotPolicy -> [Char]
showTypeOf :: Proxy SnapshotPolicy -> [Char]
NoThunks via OnlyCheckWhnf SnapshotPolicy

-- | Range from which the randomised snapshot delay will be taken. The randomly
-- chosen duration will be at least 'minimumDelay' and at most 'maximumDelay'.
data SnapshotDelayRange = SnapshotDelayRange
  { SnapshotDelayRange -> DiffTime
minimumDelay :: !DiffTime
  -- ^ minimum acceptable delay between requesting a snapshot and taking the
  -- snapshot
  , SnapshotDelayRange -> DiffTime
maximumDelay :: !DiffTime
  -- ^ maximum acceptable delay between requesting a snapshot and taking the
  -- snapshot
  }
  deriving (Int -> SnapshotDelayRange -> ShowS
[SnapshotDelayRange] -> ShowS
SnapshotDelayRange -> [Char]
(Int -> SnapshotDelayRange -> ShowS)
-> (SnapshotDelayRange -> [Char])
-> ([SnapshotDelayRange] -> ShowS)
-> Show SnapshotDelayRange
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SnapshotDelayRange -> ShowS
showsPrec :: Int -> SnapshotDelayRange -> ShowS
$cshow :: SnapshotDelayRange -> [Char]
show :: SnapshotDelayRange -> [Char]
$cshowList :: [SnapshotDelayRange] -> ShowS
showList :: [SnapshotDelayRange] -> ShowS
Show, SnapshotDelayRange -> SnapshotDelayRange -> Bool
(SnapshotDelayRange -> SnapshotDelayRange -> Bool)
-> (SnapshotDelayRange -> SnapshotDelayRange -> Bool)
-> Eq SnapshotDelayRange
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SnapshotDelayRange -> SnapshotDelayRange -> Bool
== :: SnapshotDelayRange -> SnapshotDelayRange -> Bool
$c/= :: SnapshotDelayRange -> SnapshotDelayRange -> Bool
/= :: SnapshotDelayRange -> SnapshotDelayRange -> Bool
Eq, (forall x. SnapshotDelayRange -> Rep SnapshotDelayRange x)
-> (forall x. Rep SnapshotDelayRange x -> SnapshotDelayRange)
-> Generic SnapshotDelayRange
forall x. Rep SnapshotDelayRange x -> SnapshotDelayRange
forall x. SnapshotDelayRange -> Rep SnapshotDelayRange x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. SnapshotDelayRange -> Rep SnapshotDelayRange x
from :: forall x. SnapshotDelayRange -> Rep SnapshotDelayRange x
$cto :: forall x. Rep SnapshotDelayRange x -> SnapshotDelayRange
to :: forall x. Rep SnapshotDelayRange x -> SnapshotDelayRange
Generic, [[Char]] -> SnapshotDelayRange -> IO (Maybe ThunkInfo)
Proxy SnapshotDelayRange -> [Char]
([[Char]] -> SnapshotDelayRange -> IO (Maybe ThunkInfo))
-> ([[Char]] -> SnapshotDelayRange -> IO (Maybe ThunkInfo))
-> (Proxy SnapshotDelayRange -> [Char])
-> NoThunks SnapshotDelayRange
forall a.
([[Char]] -> a -> IO (Maybe ThunkInfo))
-> ([[Char]] -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> [Char])
-> NoThunks a
$cnoThunks :: [[Char]] -> SnapshotDelayRange -> IO (Maybe ThunkInfo)
noThunks :: [[Char]] -> SnapshotDelayRange -> IO (Maybe ThunkInfo)
$cwNoThunks :: [[Char]] -> SnapshotDelayRange -> IO (Maybe ThunkInfo)
wNoThunks :: [[Char]] -> SnapshotDelayRange -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy SnapshotDelayRange -> [Char]
showTypeOf :: Proxy SnapshotDelayRange -> [Char]
NoThunks)

data SnapshotSelectorContext = SnapshotSelectorContext
  { SnapshotSelectorContext -> Maybe DiffTime
sscTimeSinceLast :: Maybe DiffTime
  -- ^ The time since the last snapshot, or 'Nothing' if none was taken yet.
  -- Note that 'Nothing' merely means no snapshot had been taking yet since the
  -- node was started; it does not necessarily mean that none exist on disk.
  , SnapshotSelectorContext -> [SlotNo]
sscSnapshotSlots :: [SlotNo]
  -- ^ An increasing list of slots for which a snapshot can be taken (as the
  -- corresponding ledger state is immutable). The result of
  -- 'onDiskSnapshotSelector' must be a subset of this list.
  }
  deriving stock Int -> SnapshotSelectorContext -> ShowS
[SnapshotSelectorContext] -> ShowS
SnapshotSelectorContext -> [Char]
(Int -> SnapshotSelectorContext -> ShowS)
-> (SnapshotSelectorContext -> [Char])
-> ([SnapshotSelectorContext] -> ShowS)
-> Show SnapshotSelectorContext
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SnapshotSelectorContext -> ShowS
showsPrec :: Int -> SnapshotSelectorContext -> ShowS
$cshow :: SnapshotSelectorContext -> [Char]
show :: SnapshotSelectorContext -> [Char]
$cshowList :: [SnapshotSelectorContext] -> ShowS
showList :: [SnapshotSelectorContext] -> ShowS
Show

-- | Determines when/how often we take ledger snapshots.
--
-- We only write snapshots for ledger states that are /immutable/. Concretely,
-- for every slot @s@ out of
--
-- > sfaOffset, sfaOffset + sfaInterval, sfaOffset + 2 * sfaInterval, sfaOffset + 3 * sfaInterval, ...
--
-- we write a snapshot for the most recent immutable ledger state before @s@.
-- This way, nodes with the same @sfaInterval@/@sfaOffset@ configuration create
-- snapshots for precisely the same slots.
--
-- For example, on Cardano mainnet, where @k=2160@ and @f=1/20@, setting
-- @sfaInterval = 10*k/f = 432000@ (one epoch) and @sfaOffset = 0@ will cause
-- the node to create snapshots for the last block in every Shelley epoch. By
-- setting @sfaOffset@ to eg @5*k/f@ (half an epoch), snapshots are created just
-- before the midway point in each epoch.
--
-- Additionally, there is an (optional, opt-out) rate limit (useful while
-- bulk-syncing). When set to a given duration, we will skip writing a snapshot
-- if less time than the given duration has passed since we finished writing the
-- previous snapshot (if any).
--
-- To avoid skipping a snapshot write when caught-up, it is advisable to set
-- 'sfaRateLimit' to something significantly smaller than the wall-clock duration
-- of 'sfaInterval'.
data SnapshotFrequencyArgs = SnapshotFrequencyArgs
  { SnapshotFrequencyArgs -> NonZero Word64
sfaInterval :: NonZero Word64
  -- ^ Try to write snapshots every 'sfaInterval' many slots.
  , SnapshotFrequencyArgs -> SlotNo
sfaOffset :: SlotNo
  -- ^ An offset for when to write snapshots, see 'SnapshotFrequency'.
  , SnapshotFrequencyArgs -> DiffTime
sfaRateLimit :: DiffTime
  -- ^ Ensure (if present) that at least this amount of time passes between
  -- writing snapshots. Setting this to a non-positive value disable the rate
  -- limit.
  , SnapshotFrequencyArgs -> SnapshotDelayRange
sfaDelaySnapshotRange :: SnapshotDelayRange
  }
  deriving stock (Int -> SnapshotFrequencyArgs -> ShowS
[SnapshotFrequencyArgs] -> ShowS
SnapshotFrequencyArgs -> [Char]
(Int -> SnapshotFrequencyArgs -> ShowS)
-> (SnapshotFrequencyArgs -> [Char])
-> ([SnapshotFrequencyArgs] -> ShowS)
-> Show SnapshotFrequencyArgs
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SnapshotFrequencyArgs -> ShowS
showsPrec :: Int -> SnapshotFrequencyArgs -> ShowS
$cshow :: SnapshotFrequencyArgs -> [Char]
show :: SnapshotFrequencyArgs -> [Char]
$cshowList :: [SnapshotFrequencyArgs] -> ShowS
showList :: [SnapshotFrequencyArgs] -> ShowS
Show, SnapshotFrequencyArgs -> SnapshotFrequencyArgs -> Bool
(SnapshotFrequencyArgs -> SnapshotFrequencyArgs -> Bool)
-> (SnapshotFrequencyArgs -> SnapshotFrequencyArgs -> Bool)
-> Eq SnapshotFrequencyArgs
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SnapshotFrequencyArgs -> SnapshotFrequencyArgs -> Bool
== :: SnapshotFrequencyArgs -> SnapshotFrequencyArgs -> Bool
$c/= :: SnapshotFrequencyArgs -> SnapshotFrequencyArgs -> Bool
/= :: SnapshotFrequencyArgs -> SnapshotFrequencyArgs -> Bool
Eq)

data SnapshotFrequency
  = SnapshotFrequency SnapshotFrequencyArgs
  | DisableSnapshots
  deriving stock (Int -> SnapshotFrequency -> ShowS
[SnapshotFrequency] -> ShowS
SnapshotFrequency -> [Char]
(Int -> SnapshotFrequency -> ShowS)
-> (SnapshotFrequency -> [Char])
-> ([SnapshotFrequency] -> ShowS)
-> Show SnapshotFrequency
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SnapshotFrequency -> ShowS
showsPrec :: Int -> SnapshotFrequency -> ShowS
$cshow :: SnapshotFrequency -> [Char]
show :: SnapshotFrequency -> [Char]
$cshowList :: [SnapshotFrequency] -> ShowS
showList :: [SnapshotFrequency] -> ShowS
Show, SnapshotFrequency -> SnapshotFrequency -> Bool
(SnapshotFrequency -> SnapshotFrequency -> Bool)
-> (SnapshotFrequency -> SnapshotFrequency -> Bool)
-> Eq SnapshotFrequency
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SnapshotFrequency -> SnapshotFrequency -> Bool
== :: SnapshotFrequency -> SnapshotFrequency -> Bool
$c/= :: SnapshotFrequency -> SnapshotFrequency -> Bool
/= :: SnapshotFrequency -> SnapshotFrequency -> Bool
Eq)

data SnapshotPolicyArgs = SnapshotPolicyArgs
  { SnapshotPolicyArgs -> SnapshotFrequency
spaFrequency :: SnapshotFrequency
  , SnapshotPolicyArgs -> NumOfDiskSnapshots
spaNum :: NumOfDiskSnapshots
  -- ^ See 'onDiskNumSnapshots'.
  }
  deriving stock (Int -> SnapshotPolicyArgs -> ShowS
[SnapshotPolicyArgs] -> ShowS
SnapshotPolicyArgs -> [Char]
(Int -> SnapshotPolicyArgs -> ShowS)
-> (SnapshotPolicyArgs -> [Char])
-> ([SnapshotPolicyArgs] -> ShowS)
-> Show SnapshotPolicyArgs
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SnapshotPolicyArgs -> ShowS
showsPrec :: Int -> SnapshotPolicyArgs -> ShowS
$cshow :: SnapshotPolicyArgs -> [Char]
show :: SnapshotPolicyArgs -> [Char]
$cshowList :: [SnapshotPolicyArgs] -> ShowS
showList :: [SnapshotPolicyArgs] -> ShowS
Show, SnapshotPolicyArgs -> SnapshotPolicyArgs -> Bool
(SnapshotPolicyArgs -> SnapshotPolicyArgs -> Bool)
-> (SnapshotPolicyArgs -> SnapshotPolicyArgs -> Bool)
-> Eq SnapshotPolicyArgs
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SnapshotPolicyArgs -> SnapshotPolicyArgs -> Bool
== :: SnapshotPolicyArgs -> SnapshotPolicyArgs -> Bool
$c/= :: SnapshotPolicyArgs -> SnapshotPolicyArgs -> Bool
/= :: SnapshotPolicyArgs -> SnapshotPolicyArgs -> Bool
Eq)

-- | Default snapshot policy args are Mithril snapshot policy args
defaultSnapshotPolicyArgs :: SnapshotPolicyArgs
defaultSnapshotPolicyArgs :: SnapshotPolicyArgs
defaultSnapshotPolicyArgs = SnapshotPolicyArgs
mithrilSnapshotPolicyArgs

-- | Snapshot Policy arguments to be used by Mithril
--
-- The snapshot interval is derived as follows:
--   * The epoch in Shelley is 432,000 slots long.
--
-- The snapshot offset is derived as follows:
--   * 21,600 slots per epoch in Byron
--   * The Byron era was 208 epochs long
--   * The Shelley era starts at 208 * 21,600 = 4,492,800 slots
--   * Half of a Shelley epoch is 432,000 / 2 = 216,000
--   * The resulting offset of the first snapshot in Shelley is 4,492,800 + 216,000 = 4,708,800
--   * Finally, if we want to start taking snapshot while still syncing Byron,
--     we must start at slot 4,708,800 % 432,000 = 388,800
mithrilSnapshotPolicyArgs :: SnapshotPolicyArgs
mithrilSnapshotPolicyArgs :: SnapshotPolicyArgs
mithrilSnapshotPolicyArgs =
  SnapshotPolicyArgs
    { spaFrequency :: SnapshotFrequency
spaFrequency =
        SnapshotFrequencyArgs -> SnapshotFrequency
SnapshotFrequency (SnapshotFrequencyArgs -> SnapshotFrequency)
-> SnapshotFrequencyArgs -> SnapshotFrequency
forall a b. (a -> b) -> a -> b
$
          SnapshotFrequencyArgs
            { sfaInterval :: NonZero Word64
sfaInterval = Word64 -> NonZero Word64
forall a. a -> NonZero a
unsafeNonZero Word64
432_000
            , sfaOffset :: SlotNo
sfaOffset = SlotNo
388_800
            , sfaRateLimit :: DiffTime
sfaRateLimit = Integer -> DiffTime
secondsToDiffTime (Integer -> DiffTime) -> Integer -> DiffTime
forall a b. (a -> b) -> a -> b
$ Integer
10 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
60
            , sfaDelaySnapshotRange :: SnapshotDelayRange
sfaDelaySnapshotRange = DiffTime -> DiffTime -> SnapshotDelayRange
SnapshotDelayRange DiffTime
fiveMinutes DiffTime
tenMinutes
            }
    , spaNum :: NumOfDiskSnapshots
spaNum = Word -> NumOfDiskSnapshots
NumOfDiskSnapshots Word
2
    }
 where
  fiveMinutes :: DiffTime
  fiveMinutes :: DiffTime
fiveMinutes = DiffTime
5 DiffTime -> DiffTime -> DiffTime
forall a. Num a => a -> a -> a
* DiffTime
60

  tenMinutes :: DiffTime
  tenMinutes :: DiffTime
tenMinutes = DiffTime
10 DiffTime -> DiffTime -> DiffTime
forall a. Num a => a -> a -> a
* DiffTime
60

-- | Default on-disk policy suitable to use with cardano-node
defaultSnapshotPolicy ::
  SnapshotPolicyArgs ->
  SnapshotPolicy
defaultSnapshotPolicy :: SnapshotPolicyArgs -> SnapshotPolicy
defaultSnapshotPolicy SnapshotPolicyArgs
args =
  SnapshotPolicy
    { onDiskNumSnapshots :: NumOfDiskSnapshots
onDiskNumSnapshots = NumOfDiskSnapshots
spaNum
    , SnapshotSelectorContext -> [SlotNo]
onDiskSnapshotSelector :: SnapshotSelectorContext -> [SlotNo]
onDiskSnapshotSelector :: SnapshotSelectorContext -> [SlotNo]
onDiskSnapshotSelector
    , SnapshotDelayRange
onDiskSnapshotDelayRange :: SnapshotDelayRange
onDiskSnapshotDelayRange :: SnapshotDelayRange
onDiskSnapshotDelayRange
    }
 where
  SnapshotPolicyArgs
    { SnapshotFrequency
spaFrequency :: SnapshotPolicyArgs -> SnapshotFrequency
spaFrequency :: SnapshotFrequency
spaFrequency
    , NumOfDiskSnapshots
spaNum :: SnapshotPolicyArgs -> NumOfDiskSnapshots
spaNum :: NumOfDiskSnapshots
spaNum
    } = SnapshotPolicyArgs
args

  onDiskSnapshotSelector :: SnapshotSelectorContext -> [SlotNo]
  onDiskSnapshotSelector :: SnapshotSelectorContext -> [SlotNo]
onDiskSnapshotSelector SnapshotSelectorContext
ctx
    | Just DiffTime
timeSinceLast <- SnapshotSelectorContext -> Maybe DiffTime
sscTimeSinceLast SnapshotSelectorContext
ctx
    , Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ DiffTime -> Bool
passesRateLimitCheck DiffTime
timeSinceLast =
        []
    | Bool
otherwise = case SnapshotFrequency
spaFrequency of
        SnapshotFrequency
DisableSnapshots -> []
        SnapshotFrequency
          SnapshotFrequencyArgs
            { NonZero Word64
sfaInterval :: SnapshotFrequencyArgs -> NonZero Word64
sfaInterval :: NonZero Word64
sfaInterval
            , SlotNo
sfaOffset :: SnapshotFrequencyArgs -> SlotNo
sfaOffset :: SlotNo
sfaOffset
            , DiffTime
sfaRateLimit :: SnapshotFrequencyArgs -> DiffTime
sfaRateLimit :: DiffTime
sfaRateLimit
            } ->
            [SlotNo] -> [SlotNo]
applyRateLimit ([SlotNo] -> [SlotNo]) -> [SlotNo] -> [SlotNo]
forall a b. (a -> b) -> a -> b
$
              [Maybe SlotNo] -> [SlotNo]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe SlotNo] -> [SlotNo]) -> [Maybe SlotNo] -> [SlotNo]
forall a b. (a -> b) -> a -> b
$
                (SlotNo -> SlotNo -> Maybe SlotNo)
-> [SlotNo] -> [SlotNo] -> [Maybe SlotNo]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith
                  SlotNo -> SlotNo -> Maybe SlotNo
shouldTakeSnapshot
                  (SnapshotSelectorContext -> [SlotNo]
sscSnapshotSlots SnapshotSelectorContext
ctx)
                  (Int -> [SlotNo] -> [SlotNo]
forall a. Int -> [a] -> [a]
drop Int
1 (SnapshotSelectorContext -> [SlotNo]
sscSnapshotSlots SnapshotSelectorContext
ctx))
           where
            -- Test whether there is a non-negative integer @n@ such that
            --
            -- > candidateSlot < offset + n * interval <= nextSlot
            --
            -- If so, return @'Just' 'candidateSlot'@ for snapshotting.
            shouldTakeSnapshot ::
              SlotNo -> -- The slot to potentially take a snapshot for.
              SlotNo -> -- The next slot in 'sscSnapshotSlots'.
              Maybe SlotNo
            shouldTakeSnapshot :: SlotNo -> SlotNo -> Maybe SlotNo
shouldTakeSnapshot SlotNo
candidateSlot SlotNo
nextSlot
              | SlotNo
nextSlot SlotNo -> SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
< SlotNo
sfaOffset = Maybe SlotNo
forall a. Maybe a
Nothing
              | SlotNo
candidateSlot SlotNo -> SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
< SlotNo
sfaOffset SlotNo -> SlotNo -> SlotNo
forall a. Num a => a -> a -> a
+ SlotNo
n SlotNo -> SlotNo -> SlotNo
forall a. Num a => a -> a -> a
* Word64 -> SlotNo
SlotNo (NonZero Word64 -> Word64
forall a. NonZero a -> a
unNonZero NonZero Word64
sfaInterval) = SlotNo -> Maybe SlotNo
forall a. a -> Maybe a
Just SlotNo
candidateSlot
              | Bool
otherwise = Maybe SlotNo
forall a. Maybe a
Nothing
             where
              n :: SlotNo
n = Word64 -> SlotNo
SlotNo (Word64 -> SlotNo) -> Word64 -> SlotNo
forall a b. (a -> b) -> a -> b
$ SlotNo -> Word64
unSlotNo (SlotNo
nextSlot SlotNo -> SlotNo -> SlotNo
forall a. Num a => a -> a -> a
- SlotNo
sfaOffset) Word64 -> Word64 -> Word64
forall a. Integral a => a -> a -> a
`div` (NonZero Word64 -> Word64
forall a. NonZero a -> a
unNonZero NonZero Word64
sfaInterval)

            -- When rate limiting is enabled, only return at most one (the last)
            -- of the slots satisfying 'shouldTakeSnapshot'.
            applyRateLimit :: [SlotNo] -> [SlotNo]
            applyRateLimit :: [SlotNo] -> [SlotNo]
applyRateLimit
              | DiffTime
sfaRateLimit DiffTime -> DiffTime -> Bool
forall a. Ord a => a -> a -> Bool
> DiffTime
0 = Maybe SlotNo -> [SlotNo]
forall a. Maybe a -> [a]
maybeToList (Maybe SlotNo -> [SlotNo])
-> ([SlotNo] -> Maybe SlotNo) -> [SlotNo] -> [SlotNo]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [SlotNo] -> Maybe SlotNo
forall a. [a] -> Maybe a
lastMaybe
              | Bool
otherwise = [SlotNo] -> [SlotNo]
forall a. a -> a
id

  onDiskSnapshotDelayRange :: SnapshotDelayRange
onDiskSnapshotDelayRange = case SnapshotFrequency
spaFrequency of
    SnapshotFrequency
DisableSnapshots -> DiffTime -> DiffTime -> SnapshotDelayRange
SnapshotDelayRange DiffTime
0 DiffTime
0 -- snapshots are disabled, but we need to provide some value here
    SnapshotFrequency SnapshotFrequencyArgs
sfa -> SnapshotFrequencyArgs -> SnapshotDelayRange
sfaDelaySnapshotRange SnapshotFrequencyArgs
sfa

  passesRateLimitCheck :: DiffTime -> Bool
passesRateLimitCheck DiffTime
t = case SnapshotFrequency
spaFrequency of
    SnapshotFrequency SnapshotFrequencyArgs{DiffTime
sfaRateLimit :: SnapshotFrequencyArgs -> DiffTime
sfaRateLimit :: DiffTime
sfaRateLimit} ->
      DiffTime
t DiffTime -> DiffTime -> Bool
forall a. Ord a => a -> a -> Bool
>= DiffTime
sfaRateLimit
    SnapshotFrequency
DisableSnapshots -> Bool
False

-- | The Cardano mainnet epoch length in slots, used as the reference for the
-- Mithril snapshot compatibility check in 'sanityCheckSnapshotPolicyArgs'.
-- Mithril requires a ledger snapshot at each epoch boundary; for snapshots to
-- land on every epoch boundary, 'sfaInterval' must divide this value evenly.
mithrilEpochSize :: Word64
mithrilEpochSize :: Word64
mithrilEpochSize = Word64
432000

-- | Check a 'SnapshotPolicyArgs' for suspicious configurations and return a
-- (possibly empty) list of 'SanityCheckIssue's describing any problems found.
--
-- Only 'Override' values are checked — 'UseDefault' values are known-good and
-- are never flagged. Checks that are specific to 'SnapshotFrequency' are
-- skipped entirely when 'spaFrequency' is 'DisableSnapshots'.
sanityCheckSnapshotPolicyArgs :: SnapshotPolicyArgs -> [SanityCheckIssue]
sanityCheckSnapshotPolicyArgs :: SnapshotPolicyArgs -> [SanityCheckIssue]
sanityCheckSnapshotPolicyArgs SnapshotPolicyArgs{SnapshotFrequency
spaFrequency :: SnapshotPolicyArgs -> SnapshotFrequency
spaFrequency :: SnapshotFrequency
spaFrequency, NumOfDiskSnapshots
spaNum :: SnapshotPolicyArgs -> NumOfDiskSnapshots
spaNum :: NumOfDiskSnapshots
spaNum} =
  [Maybe SanityCheckIssue] -> [SanityCheckIssue]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe SanityCheckIssue] -> [SanityCheckIssue])
-> [Maybe SanityCheckIssue] -> [SanityCheckIssue]
forall a b. (a -> b) -> a -> b
$
    NumOfDiskSnapshots -> Maybe SanityCheckIssue
checkNumZero NumOfDiskSnapshots
spaNum
      Maybe SanityCheckIssue
-> [Maybe SanityCheckIssue] -> [Maybe SanityCheckIssue]
forall a. a -> [a] -> [a]
: case SnapshotFrequency
spaFrequency of
        SnapshotFrequency
DisableSnapshots -> []
        SnapshotFrequency SnapshotFrequencyArgs
sfa -> SnapshotFrequencyArgs -> [Maybe SanityCheckIssue]
checkFrequencyArgs SnapshotFrequencyArgs
sfa
 where
  checkNumZero :: NumOfDiskSnapshots -> Maybe SanityCheckIssue
checkNumZero (NumOfDiskSnapshots Word
0) = SanityCheckIssue -> Maybe SanityCheckIssue
forall a. a -> Maybe a
Just SanityCheckIssue
SnapshotNumZero
  checkNumZero NumOfDiskSnapshots
_ = Maybe SanityCheckIssue
forall a. Maybe a
Nothing

  checkFrequencyArgs :: SnapshotFrequencyArgs -> [Maybe SanityCheckIssue]
checkFrequencyArgs SnapshotFrequencyArgs{SnapshotDelayRange
sfaDelaySnapshotRange :: SnapshotFrequencyArgs -> SnapshotDelayRange
sfaDelaySnapshotRange :: SnapshotDelayRange
sfaDelaySnapshotRange, DiffTime
sfaRateLimit :: SnapshotFrequencyArgs -> DiffTime
sfaRateLimit :: DiffTime
sfaRateLimit, NonZero Word64
sfaInterval :: SnapshotFrequencyArgs -> NonZero Word64
sfaInterval :: NonZero Word64
sfaInterval} =
    [ SnapshotDelayRange -> Maybe SanityCheckIssue
checkDelayRange SnapshotDelayRange
sfaDelaySnapshotRange
    , DiffTime -> Maybe SanityCheckIssue
forall {a}. (Ord a, Num a) => a -> Maybe SanityCheckIssue
checkRateLimitDisabled DiffTime
sfaRateLimit
    , DiffTime -> Maybe SanityCheckIssue
checkRateLimitLarge DiffTime
sfaRateLimit
    , NonZero Word64 -> Maybe SanityCheckIssue
checkMithrilDivisibility NonZero Word64
sfaInterval
    ]

  checkDelayRange :: SnapshotDelayRange -> Maybe SanityCheckIssue
checkDelayRange (SnapshotDelayRange DiffTime
mn DiffTime
mx)
    | DiffTime
mn DiffTime -> DiffTime -> Bool
forall a. Ord a => a -> a -> Bool
< DiffTime
0 = SanityCheckIssue -> Maybe SanityCheckIssue
forall a. a -> Maybe a
Just (DiffTime -> SanityCheckIssue
SnapshotDelayRangeNegativeMinimum DiffTime
mn)
    | DiffTime
mn DiffTime -> DiffTime -> Bool
forall a. Ord a => a -> a -> Bool
> DiffTime
mx = SanityCheckIssue -> Maybe SanityCheckIssue
forall a. a -> Maybe a
Just (DiffTime -> DiffTime -> SanityCheckIssue
SnapshotDelayRangeInverted DiffTime
mn DiffTime
mx)
    | Bool
otherwise = Maybe SanityCheckIssue
forall a. Maybe a
Nothing

  checkRateLimitDisabled :: a -> Maybe SanityCheckIssue
checkRateLimitDisabled a
rl
    | a
rl a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
0 = SanityCheckIssue -> Maybe SanityCheckIssue
forall a. a -> Maybe a
Just SanityCheckIssue
SnapshotRateLimitDisabled
    | Bool
otherwise = Maybe SanityCheckIssue
forall a. Maybe a
Nothing

  checkRateLimitLarge :: DiffTime -> Maybe SanityCheckIssue
checkRateLimitLarge DiffTime
rl
    | DiffTime
rl DiffTime -> DiffTime -> Bool
forall a. Ord a => a -> a -> Bool
> DiffTime
86400 = SanityCheckIssue -> Maybe SanityCheckIssue
forall a. a -> Maybe a
Just (DiffTime -> SanityCheckIssue
SnapshotRateLimitSuspiciouslyLarge DiffTime
rl)
    | Bool
otherwise = Maybe SanityCheckIssue
forall a. Maybe a
Nothing

  checkMithrilDivisibility :: NonZero Word64 -> Maybe SanityCheckIssue
checkMithrilDivisibility NonZero Word64
interval
    | Word64
mithrilEpochSize Word64 -> Word64 -> Word64
forall a. Integral a => a -> a -> a
`mod` NonZero Word64 -> Word64
forall a. NonZero a -> a
unNonZero NonZero Word64
interval Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word64
0 =
        SanityCheckIssue -> Maybe SanityCheckIssue
forall a. a -> Maybe a
Just (Word64 -> SanityCheckIssue
SnapshotIntervalNotDivisorOfEpoch (NonZero Word64 -> Word64
forall a. NonZero a -> a
unNonZero NonZero Word64
interval))
    | Bool
otherwise = Maybe SanityCheckIssue
forall a. Maybe a
Nothing

{-------------------------------------------------------------------------------
  Tracing snapshot events
-------------------------------------------------------------------------------}

data TraceSnapshotEvent blk
  = -- | An on disk snapshot was skipped because it was invalid.
    InvalidSnapshot DiskSnapshot (SnapshotFailure blk)
  | -- | A delayed snapshot requested was issued at a timestamp,
    --   with a delay and for ledger states at the specified slot numbers
    SnapshotRequestDelayed Time DiffTime (NonEmpty SlotNo)
  | -- | A snapshot request was completed
    SnapshotRequestCompleted
  | -- | A snapshot was written to disk.
    TookSnapshot DiskSnapshot (RealPoint blk) EnclosingTimed
  | -- | An old or invalid on-disk snapshot was deleted
    DeletedSnapshot DiskSnapshot
  deriving ((forall x.
 TraceSnapshotEvent blk -> Rep (TraceSnapshotEvent blk) x)
-> (forall x.
    Rep (TraceSnapshotEvent blk) x -> TraceSnapshotEvent blk)
-> Generic (TraceSnapshotEvent blk)
forall x. Rep (TraceSnapshotEvent blk) x -> TraceSnapshotEvent blk
forall x. TraceSnapshotEvent blk -> Rep (TraceSnapshotEvent blk) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall blk x.
Rep (TraceSnapshotEvent blk) x -> TraceSnapshotEvent blk
forall blk x.
TraceSnapshotEvent blk -> Rep (TraceSnapshotEvent blk) x
$cfrom :: forall blk x.
TraceSnapshotEvent blk -> Rep (TraceSnapshotEvent blk) x
from :: forall x. TraceSnapshotEvent blk -> Rep (TraceSnapshotEvent blk) x
$cto :: forall blk x.
Rep (TraceSnapshotEvent blk) x -> TraceSnapshotEvent blk
to :: forall x. Rep (TraceSnapshotEvent blk) x -> TraceSnapshotEvent blk
Generic, TraceSnapshotEvent blk -> TraceSnapshotEvent blk -> Bool
(TraceSnapshotEvent blk -> TraceSnapshotEvent blk -> Bool)
-> (TraceSnapshotEvent blk -> TraceSnapshotEvent blk -> Bool)
-> Eq (TraceSnapshotEvent blk)
forall blk.
StandardHash blk =>
TraceSnapshotEvent blk -> TraceSnapshotEvent blk -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall blk.
StandardHash blk =>
TraceSnapshotEvent blk -> TraceSnapshotEvent blk -> Bool
== :: TraceSnapshotEvent blk -> TraceSnapshotEvent blk -> Bool
$c/= :: forall blk.
StandardHash blk =>
TraceSnapshotEvent blk -> TraceSnapshotEvent blk -> Bool
/= :: TraceSnapshotEvent blk -> TraceSnapshotEvent blk -> Bool
Eq, Int -> TraceSnapshotEvent blk -> ShowS
[TraceSnapshotEvent blk] -> ShowS
TraceSnapshotEvent blk -> [Char]
(Int -> TraceSnapshotEvent blk -> ShowS)
-> (TraceSnapshotEvent blk -> [Char])
-> ([TraceSnapshotEvent blk] -> ShowS)
-> Show (TraceSnapshotEvent blk)
forall blk.
StandardHash blk =>
Int -> TraceSnapshotEvent blk -> ShowS
forall blk. StandardHash blk => [TraceSnapshotEvent blk] -> ShowS
forall blk. StandardHash blk => TraceSnapshotEvent blk -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall blk.
StandardHash blk =>
Int -> TraceSnapshotEvent blk -> ShowS
showsPrec :: Int -> TraceSnapshotEvent blk -> ShowS
$cshow :: forall blk. StandardHash blk => TraceSnapshotEvent blk -> [Char]
show :: TraceSnapshotEvent blk -> [Char]
$cshowList :: forall blk. StandardHash blk => [TraceSnapshotEvent blk] -> ShowS
showList :: [TraceSnapshotEvent blk] -> ShowS
Show)