{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE EmptyDataDeriving #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}

module Ouroboros.Consensus.Storage.LedgerDB.V2.InMemory
  ( -- * LedgerTablesHandle
    newInMemoryLedgerTablesHandle

    -- * Snapshots
  , loadSnapshot
  , snapshotToStatePath
  , snapshotToTablePath
  , takeSnapshot
  ) where

import Cardano.Binary as CBOR
import qualified Codec.CBOR.Write as CBOR
import Codec.Serialise (decode)
import qualified Control.Monad as Monad
import Control.Monad.Trans (lift)
import Control.Monad.Trans.Except
import Control.ResourceRegistry
import Control.Tracer
import Data.Functor.Contravariant ((>$<))
import Data.Functor.Identity
import qualified Data.List as List
import qualified Data.Map.Strict as Map
import Data.Maybe
import Data.String (fromString)
import GHC.Generics
import NoThunks.Class
import Ouroboros.Consensus.Block
import Ouroboros.Consensus.Ledger.Abstract
import Ouroboros.Consensus.Ledger.Extended
import Ouroboros.Consensus.Ledger.SupportsProtocol
import qualified Ouroboros.Consensus.Ledger.Tables.Diff as Diff
import Ouroboros.Consensus.Storage.LedgerDB.API
import Ouroboros.Consensus.Storage.LedgerDB.Snapshots
import Ouroboros.Consensus.Storage.LedgerDB.V2.LedgerSeq
import Ouroboros.Consensus.Util.CBOR (readIncremental)
import Ouroboros.Consensus.Util.CRC
import Ouroboros.Consensus.Util.Enclose
import Ouroboros.Consensus.Util.IOLike
import System.FS.API
import System.FS.CRC
import Prelude hiding (read)

{-------------------------------------------------------------------------------
  InMemory implementation of LedgerTablesHandles
-------------------------------------------------------------------------------}

data LedgerTablesHandleState l
  = LedgerTablesHandleOpen !(LedgerTables l ValuesMK)
  | LedgerTablesHandleClosed
  deriving (forall x.
 LedgerTablesHandleState l -> Rep (LedgerTablesHandleState l) x)
-> (forall x.
    Rep (LedgerTablesHandleState l) x -> LedgerTablesHandleState l)
-> Generic (LedgerTablesHandleState l)
forall x.
Rep (LedgerTablesHandleState l) x -> LedgerTablesHandleState l
forall x.
LedgerTablesHandleState l -> Rep (LedgerTablesHandleState l) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (l :: LedgerStateKind) x.
Rep (LedgerTablesHandleState l) x -> LedgerTablesHandleState l
forall (l :: LedgerStateKind) x.
LedgerTablesHandleState l -> Rep (LedgerTablesHandleState l) x
$cfrom :: forall (l :: LedgerStateKind) x.
LedgerTablesHandleState l -> Rep (LedgerTablesHandleState l) x
from :: forall x.
LedgerTablesHandleState l -> Rep (LedgerTablesHandleState l) x
$cto :: forall (l :: LedgerStateKind) x.
Rep (LedgerTablesHandleState l) x -> LedgerTablesHandleState l
to :: forall x.
Rep (LedgerTablesHandleState l) x -> LedgerTablesHandleState l
Generic

deriving instance NoThunks (LedgerTables l ValuesMK) => NoThunks (LedgerTablesHandleState l)

data InMemoryClosedExn = InMemoryClosedExn
  deriving (Int -> InMemoryClosedExn -> ShowS
[InMemoryClosedExn] -> ShowS
InMemoryClosedExn -> String
(Int -> InMemoryClosedExn -> ShowS)
-> (InMemoryClosedExn -> String)
-> ([InMemoryClosedExn] -> ShowS)
-> Show InMemoryClosedExn
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> InMemoryClosedExn -> ShowS
showsPrec :: Int -> InMemoryClosedExn -> ShowS
$cshow :: InMemoryClosedExn -> String
show :: InMemoryClosedExn -> String
$cshowList :: [InMemoryClosedExn] -> ShowS
showList :: [InMemoryClosedExn] -> ShowS
Show, Show InMemoryClosedExn
Typeable InMemoryClosedExn
(Typeable InMemoryClosedExn, Show InMemoryClosedExn) =>
(InMemoryClosedExn -> SomeException)
-> (SomeException -> Maybe InMemoryClosedExn)
-> (InMemoryClosedExn -> String)
-> (InMemoryClosedExn -> Bool)
-> Exception InMemoryClosedExn
SomeException -> Maybe InMemoryClosedExn
InMemoryClosedExn -> Bool
InMemoryClosedExn -> String
InMemoryClosedExn -> SomeException
forall e.
(Typeable e, Show e) =>
(e -> SomeException)
-> (SomeException -> Maybe e)
-> (e -> String)
-> (e -> Bool)
-> Exception e
$ctoException :: InMemoryClosedExn -> SomeException
toException :: InMemoryClosedExn -> SomeException
$cfromException :: SomeException -> Maybe InMemoryClosedExn
fromException :: SomeException -> Maybe InMemoryClosedExn
$cdisplayException :: InMemoryClosedExn -> String
displayException :: InMemoryClosedExn -> String
$cbacktraceDesired :: InMemoryClosedExn -> Bool
backtraceDesired :: InMemoryClosedExn -> Bool
Exception)

guardClosed :: LedgerTablesHandleState l -> (LedgerTables l ValuesMK -> a) -> a
guardClosed :: forall (l :: LedgerStateKind) a.
LedgerTablesHandleState l -> (LedgerTables l ValuesMK -> a) -> a
guardClosed LedgerTablesHandleState l
LedgerTablesHandleClosed LedgerTables l ValuesMK -> a
_ = String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ InMemoryClosedExn -> String
forall a. Show a => a -> String
show InMemoryClosedExn
InMemoryClosedExn
guardClosed (LedgerTablesHandleOpen LedgerTables l ValuesMK
st) LedgerTables l ValuesMK -> a
f = LedgerTables l ValuesMK -> a
f LedgerTables l ValuesMK
st

newInMemoryLedgerTablesHandle ::
  forall m l.
  ( IOLike m
  , HasLedgerTables l
  , CanUpgradeLedgerTables l
  , SerializeTablesWithHint l
  ) =>
  SomeHasFS m ->
  LedgerTables l ValuesMK ->
  m (LedgerTablesHandle m l)
newInMemoryLedgerTablesHandle :: forall (m :: * -> *) (l :: LedgerStateKind).
(IOLike m, HasLedgerTables l, CanUpgradeLedgerTables l,
 SerializeTablesWithHint l) =>
SomeHasFS m
-> LedgerTables l ValuesMK -> m (LedgerTablesHandle m l)
newInMemoryLedgerTablesHandle someFS :: SomeHasFS m
someFS@(SomeHasFS HasFS m h
hasFS) LedgerTables l ValuesMK
l = do
  !tv <- LedgerTablesHandleState l
-> m (StrictTVar m (LedgerTablesHandleState l))
forall (m :: * -> *) a.
(HasCallStack, MonadSTM m, NoThunks a) =>
a -> m (StrictTVar m a)
newTVarIO (LedgerTables l ValuesMK -> LedgerTablesHandleState l
forall (l :: LedgerStateKind).
LedgerTables l ValuesMK -> LedgerTablesHandleState l
LedgerTablesHandleOpen LedgerTables l ValuesMK
l)
  pure
    LedgerTablesHandle
      { close =
          atomically $ writeTVar tv LedgerTablesHandleClosed
      , duplicate = do
          hs <- readTVarIO tv
          !x <- guardClosed hs $ newInMemoryLedgerTablesHandle someFS
          pure x
      , read = \LedgerTables l KeysMK
keys -> do
          hs <- StrictTVar m (LedgerTablesHandleState l)
-> m (LedgerTablesHandleState l)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> m a
readTVarIO StrictTVar m (LedgerTablesHandleState l)
tv
          guardClosed
            hs
            (pure . flip (ltliftA2 (\(ValuesMK Map k v
v) (KeysMK Set k
k) -> Map k v -> ValuesMK k v
forall k v. Map k v -> ValuesMK k v
ValuesMK (Map k v -> ValuesMK k v) -> Map k v -> ValuesMK k v
forall a b. (a -> b) -> a -> b
$ Map k v
v Map k v -> Set k -> Map k v
forall k a. Ord k => Map k a -> Set k -> Map k a
`Map.restrictKeys` Set k
k)) keys)
      , readRange = \(Maybe (TxIn l)
f, Int
t) -> do
          hs <- StrictTVar m (LedgerTablesHandleState l)
-> m (LedgerTablesHandleState l)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> m a
readTVarIO StrictTVar m (LedgerTablesHandleState l)
tv
          guardClosed
            hs
            ( \(LedgerTables (ValuesMK Map (TxIn l) (TxOut l)
m)) ->
                LedgerTables l ValuesMK -> m (LedgerTables l ValuesMK)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LedgerTables l ValuesMK -> m (LedgerTables l ValuesMK))
-> (Map (TxIn l) (TxOut l) -> LedgerTables l ValuesMK)
-> Map (TxIn l) (TxOut l)
-> m (LedgerTables l ValuesMK)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ValuesMK (TxIn l) (TxOut l) -> LedgerTables l ValuesMK
forall (l :: LedgerStateKind) (mk :: * -> * -> *).
mk (TxIn l) (TxOut l) -> LedgerTables l mk
LedgerTables (ValuesMK (TxIn l) (TxOut l) -> LedgerTables l ValuesMK)
-> (Map (TxIn l) (TxOut l) -> ValuesMK (TxIn l) (TxOut l))
-> Map (TxIn l) (TxOut l)
-> LedgerTables l ValuesMK
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map (TxIn l) (TxOut l) -> ValuesMK (TxIn l) (TxOut l)
forall k v. Map k v -> ValuesMK k v
ValuesMK (Map (TxIn l) (TxOut l) -> ValuesMK (TxIn l) (TxOut l))
-> (Map (TxIn l) (TxOut l) -> Map (TxIn l) (TxOut l))
-> Map (TxIn l) (TxOut l)
-> ValuesMK (TxIn l) (TxOut l)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Map (TxIn l) (TxOut l) -> Map (TxIn l) (TxOut l)
forall k a. Int -> Map k a -> Map k a
Map.take Int
t (Map (TxIn l) (TxOut l) -> Map (TxIn l) (TxOut l))
-> (Map (TxIn l) (TxOut l) -> Map (TxIn l) (TxOut l))
-> Map (TxIn l) (TxOut l)
-> Map (TxIn l) (TxOut l)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Map (TxIn l) (TxOut l) -> Map (TxIn l) (TxOut l))
-> (TxIn l -> Map (TxIn l) (TxOut l) -> Map (TxIn l) (TxOut l))
-> Maybe (TxIn l)
-> Map (TxIn l) (TxOut l)
-> Map (TxIn l) (TxOut l)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Map (TxIn l) (TxOut l) -> Map (TxIn l) (TxOut l)
forall a. a -> a
id (\TxIn l
g -> (Map (TxIn l) (TxOut l), Map (TxIn l) (TxOut l))
-> Map (TxIn l) (TxOut l)
forall a b. (a, b) -> b
snd ((Map (TxIn l) (TxOut l), Map (TxIn l) (TxOut l))
 -> Map (TxIn l) (TxOut l))
-> (Map (TxIn l) (TxOut l)
    -> (Map (TxIn l) (TxOut l), Map (TxIn l) (TxOut l)))
-> Map (TxIn l) (TxOut l)
-> Map (TxIn l) (TxOut l)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxIn l
-> Map (TxIn l) (TxOut l)
-> (Map (TxIn l) (TxOut l), Map (TxIn l) (TxOut l))
forall k a. Ord k => k -> Map k a -> (Map k a, Map k a)
Map.split TxIn l
g) Maybe (TxIn l)
f) (Map (TxIn l) (TxOut l) -> m (LedgerTables l ValuesMK))
-> Map (TxIn l) (TxOut l) -> m (LedgerTables l ValuesMK)
forall a b. (a -> b) -> a -> b
$ Map (TxIn l) (TxOut l)
m
            )
      , readAll = do
          hs <- readTVarIO tv
          guardClosed hs pure
      , pushDiffs = \l mk
