{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# 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
  , ReadSnapshotErr (..)
  , 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, when)
import           Control.Monad.Except (ExceptT (..), throwError, withExceptT)
import           Control.Tracer
import           Data.Bits
import qualified Data.ByteString.Builder as BS
import qualified Data.ByteString.Char8 as BSC
import qualified Data.ByteString.Lazy as BSL
import           Data.Char (ord)
import           Data.Functor.Contravariant ((>$<))
import qualified Data.List as List
import           Data.Maybe (isJust, mapMaybe)
import           Data.Ord (Down (..), comparing)
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           System.FS.CRC (CRC (..), hPutAllCRC)
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 ReadSnapshotErr

    -- | 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.
  | SnapshotMissingChecksum DiskSnapshot
    -- ^ The checksum file for a snapshot was missing and was not checked
  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
  -> Flag "DoDiskSnapshotChecksum"
  -> (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
-> Flag "DoDiskSnapshotChecksum"
-> (ExtLedgerState blk -> Encoding)
-> ExtLedgerState blk
-> m (Maybe (DiskSnapshot, RealPoint blk))
takeSnapshot Tracer m (TraceSnapshotEvent blk)
tracer SomeHasFS m
hasFS Flag "DoDiskSnapshotChecksum"
doChecksum 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
-> Flag "DoDiskSnapshotChecksum"
-> (ExtLedgerState blk -> Encoding)
-> DiskSnapshot
-> ExtLedgerState blk
-> m ()
forall (m :: * -> *) blk.
MonadThrow m =>
SomeHasFS m
-> Flag "DoDiskSnapshotChecksum"
-> (ExtLedgerState blk -> Encoding)
-> DiskSnapshot
-> ExtLedgerState blk
-> m ()
writeSnapshot SomeHasFS m
hasFS Flag "DoDiskSnapshotChecksum"
doChecksum 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
Flag "DoDiskSnapshotChecksum"
TimeSinceLast DiffTime -> Word64 -> Bool
onDiskNumSnapshots :: DiskPolicy -> Word
onDiskNumSnapshots :: Word
onDiskShouldTakeSnapshot :: TimeSinceLast DiffTime -> Word64 -> Bool
onDiskShouldChecksumSnapshots :: Flag "DoDiskSnapshotChecksum"
onDiskShouldTakeSnapshot :: DiskPolicy -> TimeSinceLast DiffTime -> Word64 -> Bool
onDiskShouldChecksumSnapshots :: DiskPolicy -> Flag "DoDiskSnapshotChecksum"
..} = 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 :: * -> *).
(Monad 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
-------------------------------------------------------------------------------}

-- | 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 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, (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

-- | 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

data ReadSnapshotErr =
    -- | Error while de-serialising data
    ReadSnapshotFailed ReadIncrementalErr
    -- | Checksum of read snapshot differs from the one tracked by
    --   the corresponding '.checksum' file
  | ReadSnapshotDataCorruption
    -- | A '.checksum' file does not exist for a @'DiskSnapshot'@
  | ReadSnapshotNoChecksumFile FsPath
    -- | A '.checksum' file exists for a @'DiskSnapshot'@, but its contents is invalid
  | ReadSnapshotInvalidChecksumFile FsPath
  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)

-- | Read snapshot from disk.
--
--   Fail on data corruption, i.e. when the checksum of the read data differs
--   from the one tracked by @'DiskSnapshot'@.
readSnapshot ::
     forall m blk. IOLike m
  => SomeHasFS m
  -> (forall s. Decoder s (ExtLedgerState blk))
  -> (forall s. Decoder s (HeaderHash blk))
  -> Flag "DoDiskSnapshotChecksum"
  -> DiskSnapshot
  -> ExceptT ReadSnapshotErr m (ExtLedgerState blk)
readSnapshot :: forall (m :: * -> *) blk.
IOLike m =>
SomeHasFS m
-> (forall s. Decoder s (ExtLedgerState blk))
-> (forall s. Decoder s (HeaderHash blk))
-> Flag "DoDiskSnapshotChecksum"
-> DiskSnapshot
-> ExceptT ReadSnapshotErr m (ExtLedgerState blk)
readSnapshot SomeHasFS m
someHasFS forall s. Decoder s (ExtLedgerState blk)
decLedger forall s. Decoder s (HeaderHash blk)
decHash Flag "DoDiskSnapshotChecksum"
doChecksum DiskSnapshot
snapshotName = do
  (ExtLedgerState blk
ledgerState, Maybe CRC
mbChecksumAsRead) <- (ReadIncrementalErr -> ReadSnapshotErr)
-> ExceptT ReadIncrementalErr m (ExtLedgerState blk, Maybe CRC)
-> ExceptT ReadSnapshotErr m (ExtLedgerState blk, Maybe CRC)
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT ReadIncrementalErr -> ReadSnapshotErr
ReadSnapshotFailed (ExceptT ReadIncrementalErr m (ExtLedgerState blk, Maybe CRC)
 -> ExceptT ReadSnapshotErr m (ExtLedgerState blk, Maybe CRC))
