{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

module Ouroboros.Consensus.Storage.LedgerDB.Snapshots (
    DiskSnapshot (..)
    -- * Read from disk
  , SnapshotFailure (..)
  , diskSnapshotIsTemporary
  , listSnapshots
  , readSnapshot
    -- * Write to disk
  , takeSnapshot
  , trimSnapshots
  , writeSnapshot
    -- * Low-level API (primarily exposed for testing)
  , decodeSnapshotBackwardsCompatible
  , deleteSnapshot
  , encodeSnapshot
  , snapshotToFileName
  , snapshotToPath
    -- * Trace
  , TraceSnapshotEvent (..)
  ) where

import qualified Codec.CBOR.Write as CBOR
import           Codec.Serialise.Decoding (Decoder)
import qualified Codec.Serialise.Decoding as Dec
import           Codec.Serialise.Encoding (Encoding)
import           Control.Monad (forM, void)
import           Control.Monad.Except (ExceptT (..))
import           Control.Tracer
import           Data.Functor.Contravariant ((>$<))
import qualified Data.List as List
import           Data.Maybe (isJust, mapMaybe)
import           Data.Ord (Down (..))
import           Data.Set (Set)
import qualified Data.Set as Set
import           Data.Word
import           GHC.Generics (Generic)
import           GHC.Stack
import           Ouroboros.Consensus.Block
import           Ouroboros.Consensus.Ledger.Abstract
import           Ouroboros.Consensus.Ledger.Extended
import           Ouroboros.Consensus.Storage.LedgerDB.DiskPolicy
import           Ouroboros.Consensus.Util.CBOR (ReadIncrementalErr,
                     decodeWithOrigin, readIncremental)
import           Ouroboros.Consensus.Util.Enclose
import           Ouroboros.Consensus.Util.IOLike
import           Ouroboros.Consensus.Util.Versioned
import           System.FS.API.Lazy
import           Text.Read (readMaybe)

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

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

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

    -- | This snapshot was of the ledger state at genesis, even though we never
    -- take snapshots at genesis, so this is unexpected.
  | InitFailureGenesis
  deriving (Int -> 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 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)

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

-- | 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
  -> DiskPolicy
  -> m [DiskSnapshot]
trimSnapshots :: forall (m :: * -> *) r.
Monad m =>
Tracer m (TraceSnapshotEvent r)
-> SomeHasFS m -> DiskPolicy -> m [DiskSnapshot]
trimSnapshots Tracer m (TraceSnapshotEvent r)
tracer SomeHasFS m
hasFS DiskPolicy{Word
TimeSinceLast DiffTime -> Word64 -> Bool
onDiskNumSnapshots :: DiskPolicy -> Word
onDiskNumSnapshots :: Word
onDiskShouldTakeSnapshot :: TimeSinceLast DiffTime -> Word64 -> Bool
onDiskShouldTakeSnapshot :: DiskPolicy -> TimeSinceLast DiffTime -> Word64 -> Bool
..} = do
    -- We only trim temporary snapshots
    [DiskSnapshot]
snapshots <- (DiskSnapshot -> Bool) -> [DiskSnapshot] -> [DiskSnapshot]
forall a. (a -> Bool) -> [a] -> [a]
filter DiskSnapshot -> Bool
diskSnapshotIsTemporary ([DiskSnapshot] -> [DiskSnapshot])
-> m [DiskSnapshot] -> m [DiskSnapshot]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SomeHasFS m -> m [DiskSnapshot]
forall (m :: * -> *). Monad m => SomeHasFS m -> m [DiskSnapshot]
listSnapshots SomeHasFS m
hasFS
    -- The snapshot are most recent first, so we can simply drop from the
    -- front to get the snapshots that are "too" old.
    [DiskSnapshot]
-> (DiskSnapshot -> m DiskSnapshot) -> m [DiskSnapshot]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (Int -> [DiskSnapshot] -> [DiskSnapshot]
forall a. Int -> [a] -> [a]
drop (Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
onDiskNumSnapshots) [DiskSnapshot]
snapshots) ((DiskSnapshot -> m DiskSnapshot) -> m [DiskSnapshot])
-> (DiskSnapshot -> m DiskSnapshot) -> m [DiskSnapshot]
forall a b. (a -> b) -> a -> b
$ \DiskSnapshot
snapshot -> do
      SomeHasFS m -> DiskSnapshot -> m ()
forall (m :: * -> *).
HasCallStack =>
SomeHasFS m -> DiskSnapshot -> m ()
deleteSnapshot SomeHasFS m
hasFS DiskSnapshot
snapshot
      Tracer m (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
snapshot
      DiskSnapshot -> m DiskSnapshot
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return DiskSnapshot
snapshot

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

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

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

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

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

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

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

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

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

snapshotToFileName :: DiskSnapshot -> String
snapshotToFileName :: DiskSnapshot -> String
snapshotToFileName DiskSnapshot { Word64
dsNumber :: 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

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

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

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

{-------------------------------------------------------------------------------
  Serialisation
-------------------------------------------------------------------------------}

-- | 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'.
encodeSnapshot :: (l -> Encoding) -> l -> Encoding
encodeSnapshot :: forall l. (l -> Encoding) -> l -> Encoding
encodeSnapshot 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.
decodeSnapshotBackwardsCompatible ::
     forall l blk.
     Proxy blk
  -> (forall s. Decoder s l)
  -> (forall s. Decoder s (HeaderHash blk))
  -> forall s. Decoder s l
decodeSnapshotBackwardsCompatible :: forall l blk.
Proxy blk
-> (forall s. Decoder s l)
-> (forall s. Decoder s (HeaderHash blk))
-> forall s. Decoder s l
decodeSnapshotBackwardsCompatible Proxy blk
_ forall 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
        Point blk
_ <- 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)
        Word64
_ <- Decoder s Word64
forall s. Decoder s Word64
Dec.decodeWord64
        Decoder s l
forall s. Decoder s l
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