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

-- | Common logic and types for LedgerDB Snapshots.
--
-- Snapshots are saved copies of Ledger states in the chain which can be used to
-- restart the node without having to replay the whole chain. Regardless of the
-- actual LedgerDB implementation chosen, the general management of snapshots is
-- common to all implementations.
module Ouroboros.Consensus.Storage.LedgerDB.Snapshots (
    -- * Snapshots
    CRCError (..)
  , DiskSnapshot (..)
  , MetadataErr (..)
  , NumOfDiskSnapshots (..)
  , ReadSnapshotErr (..)
  , SnapshotBackend (..)
  , SnapshotFailure (..)
  , SnapshotMetadata (..)
  , SnapshotPolicyArgs (..)
  , defaultSnapshotPolicyArgs
    -- * Codec
  , readExtLedgerState
  , writeExtLedgerState
    -- * Paths
  , diskSnapshotIsTemporary
  , snapshotFromPath
  , snapshotToChecksumPath
  , snapshotToDirName
  , snapshotToDirPath
  , snapshotToMetadataPath
    -- * Management
  , deleteSnapshot
  , listSnapshots
  , loadSnapshotMetadata
  , trimSnapshots
  , writeSnapshotMetadata
    -- * Policy
  , SnapshotInterval (..)
  , SnapshotPolicy (..)
  , defaultSnapshotPolicy
  , 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.Functor.Identity
import qualified Data.List as List
import           Data.Maybe (isJust, mapMaybe)
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.Config
import           Ouroboros.Consensus.Ledger.Abstract (EmptyMK)
import           Ouroboros.Consensus.Ledger.Extended
import           Ouroboros.Consensus.Util (Flag (..))
import           Ouroboros.Consensus.Util.CallStack
import           Ouroboros.Consensus.Util.CBOR (ReadIncrementalErr,
                     decodeWithOrigin, readIncremental)
import           Ouroboros.Consensus.Util.CRC
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 {
      -- | 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 deleted/.
    , 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
$cshowsPrec :: Int -> DiskSnapshot -> ShowS
showsPrec :: Int -> DiskSnapshot -> ShowS
$cshow :: DiskSnapshot -> String
show :: DiskSnapshot -> String
$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)

instance Ord DiskSnapshot where
  compare :: DiskSnapshot -> DiskSnapshot -> Ordering
compare = (DiskSnapshot -> Word64)
-> DiskSnapshot -> DiskSnapshot -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing DiskSnapshot -> Word64
dsNumber

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 (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 -> SnapshotFailure blk -> ShowS
[SnapshotFailure blk] -> ShowS
SnapshotFailure blk -> String
(Int -> SnapshotFailure blk -> ShowS)
-> (SnapshotFailure blk -> String)
-> ([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 -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([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 -> String
show :: SnapshotFailure blk -> String
$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
  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 -> String
(Int -> ReadSnapshotErr -> ShowS)
-> (ReadSnapshotErr -> String)
-> ([ReadSnapshotErr] -> ShowS)
-> Show ReadSnapshotErr
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ReadSnapshotErr -> ShowS
showsPrec :: Int -> ReadSnapshotErr -> ShowS
$cshow :: ReadSnapshotErr -> String
show :: ReadSnapshotErr -> String
$cshowList :: [ReadSnapshotErr] -> ShowS
showList :: [ReadSnapshotErr] -> ShowS
Show)

data SnapshotMetadata = SnapshotMetadata
  { SnapshotMetadata -> SnapshotBackend
snapshotBackend  :: SnapshotBackend
  , SnapshotMetadata -> CRC
snapshotChecksum :: CRC
  } 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 -> String
(Int -> SnapshotMetadata -> ShowS)
-> (SnapshotMetadata -> String)
-> ([SnapshotMetadata] -> ShowS)
-> Show SnapshotMetadata
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SnapshotMetadata -> ShowS
showsPrec :: Int -> SnapshotMetadata -> ShowS
$cshow :: SnapshotMetadata -> String
show :: SnapshotMetadata -> String
$cshowList :: [SnapshotMetadata] -> ShowS
showList :: [SnapshotMetadata] -> ShowS
Show)

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

instance FromJSON SnapshotMetadata where
  parseJSON :: Value -> Parser SnapshotMetadata
parseJSON = String
-> (Object -> Parser SnapshotMetadata)
-> Value
-> Parser SnapshotMetadata
forall a. String -> (Object -> Parser a) -> Value -> Parser a
Aeson.withObject String
"SnapshotMetadata" ((Object -> Parser SnapshotMetadata)
 -> Value -> Parser SnapshotMetadata)
-> (Object -> Parser SnapshotMetadata)
-> Value
-> Parser SnapshotMetadata
forall a b. (a -> b) -> a -> b
$ \Object
o ->
    SnapshotBackend -> CRC -> SnapshotMetadata
SnapshotMetadata (SnapshotBackend -> CRC -> SnapshotMetadata)
-> Parser SnapshotBackend -> Parser (CRC -> 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 -> SnapshotMetadata)
-> Parser CRC -> 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
<*> (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")

data SnapshotBackend =
    UTxOHDMemSnapshot
  | UTxOHDLMDBSnapshot
  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 -> String
(Int -> SnapshotBackend -> ShowS)
-> (SnapshotBackend -> String)
-> ([SnapshotBackend] -> ShowS)
-> Show SnapshotBackend
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SnapshotBackend -> ShowS
showsPrec :: Int -> SnapshotBackend -> ShowS
$cshow :: SnapshotBackend -> String
show :: SnapshotBackend -> String
$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"

instance FromJSON SnapshotBackend where
  parseJSON :: Value -> Parser SnapshotBackend
parseJSON = String
-> (Text -> Parser SnapshotBackend)
-> Value
-> Parser SnapshotBackend
forall a. String -> (Text -> Parser a) -> Value -> Parser a
Aeson.withText String
"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
_ -> String -> Parser SnapshotBackend
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"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 -> String
(Int -> MetadataErr -> ShowS)
-> (MetadataErr -> String)
-> ([MetadataErr] -> ShowS)
-> Show MetadataErr
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> MetadataErr -> ShowS
showsPrec :: Int -> MetadataErr -> ShowS
$cshow :: MetadataErr -> String
show :: MetadataErr -> String
$cshowList :: [MetadataErr] -> ShowS
showList :: [MetadataErr] -> ShowS
Show)

-- | Named snapshot are permanent, they will never be deleted even if failing to
-- deserialize.
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 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 :: String -> Maybe DiskSnapshot
snapshotFromPath String
fileName = do
    number <- String -> Maybe Word64
forall a. Read a => String -> Maybe a
readMaybe String
prefix
    return $ DiskSnapshot number 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

-- | List on-disk snapshots, highest number first.
listSnapshots :: Monad m => SomeHasFS m -> m [DiskSnapshot]
listSnapshots :: forall (m :: * -> *). Monad m => SomeHasFS m -> m [DiskSnapshot]
listSnapshots (SomeHasFS HasFS{HasCallStack => FsPath -> m (Set String)
listDirectory :: HasCallStack => FsPath -> m (Set String)
listDirectory :: forall (m :: * -> *) h.
HasFS m h -> HasCallStack => FsPath -> m (Set String)
listDirectory}) =
    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

-- | Delete snapshot from disk
deleteSnapshot :: (Monad m, HasCallStack) => SomeHasFS m -> DiskSnapshot -> m ()
deleteSnapshot :: forall (m :: * -> *).
(Monad m, HasCallStack) =>
SomeHasFS m -> DiskSnapshot -> m ()
deleteSnapshot (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}) DiskSnapshot
ss = 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)

-- | 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 String
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
$ String -> MetadataErr
MetadataInvalid String
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 => SomeHasFS m -> (FilePath -> m a) -> m ()
snapshotsMapM_ :: forall (m :: * -> *) a.
Monad m =>
SomeHasFS m -> (String -> m a) -> m ()
snapshotsMapM_ (SomeHasFS HasFS m h
fs) String -> m a
f = do
  (String -> m a) -> Maybe String -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ String -> m a
f (Maybe String -> m ()) -> m (Maybe String) -> m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Set String -> Maybe String
forall a. Set a -> Maybe a
Set.lookupMax (Set String -> Maybe String)
-> (Set String -> Set String) -> Set String -> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Bool) -> Set String -> Set String
forall a. (a -> Bool) -> Set a -> Set a
Set.filter (Maybe DiskSnapshot -> Bool
forall a. Maybe a -> Bool
isJust (Maybe DiskSnapshot -> Bool)
-> (String -> Maybe DiskSnapshot) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe DiskSnapshot
snapshotFromPath) (Set String -> Maybe String) -> m (Set String) -> m (Maybe String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HasFS m h -> HasCallStack => FsPath -> m (Set String)
forall (m :: * -> *) h.
HasFS m h -> HasCallStack => FsPath -> m (Set String)
listDirectory HasFS m h
fs ([String] -> FsPath
mkFsPath [])

-- | Testing only! Destroy all snapshots in the DB.
destroySnapshots :: Monad m => SomeHasFS m -> m ()
destroySnapshots :: forall (m :: * -> *). Monad m => SomeHasFS m -> m ()
destroySnapshots sfs :: SomeHasFS m
sfs@(SomeHasFS HasFS m h
fs) = do
  SomeHasFS m -> (String -> m ()) -> m ()
forall (m :: * -> *) a.
Monad m =>
SomeHasFS m -> (String -> m a) -> m ()
snapshotsMapM_ SomeHasFS m
sfs ((\FsPath
d -> do
            isDir <- HasFS m h -> HasCallStack => FsPath -> m Bool
forall (m :: * -> *) h.
HasFS m h -> HasCallStack => FsPath -> m Bool
doesDirectoryExist HasFS m h
fs FsPath
d
            if isDir
              then removeDirectoryRecursive fs d
              else removeFile fs d
        ) (FsPath -> m ()) -> (String -> FsPath) -> String -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> FsPath
mkFsPath ([String] -> FsPath) -> (String -> [String]) -> String -> FsPath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> [String] -> [String]
forall a. a -> [a] -> [a]
:[]))

-- | 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
  => Tracer m (TraceSnapshotEvent r)
  -> SomeHasFS m
  -> SnapshotPolicy
  -> m [DiskSnapshot]
trimSnapshots :: forall (m :: * -> *) r.
Monad m =>
Tracer m (TraceSnapshotEvent r)
-> SomeHasFS m -> SnapshotPolicy -> m [DiskSnapshot]
trimSnapshots Tracer m (TraceSnapshotEvent r)
tracer SomeHasFS m
fs SnapshotPolicy{Word
onDiskNumSnapshots :: SnapshotPolicy -> Word
onDiskNumSnapshots :: Word
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
<$> SomeHasFS m -> m [DiskSnapshot]
forall (m :: * -> *). Monad m => SomeHasFS m -> m [DiskSnapshot]
listSnapshots SomeHasFS m
fs
    -- 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
onDiskNumSnapshots) [DiskSnapshot]
ss
    mapM
        (\DiskSnapshot
s -> do
          SomeHasFS m -> DiskSnapshot -> m ()
forall (m :: * -> *).
(Monad m, HasCallStack) =>
SomeHasFS m -> DiskSnapshot -> m ()
deleteSnapshot SomeHasFS m
fs DiskSnapshot
s
          Tracer m (TraceSnapshotEvent r) -> TraceSnapshotEvent r -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (TraceSnapshotEvent r)
tracer (TraceSnapshotEvent r -> m ()) -> TraceSnapshotEvent r -> m ()
forall a b. (a -> b) -> a -> b
$ DiskSnapshot -> TraceSnapshotEvent r
forall blk. DiskSnapshot -> TraceSnapshotEvent blk
DeletedSnapshot 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 -> String
snapshotToDirName DiskSnapshot { Word64
dsNumber :: DiskSnapshot -> Word64
dsNumber :: Word64
dsNumber, Maybe String
dsSuffix :: DiskSnapshot -> Maybe String
dsSuffix :: 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

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

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

-- | The path within the LedgerDB's filesystem to the snapshot's directory
snapshotToDirPath :: DiskSnapshot -> FsPath
snapshotToDirPath :: DiskSnapshot -> FsPath
snapshotToDirPath = [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
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 =
        String -> Decoder s l
forall a. String -> Decoder s a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Decoder s l) -> String -> Decoder s l
forall a b. (a -> b) -> a -> b
$
          String
"decodeSnapshotBackwardsCompatible: invalid start " String -> ShowS
forall a. Semigroup a => a -> a -> a
<>
          Maybe Int -> String
forall a. Show a => a -> String
show Maybe Int
mbListLen

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

-- | Length of time that has to pass after which a snapshot is taken.
data SnapshotInterval =
    DefaultSnapshotInterval
  | RequestedSnapshotInterval DiffTime
  | DisableSnapshots
  deriving stock (SnapshotInterval -> SnapshotInterval -> Bool
(SnapshotInterval -> SnapshotInterval -> Bool)
-> (SnapshotInterval -> SnapshotInterval -> Bool)
-> Eq SnapshotInterval
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SnapshotInterval -> SnapshotInterval -> Bool
== :: SnapshotInterval -> SnapshotInterval -> Bool
$c/= :: SnapshotInterval -> SnapshotInterval -> Bool
/= :: SnapshotInterval -> SnapshotInterval -> Bool
Eq, (forall x. SnapshotInterval -> Rep SnapshotInterval x)
-> (forall x. Rep SnapshotInterval x -> SnapshotInterval)
-> Generic SnapshotInterval
forall x. Rep SnapshotInterval x -> SnapshotInterval
forall x. SnapshotInterval -> Rep SnapshotInterval x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. SnapshotInterval -> Rep SnapshotInterval x
from :: forall x. SnapshotInterval -> Rep SnapshotInterval x
$cto :: forall x. Rep SnapshotInterval x -> SnapshotInterval
to :: forall x. Rep SnapshotInterval x -> SnapshotInterval
Generic, Int -> SnapshotInterval -> ShowS
[SnapshotInterval] -> ShowS
SnapshotInterval -> String
(Int -> SnapshotInterval -> ShowS)
-> (SnapshotInterval -> String)
-> ([SnapshotInterval] -> ShowS)
-> Show SnapshotInterval
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SnapshotInterval -> ShowS
showsPrec :: Int -> SnapshotInterval -> ShowS
$cshow :: SnapshotInterval -> String
show :: SnapshotInterval -> String
$cshowList :: [SnapshotInterval] -> ShowS
showList :: [SnapshotInterval] -> ShowS
Show)

-- | Number of snapshots to be stored on disk. This is either the default value
-- as determined by the @'SnapshotPolicy'@, or it is provided by the user. See the
-- @'SnapshotPolicy'@ documentation for more information.
data NumOfDiskSnapshots =
    DefaultNumOfDiskSnapshots
  | RequestedNumOfDiskSnapshots 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 -> String
(Int -> NumOfDiskSnapshots -> ShowS)
-> (NumOfDiskSnapshots -> String)
-> ([NumOfDiskSnapshots] -> ShowS)
-> Show NumOfDiskSnapshots
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> NumOfDiskSnapshots -> ShowS
showsPrec :: Int -> NumOfDiskSnapshots -> ShowS
$cshow :: NumOfDiskSnapshots -> String
show :: NumOfDiskSnapshots -> String
$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 $mDoDiskSnapshotChecksum :: forall {r}.
Flag "DoDiskSnapshotChecksum" -> ((# #) -> r) -> ((# #) -> r) -> r
$bDoDiskSnapshotChecksum :: Flag "DoDiskSnapshotChecksum"
DoDiskSnapshotChecksum = Flag True
pattern $mNoDoDiskSnapshotChecksum :: forall {r}.
Flag "DoDiskSnapshotChecksum" -> ((# #) -> r) -> ((# #) -> r) -> r
$bNoDoDiskSnapshotChecksum :: Flag "DoDiskSnapshotChecksum"
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 {
      -- | 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 -> Word
onDiskNumSnapshots       :: Word

      -- | Should we write a snapshot of the ledger state to disk?
      --
      -- This function is passed two bits of information:
      --
      -- * The time since the last snapshot, or 'NoSnapshotTakenYet' if none was taken yet.
      --   Note that 'NoSnapshotTakenYet' merely means no snapshot had been taking yet
      --   since the node was started; it does not necessarily mean that none
      --   exist on disk.
      --
      -- * The distance in terms of blocks applied to the /oldest/ ledger
      --   snapshot in memory. During normal operation, this is the number of
      --   blocks written to the ImmutableDB since the last snapshot. On
      --   startup, it is computed by counting how many immutable blocks we had
      --   to reapply to get to the chain tip. This is useful, as it allows the
      --   policy to decide to take a snapshot /on node startup/ if a lot of
      --   blocks had to be replayed.
      --
      -- See also 'defaultSnapshotPolicy'
    , SnapshotPolicy -> Maybe DiffTime -> Word64 -> Bool
onDiskShouldTakeSnapshot :: Maybe DiffTime -> Word64 -> Bool
    }
  deriving [String] -> SnapshotPolicy -> IO (Maybe ThunkInfo)
Proxy SnapshotPolicy -> String
([String] -> SnapshotPolicy -> IO (Maybe ThunkInfo))
-> ([String] -> SnapshotPolicy -> IO (Maybe ThunkInfo))
-> (Proxy SnapshotPolicy -> String)
-> NoThunks SnapshotPolicy
forall a.
([String] -> a -> IO (Maybe ThunkInfo))
-> ([String] -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: [String] -> SnapshotPolicy -> IO (Maybe ThunkInfo)
noThunks :: [String] -> SnapshotPolicy -> IO (Maybe ThunkInfo)
$cwNoThunks :: [String] -> SnapshotPolicy -> IO (Maybe ThunkInfo)
wNoThunks :: [String] -> SnapshotPolicy -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy SnapshotPolicy -> String
showTypeOf :: Proxy SnapshotPolicy -> String
NoThunks via OnlyCheckWhnf SnapshotPolicy

data SnapshotPolicyArgs = SnapshotPolicyArgs {
    SnapshotPolicyArgs -> SnapshotInterval
spaInterval :: !SnapshotInterval
  , SnapshotPolicyArgs -> NumOfDiskSnapshots
spaNum      :: !NumOfDiskSnapshots
  }

defaultSnapshotPolicyArgs :: SnapshotPolicyArgs
defaultSnapshotPolicyArgs :: SnapshotPolicyArgs
defaultSnapshotPolicyArgs =
  SnapshotInterval -> NumOfDiskSnapshots -> SnapshotPolicyArgs
SnapshotPolicyArgs
    SnapshotInterval
DefaultSnapshotInterval
    NumOfDiskSnapshots
DefaultNumOfDiskSnapshots

-- | Default on-disk policy suitable to use with cardano-node
--
defaultSnapshotPolicy ::
     SecurityParam
  -> SnapshotPolicyArgs
  -> SnapshotPolicy
defaultSnapshotPolicy :: SecurityParam -> SnapshotPolicyArgs -> SnapshotPolicy
defaultSnapshotPolicy
  (SecurityParam NonZero Word64
k)
  (SnapshotPolicyArgs SnapshotInterval
requestedInterval NumOfDiskSnapshots
reqNumOfSnapshots) =
    SnapshotPolicy {
        Word
onDiskNumSnapshots :: Word
onDiskNumSnapshots :: Word
onDiskNumSnapshots
      , Maybe DiffTime -> Word64 -> Bool
onDiskShouldTakeSnapshot :: Maybe DiffTime -> Word64 -> Bool
onDiskShouldTakeSnapshot :: Maybe DiffTime -> Word64 -> Bool
onDiskShouldTakeSnapshot
      }
  where
    onDiskNumSnapshots :: Word
    onDiskNumSnapshots :: Word
onDiskNumSnapshots = case NumOfDiskSnapshots
reqNumOfSnapshots of
      NumOfDiskSnapshots
DefaultNumOfDiskSnapshots         -> Word
2
      RequestedNumOfDiskSnapshots Word
value -> Word
value

    onDiskShouldTakeSnapshot ::
         Maybe DiffTime
      -> Word64
      -> Bool
    onDiskShouldTakeSnapshot :: Maybe DiffTime -> Word64 -> Bool
onDiskShouldTakeSnapshot Maybe DiffTime
Nothing Word64
blocksSinceLast =
      -- If users never leave their wallet running for long, this would mean
      -- that under some circumstances we would never take a snapshot
      -- So, on startup (when the 'time since the last snapshot' is `Nothing`),
      -- we take a snapshot as soon as there are @k@ blocks replayed.
      -- This means that even if users frequently shut down their wallet, we still
      -- take a snapshot roughly every @k@ blocks. It does mean the possibility of
      -- an extra unnecessary snapshot during syncing (if the node is restarted), but
      -- that is not a big deal.
      Word64
blocksSinceLast Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
>=NonZero Word64 -> Word64
forall a. NonZero a -> a
unNonZero NonZero Word64
k

    onDiskShouldTakeSnapshot (Just DiffTime
timeSinceLast) Word64
blocksSinceLast =
         DiffTime -> Bool
snapshotInterval DiffTime
timeSinceLast
      Bool -> Bool -> Bool
|| Word64 -> DiffTime -> Bool
forall {a}. (Ord a, Num a) => a -> DiffTime -> Bool
substantialAmountOfBlocksWereProcessed Word64
blocksSinceLast DiffTime
timeSinceLast

    -- | We want to create a snapshot after a substantial amount of blocks were
    -- processed (hard-coded to 50k blocks). Given the fact that during bootstrap
    -- a fresh node will see a lot of blocks over a short period of time, we want
    -- to limit this condition to happen not more often then a fixed amount of
    -- time (here hard-coded to 6 minutes)
    substantialAmountOfBlocksWereProcessed :: a -> DiffTime -> Bool
substantialAmountOfBlocksWereProcessed a
blocksSinceLast DiffTime
timeSinceLast =
      let minBlocksBeforeSnapshot :: a
minBlocksBeforeSnapshot      = a
50_000
          minTimeBeforeSnapshot :: DiffTime
minTimeBeforeSnapshot        = DiffTime
6 DiffTime -> DiffTime -> DiffTime
forall a. Num a => a -> a -> a
* Integer -> DiffTime
secondsToDiffTime Integer
60
      in    a
blocksSinceLast a -> a -> Bool
forall a. Ord a => a -> a -> Bool
>= a
minBlocksBeforeSnapshot
         Bool -> Bool -> Bool
&& DiffTime
timeSinceLast   DiffTime -> DiffTime -> Bool
forall a. Ord a => a -> a -> Bool
>= DiffTime
minTimeBeforeSnapshot

    -- | Requested snapshot interval can be explicitly provided by the
    -- caller (RequestedSnapshotInterval) or the caller might request the default
    -- snapshot interval (DefaultSnapshotInterval). If the latter then the
    -- snapshot interval is defaulted to k * 2 seconds - when @k = 2160@ the interval
    -- defaults to 72 minutes.
    snapshotInterval :: DiffTime -> Bool
snapshotInterval DiffTime
t = case SnapshotInterval
requestedInterval of
      RequestedSnapshotInterval DiffTime
value -> DiffTime
t DiffTime -> DiffTime -> Bool
forall a. Ord a => a -> a -> Bool
>= DiffTime
value
      SnapshotInterval
DefaultSnapshotInterval         -> DiffTime
t DiffTime -> DiffTime -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer -> DiffTime
secondsToDiffTime (Word64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Integer) -> Word64 -> Integer
forall a b. (a -> b) -> a -> b
$ NonZero Word64 -> Word64
forall a. NonZero a -> a
unNonZero NonZero Word64
k Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Word64
2)
      SnapshotInterval
DisableSnapshots                -> Bool
False

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

data TraceSnapshotEvent blk
  = InvalidSnapshot DiskSnapshot (SnapshotFailure blk)
    -- ^ An on disk snapshot was skipped because it was invalid.
  | TookSnapshot DiskSnapshot (RealPoint blk) EnclosingTimed
    -- ^ A snapshot was written to disk.
  | DeletedSnapshot DiskSnapshot
    -- ^ An old or invalid on-disk snapshot was deleted
  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 -> String
(Int -> TraceSnapshotEvent blk -> ShowS)
-> (TraceSnapshotEvent blk -> String)
-> ([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 -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([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 -> String
show :: TraceSnapshotEvent blk -> String
$cshowList :: forall blk. StandardHash blk => [TraceSnapshotEvent blk] -> ShowS
showList :: [TraceSnapshotEvent blk] -> ShowS
Show)