-> (m (Either ReadIncrementalErr (ExtLedgerState blk, Maybe CRC))
    -> ExceptT ReadIncrementalErr m (ExtLedgerState blk, Maybe CRC))
-> m (Either ReadIncrementalErr (ExtLedgerState blk, Maybe CRC))
-> ExceptT ReadSnapshotErr m (ExtLedgerState blk, Maybe CRC)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m (Either ReadIncrementalErr (ExtLedgerState blk, Maybe CRC))
-> ExceptT ReadIncrementalErr m (ExtLedgerState blk, Maybe CRC)
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (m (Either ReadIncrementalErr (ExtLedgerState blk, Maybe CRC))
 -> ExceptT ReadSnapshotErr m (ExtLedgerState blk, Maybe CRC))
-> m (Either ReadIncrementalErr (ExtLedgerState blk, Maybe CRC))
-> ExceptT ReadSnapshotErr m (ExtLedgerState blk, Maybe CRC)
forall a b. (a -> b) -> a -> b
$
      SomeHasFS m
-> Bool
-> Decoder (PrimState m) (ExtLedgerState blk)
-> FsPath
-> m (Either ReadIncrementalErr (ExtLedgerState blk, Maybe CRC))
forall (m :: * -> *) a.
IOLike m =>
SomeHasFS m
-> Bool
-> Decoder (PrimState m) a
-> FsPath
-> m (Either ReadIncrementalErr (a, Maybe CRC))
readIncremental SomeHasFS m
someHasFS (Flag "DoDiskSnapshotChecksum" -> Bool
forall (name :: Symbol). Flag name -> Bool
getFlag Flag "DoDiskSnapshotChecksum"
doChecksum) Decoder (PrimState m) (ExtLedgerState blk)
forall s. Decoder s (ExtLedgerState blk)
decoder (DiskSnapshot -> FsPath
snapshotToPath DiskSnapshot
snapshotName)
  Bool
-> ExceptT ReadSnapshotErr m () -> ExceptT ReadSnapshotErr m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Flag "DoDiskSnapshotChecksum" -> Bool
forall (name :: Symbol). Flag name -> Bool
getFlag Flag "DoDiskSnapshotChecksum"
doChecksum) (ExceptT ReadSnapshotErr m () -> ExceptT ReadSnapshotErr m ())
-> ExceptT ReadSnapshotErr m () -> ExceptT ReadSnapshotErr m ()
forall a b. (a -> b) -> a -> b
$ do
    !CRC
snapshotCRC <- SomeHasFS m -> FsPath -> ExceptT ReadSnapshotErr m CRC
readCRC SomeHasFS m
someHasFS (DiskSnapshot -> FsPath
snapshotToChecksumPath DiskSnapshot
snapshotName)
    Bool
-> ExceptT ReadSnapshotErr m () -> ExceptT ReadSnapshotErr m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe CRC
mbChecksumAsRead Maybe CRC -> Maybe CRC -> Bool
forall a. Eq a => a -> a -> Bool
/= CRC -> Maybe CRC
forall a. a -> Maybe a
Just CRC
snapshotCRC) (ExceptT ReadSnapshotErr m () -> ExceptT ReadSnapshotErr m ())
-> ExceptT ReadSnapshotErr m () -> ExceptT ReadSnapshotErr m ()
forall a b. (a -> b) -> a -> b
$
      ReadSnapshotErr -> ExceptT ReadSnapshotErr m ()
forall a. ReadSnapshotErr -> ExceptT ReadSnapshotErr m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ReadSnapshotErr
ReadSnapshotDataCorruption
  ExtLedgerState blk
-> ExceptT ReadSnapshotErr m (ExtLedgerState blk)
forall a. a -> ExceptT ReadSnapshotErr m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ExtLedgerState blk
ledgerState
  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

    readCRC ::
      SomeHasFS m
      -> FsPath
      -> ExceptT ReadSnapshotErr m CRC
    readCRC :: SomeHasFS m -> FsPath -> ExceptT ReadSnapshotErr m CRC