st0 !l DiffMK
diffs ->
          STM m () -> m ()
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m () -> m ()) -> STM m () -> m ()
forall a b. (a -> b) -> a -> b
$
            StrictTVar m (LedgerTablesHandleState l)
-> (LedgerTablesHandleState l -> LedgerTablesHandleState l)
-> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> (a -> a) -> STM m ()
modifyTVar
              StrictTVar m (LedgerTablesHandleState l)
tv
              ( \LedgerTablesHandleState l
r ->
                  LedgerTablesHandleState l
-> (LedgerTables l ValuesMK -> LedgerTablesHandleState l)
-> LedgerTablesHandleState l
forall (l :: LedgerStateKind) a.
LedgerTablesHandleState l -> (LedgerTables l ValuesMK -> a) -> a
guardClosed
                    LedgerTablesHandleState l
r
                    ( LedgerTables l ValuesMK -> LedgerTablesHandleState l
forall (l :: LedgerStateKind).
LedgerTables l ValuesMK -> LedgerTablesHandleState l
LedgerTablesHandleOpen
                        (LedgerTables l ValuesMK -> LedgerTablesHandleState l)
-> (LedgerTables l ValuesMK -> LedgerTables l ValuesMK)
-> LedgerTables l ValuesMK
-> LedgerTablesHandleState l
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LedgerTables l ValuesMK
 -> LedgerTables l DiffMK -> LedgerTables l ValuesMK)
-> LedgerTables l DiffMK
-> LedgerTables l ValuesMK
-> LedgerTables l ValuesMK
forall a b c. (a -> b -> c) -> b -> a -> c
flip
                          ((forall k v.
 LedgerTableConstraints' l k v =>
 ValuesMK k v -> DiffMK k v -> ValuesMK k v)
-> LedgerTables l ValuesMK
-> LedgerTables l DiffMK
-> LedgerTables l ValuesMK
forall (l :: LedgerStateKind) (mk1 :: * -> * -> *)
       (mk2 :: * -> * -> *) (mk3 :: * -> * -> *).
LedgerTableConstraints l =>
(forall k v.
 LedgerTableConstraints' l k v =>
 mk1 k v -> mk2 k v -> mk3 k v)
-> LedgerTables l mk1 -> LedgerTables l mk2 -> LedgerTables l mk3
ltliftA2 (\(ValuesMK Map k v
vals) (DiffMK Diff k v
d) -> Map k v -> ValuesMK k v
forall k v. Map k v -> ValuesMK k v
ValuesMK (Map k v -> Diff k v -> Map k v
forall k v. Ord k => Map k v -> Diff k v -> Map k v
Diff.applyDiff Map k v
vals Diff k v
d)))
                          (l DiffMK -> LedgerTables l DiffMK
forall (mk :: * -> * -> *).
(CanMapMK mk, CanMapKeysMK mk, ZeroableMK mk) =>
l mk -> LedgerTables l mk
forall (l :: LedgerStateKind) (mk :: * -> * -> *).
(HasLedgerTables l, CanMapMK mk, CanMapKeysMK mk, ZeroableMK mk) =>
l mk -> LedgerTables l mk
projectLedgerTables l DiffMK
diffs)
                        (LedgerTables l ValuesMK -> LedgerTables l ValuesMK)
-> (LedgerTables l ValuesMK -> LedgerTables l ValuesMK)
-> LedgerTables l ValuesMK
-> LedgerTables l ValuesMK
forall b c a. (b -> c) -> (a -> b) -> a -> c
. l mk
-> l DiffMK -> LedgerTables l ValuesMK -> LedgerTables l ValuesMK
forall (mk1 :: * -> * -> *) (mk2 :: * -> * -> *).
l mk1
-> l mk2 -> LedgerTables l ValuesMK -> LedgerTables l ValuesMK
forall (l :: LedgerStateKind) (mk1 :: * -> * -> *)
       (mk2 :: * -> * -> *).
CanUpgradeLedgerTables l =>
l mk1
-> l mk2 -> LedgerTables l ValuesMK -> LedgerTables l ValuesMK
upgradeTables l mk
st0 l DiffMK
diffs
                    )
              )
      , takeHandleSnapshot = \l EmptyMK
hint String
snapshotName -> do
          HasFS m h -> HasCallStack => Bool -> FsPath -> m ()
forall (m :: * -> *) h.
HasFS m h -> HasCallStack => Bool -> FsPath -> m ()
createDirectoryIfMissing HasFS m h
hasFS Bool
True (FsPath -> m ()) -> FsPath -> m ()
forall a b. (a -> b) -> a -> b
$ Context -> FsPath
mkFsPath [String
snapshotName, String
"tables"]
          h <- StrictTVar m (LedgerTablesHandleState l)
-> m (LedgerTablesHandleState l)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> m a
readTVarIO StrictTVar m (LedgerTablesHandleState l)
tv
          guardClosed h $
            \LedgerTables l ValuesMK
values ->
              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 (Context -> FsPath
mkFsPath [String
snapshotName, String
"tables", String
"tvar"]) (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
hf ->
                ((Word64, CRC) -> CRC) -> m (Word64, CRC) -> m CRC
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Word64, CRC) -> CRC
forall a b. (a, b) -> b
snd (m (Word64, CRC) -> m CRC) -> m (Word64, CRC) -> m CRC
forall a b. (a -> b) -> a -> 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
hf (ByteString -> m (Word64, CRC)) -> ByteString -> m (Word64, CRC)
forall a b. (a -> b) -> a -> b
$
                    Encoding -> ByteString