readCRC (SomeHasFS HasFS m h
hasFS) FsPath
crcPath = m (Either ReadSnapshotErr CRC) -> ExceptT ReadSnapshotErr m CRC
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (m (Either ReadSnapshotErr CRC) -> ExceptT ReadSnapshotErr m CRC)
-> m (Either ReadSnapshotErr CRC) -> ExceptT ReadSnapshotErr m CRC
forall a b. (a -> b) -> a -> b
$ do
        Bool
crcExists <- HasFS m h -> HasCallStack => FsPath -> m Bool
forall (m :: * -> *) h.
HasFS m h -> HasCallStack => FsPath -> m Bool
doesFileExist HasFS m h
hasFS FsPath
crcPath
        if Bool -> Bool
not Bool
crcExists
          then Either ReadSnapshotErr CRC -> m (Either ReadSnapshotErr CRC)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ReadSnapshotErr -> Either ReadSnapshotErr CRC
forall a b. a -> Either a b
Left (ReadSnapshotErr -> Either ReadSnapshotErr CRC)
-> ReadSnapshotErr -> Either ReadSnapshotErr CRC
forall a b. (a -> b) -> a -> b
$ FsPath -> ReadSnapshotErr
ReadSnapshotNoChecksumFile FsPath
crcPath)
          else do
            HasFS m h
-> FsPath
-> OpenMode
-> (Handle h -> m (Either ReadSnapshotErr CRC))
-> m (Either ReadSnapshotErr 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
crcPath OpenMode
ReadMode ((Handle h -> m (Either ReadSnapshotErr CRC))
 -> m (Either ReadSnapshotErr CRC))
-> (Handle h -> m (Either ReadSnapshotErr CRC))
-> m (Either ReadSnapshotErr CRC)
forall a b. (a -> b) -> a -> b
$ \Handle h
h -> do
              ByteString
str <- ByteString -> ByteString
BSL.toStrict (ByteString -> ByteString) -> m ByteString -> m ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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
              if Bool -> Bool
not (ByteString -> Int
BSC.length ByteString
str Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
8 Bool -> Bool -> Bool
&& (Char -> Bool) -> ByteString -> Bool
BSC.all Char -> Bool
isHexDigit ByteString
str)
                then Either ReadSnapshotErr CRC -> m (Either ReadSnapshotErr CRC)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ReadSnapshotErr -> Either ReadSnapshotErr CRC
forall a b. a -> Either a b
Left (ReadSnapshotErr -> Either ReadSnapshotErr CRC)
-> ReadSnapshotErr -> Either ReadSnapshotErr CRC
forall a b. (a -> b) -> a -> b
$ FsPath -> ReadSnapshotErr
ReadSnapshotInvalidChecksumFile FsPath
crcPath)
                else Either ReadSnapshotErr CRC -> m (Either ReadSnapshotErr CRC)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ReadSnapshotErr CRC -> m (Either ReadSnapshotErr CRC))
-> (Word32 -> Either ReadSnapshotErr CRC)
-> Word32
-> m (Either ReadSnapshotErr CRC)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CRC -> Either ReadSnapshotErr CRC
forall a b. b -> Either a b
Right (CRC -> Either ReadSnapshotErr CRC)
-> (Word32 -> CRC) -> Word32 -> Either ReadSnapshotErr CRC
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> CRC
CRC (Word32 -> m (Either ReadSnapshotErr CRC))
-> Word32 -> m (Either ReadSnapshotErr CRC)
forall a b. (a -> b) -> a -> b
$ Word -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Word
hexdigitsToInt ByteString
str)
        -- TODO: remove the functions in the where clause when we start depending on lsm-tree
      where
        isHexDigit :: Char -> Bool
        isHexDigit :: Char -> Bool
isHexDigit Char
c = (Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'0' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'9')
                    Bool -> Bool -> Bool
|| (Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'a' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'f') --lower case only

        -- Precondition: BSC.all isHexDigit
        hexdigitsToInt :: BSC.ByteString -> Word
        hexdigitsToInt :: ByteString -> Word
hexdigitsToInt =
            (Word -> Char -> Word) -> Word -> ByteString -> Word
forall a. (a -> Char -> a) -> a -> ByteString -> a
BSC.foldl' Word -> Char -> Word
accumdigit Word
0
          where
            accumdigit :: Word -> Char -> Word
            accumdigit :: Word -> Char -> Word
accumdigit !Word
a !Char
c =
              (Word
a Word -> Int -> Word
forall a. Bits a => a -> Int -> a
`shiftL` Int
4) Word -> Word -> Word
forall a. Bits a => a -> a -> a
.|. Char -> Word
hexdigitToWord Char
c


        -- Precondition: isHexDigit
        hexdigitToWord :: Char -> Word
        hexdigitToWord :: Char -> Word
hexdigitToWord Char
c
          | let !dec :: Word