CBOR.toLazyByteString (Encoding -> ByteString) -> Encoding -> ByteString
forall a b. (a -> b) -> a -> b
$
                      l EmptyMK -> LedgerTables l ValuesMK -> Encoding
forall (l :: LedgerStateKind).
SerializeTablesWithHint l =>
l EmptyMK -> LedgerTables l ValuesMK -> Encoding
valuesMKEncoder l EmptyMK
hint LedgerTables l ValuesMK
values
      , tablesSize = do
          hs <- readTVarIO tv
          guardClosed hs (pure . Just . Map.size . getValuesMK . getLedgerTables)
      }

{-------------------------------------------------------------------------------
  Snapshots
-------------------------------------------------------------------------------}

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

snapshotToTablePath :: DiskSnapshot -> FsPath
snapshotToTablePath :: DiskSnapshot -> FsPath
snapshotToTablePath = Context -> FsPath
mkFsPath (Context -> FsPath)
-> (DiskSnapshot -> Context) -> DiskSnapshot -> FsPath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\String
x -> [String
x, String
"tables", String
"tvar"]) (String -> Context)
-> (DiskSnapshot -> String) -> DiskSnapshot -> Context
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DiskSnapshot -> String
snapshotToDirName

writeSnapshot ::
  MonadThrow m =>
  SomeHasFS m ->
  (ExtLedgerState blk EmptyMK -> Encoding) ->
  DiskSnapshot ->
  StateRef m (ExtLedgerState blk) ->
  m ()
writeSnapshot :: forall (m :: * -> *) blk.
MonadThrow m =>
SomeHasFS m
-> (ExtLedgerState blk EmptyMK -> Encoding)
-> DiskSnapshot
-> StateRef m (ExtLedgerState blk)
-> m ()
writeSnapshot fs :: SomeHasFS m
fs@(SomeHasFS HasFS m h
hasFs) ExtLedgerState blk EmptyMK -> Encoding
encLedger DiskSnapshot
ds StateRef m (ExtLedgerState blk)
st = do
  HasFS m h -> HasCallStack => Bool -> FsPath -> m ()
forall (m :: * -> *) h.
HasFS m h -> HasCallStack => Bool -> FsPath -> m ()
createDirectoryIfMissing HasFS m h
hasFs Bool
True (FsPath -> m ()) -> FsPath -> m ()
forall a b. (a -> b) -> a -> b
$ DiskSnapshot -> FsPath
snapshotToDirPath DiskSnapshot
ds
  crc1 <- SomeHasFS m
-> (ExtLedgerState blk EmptyMK -> Encoding)
-> FsPath
-> ExtLedgerState blk EmptyMK
-> m CRC
forall (m :: * -> *) blk.
MonadThrow m =>
SomeHasFS m
-> (ExtLedgerState blk EmptyMK -> Encoding)
-> FsPath
-> ExtLedgerState blk EmptyMK
-> m CRC
writeExtLedgerState SomeHasFS m
fs ExtLedgerState blk EmptyMK -> Encoding
encLedger (DiskSnapshot -> FsPath
snapshotToStatePath DiskSnapshot
ds) (ExtLedgerState blk EmptyMK -> m CRC)
-> ExtLedgerState blk EmptyMK -> m CRC
forall a b. (a -> b) -> a -> b
$ StateRef m (ExtLedgerState blk) -> ExtLedgerState blk EmptyMK
forall (m :: * -> *) (l :: LedgerStateKind).
StateRef m l -> l EmptyMK
state StateRef m (ExtLedgerState blk)
st
  crc2 <- takeHandleSnapshot (tables st) (state st) $ snapshotToDirName ds
  writeSnapshotMetadata fs ds $
    SnapshotMetadata
      { snapshotBackend = UTxOHDMemSnapshot
      , snapshotChecksum = crcOfConcat crc1 crc2
      }