dec = Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Char -> Int
ord Char
c Int -> Int -> Int
forall a. Num a => a -> a -> a
- Char -> Int
ord Char
'0')
          , Word
dec Word -> Word -> Bool
forall a. Ord a => a -> a -> Bool
<= Word
9  = Word
dec

          | let !hex :: Word
hex = Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Char -> Int
ord Char
c Int -> Int -> Int
forall a. Num a => a -> a -> a
- Char -> Int
ord Char
'a' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
10)
          , Bool
otherwise = Word
hex

-- | Write a ledger state snapshot to disk
--
--   This function writes two files:
--   * the snapshot file itself, with the name generated by @'snapshotToPath'@
--   * the checksum file, with the name generated by @'snapshotToChecksumPath'@
writeSnapshot ::
     forall m blk. MonadThrow m
  => SomeHasFS m
  -> Flag "DoDiskSnapshotChecksum"
  -> (ExtLedgerState blk -> Encoding)
  -> DiskSnapshot
  -> ExtLedgerState blk -> m ()
writeSnapshot :: forall (m :: * -> *) blk.
MonadThrow m =>
SomeHasFS m
-> Flag "DoDiskSnapshotChecksum"
-> (ExtLedgerState blk -> Encoding)
-> DiskSnapshot
-> ExtLedgerState blk
-> m ()
writeSnapshot (SomeHasFS HasFS m h
hasFS) Flag "DoDiskSnapshotChecksum"
doChecksum ExtLedgerState blk -> Encoding
encLedger DiskSnapshot
ss ExtLedgerState blk
cs = do
    CRC
crc <- 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 (DiskSnapshot -> FsPath
snapshotToPath DiskSnapshot
ss) (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 -> Encoding
encode ExtLedgerState blk
cs)
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Flag "DoDiskSnapshotChecksum" -> Bool
forall (name :: Symbol). Flag name -> Bool
getFlag Flag "DoDiskSnapshotChecksum"
doChecksum) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
      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
snapshotToChecksumPath 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 -> 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)
-> (Word32 -> ByteString) -> Word32 -> m Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> ByteString
BS.toLazyByteString (Builder -> ByteString)
-> (Word32 -> Builder) -> Word32 -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> Builder
BS.word32HexFixed (Word32 -> m Word64) -> Word32 -> m Word64
forall a b. (a -> b) -> a -> b
$ CRC -> Word32
getCRC CRC
crc
  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 :: Monad m => HasCallStack => SomeHasFS m -> DiskSnapshot -> m ()
deleteSnapshot :: forall (m :: * -> *).
(Monad m, HasCallStack) =>
SomeHasFS m -> DiskSnapshot -> m ()
deleteSnapshot (SomeHasFS HasFS m h
hasFS) DiskSnapshot
snapshot = do
  HasFS m h -> HasCallStack => FsPath -> m ()
forall (m :: * -> *) h. HasFS m h -> HasCallStack => FsPath -> m ()
removeFile HasFS m h
hasFS (DiskSnapshot -> FsPath
snapshotToPath DiskSnapshot
snapshot)
  Bool
checksumFileExists <- HasFS m h -> HasCallStack => FsPath -> m Bool
forall (m :: * -> *) h.
HasFS m h -> HasCallStack => FsPath -> m Bool
doesFileExist HasFS m h
hasFS (DiskSnapshot -> FsPath
snapshotToChecksumPath DiskSnapshot
snapshot)
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
checksumFileExists (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
    HasFS m h -> HasCallStack => FsPath -> m ()
forall (m :: * -> *) h. HasFS m h -> HasCallStack => FsPath -> m ()
removeFile HasFS m h
hasFS (DiskSnapshot -> FsPath
snapshotToChecksumPath DiskSnapshot
snapshot)

-- | 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
doesFileExist :: forall (m :: * -> *) h.
HasFS m h -> HasCallStack => FsPath -> m Bool
removeFile :: forall (m :: * -> *) h. HasFS m h -> HasCallStack => FsPath -> m ()
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
removeDirectoryRecursive :: 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
..}) =
    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 DiskSnapshot)
-> [DiskSnapshot] -> [DiskSnapshot]
forall b a. Ord b => (a -> b) -> [a] -> [a]
List.sortOn DiskSnapshot -> Down DiskSnapshot
forall a. a -> Down a
Down ([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

snapshotToChecksumFileName :: DiskSnapshot -> String
snapshotToChecksumFileName :: DiskSnapshot -> String
snapshotToChecksumFileName = (String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
".checksum") ShowS -> (DiskSnapshot -> String) -> DiskSnapshot -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DiskSnapshot -> String
snapshotToFileName

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

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 -> [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
snapshotToChecksumFileName

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