takeSnapshot ::
  ( IOLike m
  , LedgerDbSerialiseConstraints blk
  , LedgerSupportsProtocol blk
  ) =>
  CodecConfig blk ->
  Tracer m (TraceSnapshotEvent blk) ->
  SomeHasFS m ->
  Maybe String ->
  StateRef m (ExtLedgerState blk) ->
  m (Maybe (DiskSnapshot, RealPoint blk))
takeSnapshot :: forall (m :: * -> *) blk.
(IOLike m, LedgerDbSerialiseConstraints blk,
 LedgerSupportsProtocol blk) =>
CodecConfig blk
-> Tracer m (TraceSnapshotEvent blk)
-> SomeHasFS m
-> Maybe String
-> StateRef m (ExtLedgerState blk)
-> m (Maybe (DiskSnapshot, RealPoint blk))
takeSnapshot CodecConfig blk
ccfg Tracer m (TraceSnapshotEvent blk)
tracer SomeHasFS m
hasFS Maybe String
suffix StateRef m (ExtLedgerState blk)
st = do
  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 EmptyMK -> Point (ExtLedgerState blk)
forall (mk :: * -> * -> *).
ExtLedgerState blk mk -> Point (ExtLedgerState blk)
forall (l :: LedgerStateKind) (mk :: * -> * -> *).
GetTip l =>
l mk -> Point l
getTip (ExtLedgerState blk EmptyMK -> Point (ExtLedgerState blk))
-> ExtLedgerState blk EmptyMK -> Point (ExtLedgerState blk)
forall a b. (a -> b) -> a -> b
$ StateRef m (ExtLedgerState blk) -> ExtLedgerState blk EmptyMK
forall (m :: * -> *) (l :: LedgerStateKind).
StateRef m l -> l EmptyMK
state StateRef m (ExtLedgerState blk)
st)) 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
t -> do
      let number :: Word64
number = SlotNo -> Word64
unSlotNo (RealPoint blk -> SlotNo
forall blk. RealPoint blk -> SlotNo
realPointSlot RealPoint blk
t)
          snapshot :: DiskSnapshot
snapshot = Word64 -> Maybe String -> DiskSnapshot
DiskSnapshot Word64
number Maybe String
suffix
      diskSnapshots <- SomeHasFS m -> m [DiskSnapshot]
forall (m :: * -> *). Monad m => SomeHasFS m -> m [DiskSnapshot]
listSnapshots SomeHasFS m
hasFS
      if List.any (== DiskSnapshot number suffix) diskSnapshots
        then
          return Nothing
        else do
          encloseTimedWith (TookSnapshot snapshot t >$< tracer) $
            writeSnapshot hasFS (encodeDiskExtLedgerState ccfg) snapshot st
          return $ Just (snapshot, t)

-- | Read snapshot from disk.
--
--   Fail on data corruption, i.e. when the checksum of the read data differs
--   from the one tracked by @'DiskSnapshot'@.
loadSnapshot ::
  forall blk m.
  ( LedgerDbSerialiseConstraints blk
  , LedgerSupportsProtocol blk
  , IOLike m
  , LedgerSupportsInMemoryLedgerDB blk
  ) =>
  ResourceRegistry m ->
  CodecConfig blk ->
  SomeHasFS m ->
  DiskSnapshot ->
  ExceptT (SnapshotFailure blk) m (LedgerSeq' m blk, RealPoint blk)
loadSnapshot :: forall blk (m :: * -> *).
(LedgerDbSerialiseConstraints blk, LedgerSupportsProtocol blk,
 IOLike m, LedgerSupportsInMemoryLedgerDB blk) =>
ResourceRegistry m
-> CodecConfig blk
-> SomeHasFS m
-> DiskSnapshot
-> ExceptT
     (SnapshotFailure blk) m (LedgerSeq' m blk, RealPoint blk)
loadSnapshot ResourceRegistry m
_rr CodecConfig blk
ccfg SomeHasFS m
fs DiskSnapshot
ds = do
  snapshotMeta <-
    (MetadataErr -> SnapshotFailure blk)
-> ExceptT MetadataErr m SnapshotMetadata
-> ExceptT (SnapshotFailure blk) m SnapshotMetadata
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT (ReadSnapshotErr -> SnapshotFailure blk
forall blk. ReadSnapshotErr -> SnapshotFailure blk
InitFailureRead (ReadSnapshotErr -> SnapshotFailure blk)
-> (MetadataErr -> ReadSnapshotErr)
-> MetadataErr
-> SnapshotFailure blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FsPath -> MetadataErr -> ReadSnapshotErr
ReadMetadataError (DiskSnapshot -> FsPath
snapshotToMetadataPath DiskSnapshot
ds)) (ExceptT MetadataErr m SnapshotMetadata
 -> ExceptT (SnapshotFailure blk) m SnapshotMetadata)
-> ExceptT MetadataErr m SnapshotMetadata
-> ExceptT (SnapshotFailure blk) m SnapshotMetadata
forall a b. (a -> b) -> a -> b
$
      SomeHasFS m
-> DiskSnapshot -> ExceptT MetadataErr m SnapshotMetadata
forall (m :: * -> *).
IOLike m =>
SomeHasFS m
-> DiskSnapshot -> ExceptT MetadataErr m SnapshotMetadata
loadSnapshotMetadata SomeHasFS m
fs DiskSnapshot
ds
  Monad.when (snapshotBackend snapshotMeta /= UTxOHDMemSnapshot) $ do
    throwE $ InitFailureRead $ ReadMetadataError (snapshotToMetadataPath ds) MetadataBackendMismatch
  (extLedgerSt, checksumAsRead) <-
    withExceptT
      (InitFailureRead . ReadSnapshotFailed)
      $ readExtLedgerState fs (decodeDiskExtLedgerState ccfg) decode (snapshotToStatePath ds)
  case pointToWithOriginRealPoint (castPoint (getTip extLedgerSt)) of
    WithOrigin (RealPoint blk)
Origin -> SnapshotFailure blk
-> ExceptT
     (SnapshotFailure blk) m (LedgerSeq' m blk, RealPoint blk)
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE SnapshotFailure blk
forall blk. SnapshotFailure blk
InitFailureGenesis
    NotOrigin RealPoint blk
pt -> do
      (values, Identity crcTables) <-
        (ReadIncrementalErr -> SnapshotFailure blk)
-> ExceptT
     ReadIncrementalErr
     m
     (LedgerTables (ExtLedgerState blk) ValuesMK, Identity CRC)
-> ExceptT
     (SnapshotFailure blk)
     m
     (LedgerTables (ExtLedgerState blk) ValuesMK, Identity CRC)
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT (ReadSnapshotErr -> SnapshotFailure blk
forall blk. ReadSnapshotErr -> SnapshotFailure blk
InitFailureRead (ReadSnapshotErr -> SnapshotFailure blk)
-> (ReadIncrementalErr -> ReadSnapshotErr)
-> ReadIncrementalErr
-> SnapshotFailure blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReadIncrementalErr -> ReadSnapshotErr
ReadSnapshotFailed) (ExceptT
   ReadIncrementalErr
   m
   (LedgerTables (ExtLedgerState blk) ValuesMK, Identity CRC)
 -> ExceptT
      (SnapshotFailure blk)
      m
      (LedgerTables (ExtLedgerState blk) ValuesMK, Identity CRC))
-> ExceptT
     ReadIncrementalErr
     m
     (LedgerTables (ExtLedgerState blk) ValuesMK, Identity CRC)
-> ExceptT
     (SnapshotFailure blk)
     m
     (LedgerTables (ExtLedgerState blk) ValuesMK, Identity CRC)
forall a b. (a -> b) -> a -> b
$
          m (Either
     ReadIncrementalErr
     (LedgerTables (ExtLedgerState blk) ValuesMK, Identity CRC))
-> ExceptT
     ReadIncrementalErr
     m
     (LedgerTables (ExtLedgerState blk) ValuesMK, Identity CRC)
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (m (Either
      ReadIncrementalErr
      (LedgerTables (ExtLedgerState blk) ValuesMK, Identity CRC))
 -> ExceptT
      ReadIncrementalErr
      m
      (LedgerTables (ExtLedgerState blk) ValuesMK, Identity CRC))
-> m (Either
        ReadIncrementalErr
        (LedgerTables (ExtLedgerState blk) ValuesMK, Identity CRC))
-> ExceptT
     ReadIncrementalErr
     m
     (LedgerTables (ExtLedgerState blk) ValuesMK, Identity CRC)
forall a b. (a -> b) -> a -> b
$
            SomeHasFS m
-> (CRC -> Identity CRC)
-> Decoder
     (PrimState m) (LedgerTables (ExtLedgerState blk) ValuesMK)
-> FsPath
-> m (Either
        ReadIncrementalErr
        (LedgerTables (ExtLedgerState blk) ValuesMK, 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
fs
              CRC -> Identity CRC
forall a. a -> Identity a
Identity
              (ExtLedgerState blk EmptyMK
-> Decoder
     (PrimState m) (LedgerTables (ExtLedgerState blk) ValuesMK)
forall (l :: LedgerStateKind) s.
SerializeTablesWithHint l =>
l EmptyMK -> Decoder s (LedgerTables l ValuesMK)
valuesMKDecoder ExtLedgerState blk EmptyMK
extLedgerSt)
              ( [Text] -> FsPath
fsPathFromList ([Text] -> FsPath) -> [Text] -> FsPath
forall a b. (a -> b) -> a -> b
$
                  FsPath -> [Text]
fsPathToList (DiskSnapshot -> FsPath
snapshotToDirPath DiskSnapshot
ds)
                    [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [String -> Text
forall a. IsString a => String -> a
fromString String
"tables", String -> Text
forall a. IsString a => String -> a
fromString String
"tvar"]
              )
      let computedCRC = CRC -> CRC -> CRC
crcOfConcat CRC
checksumAsRead CRC
crcTables
      Monad.when (computedCRC /= snapshotChecksum snapshotMeta) $
        throwE $
          InitFailureRead $
            ReadSnapshotDataCorruption
      (,pt) <$> lift (empty extLedgerSt values (newInMemoryLedgerTablesHandle fs))