{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeData #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ViewPatterns #-}
-- Needed for @NoThunks (Table m k v b)@
{-# OPTIONS_GHC -Wno-orphans #-}

-- | Implementation of the 'LedgerTablesHandle' interface with LSM trees.
module Ouroboros.Consensus.Storage.LedgerDB.V2.LSM
  ( -- * Backend API
    LSM
  , Backend (..)
  , Args (LSMArgs)
  , Trace (..)
  , LSM.LSMTreeTrace (..)
  , mkLSMArgsIO
  , stdMkBlockIOFS

    -- * Streaming
  , YieldArgs (YieldLSM)
  , mkLSMYieldArgs
  , mkExportedLSMYieldArgs
  , SinkArgs (SinkLSM)
  , mkLSMSinkArgs
  , mkExportedLSMSinkArgs

    -- * Standalone (exported) snapshots
  , lsmDbExportSnapshot
  , lsmDbImportSnapshot

    -- * Exported for tests
  , LSM.Salt
  , SomeHasFSAndBlockIO (..)

    -- * Disk cache policy
  , LSM.DiskCachePolicy (..)
  ) where

import Codec.Serialise (decode)
import Control.Exception (assert)
import qualified Control.Monad as Monad
import Control.Monad.Class.MonadThrow.Trans ()
import Control.Monad.Trans (lift)
import Control.Monad.Trans.Except
import Control.Monad.Trans.Maybe (MaybeT (..), maybeToExceptT)
import Control.ResourceRegistry
import Control.Tracer
import Data.ByteString (toStrict)
import qualified Data.ByteString.Builder as BS
import Data.ByteString.Char8 (readInt)
import qualified Data.Foldable as Foldable
import qualified Data.List as List
import qualified Data.Map.Strict as Map
import Data.Maybe
import Data.MemPack
import qualified Data.Primitive as P
import qualified Data.Primitive.ByteArray as PBA
import qualified Data.Set as Set
import Data.String (fromString)
import qualified Data.Text as T
import qualified Data.Text as Text
import Data.Typeable
import qualified Data.Vector as V
import qualified Data.Vector.Mutable as VM
import qualified Data.Vector.Primitive as VP
import Data.Void
import Data.Word
import Database.LSMTree (Salt, Session, Table)
import qualified Database.LSMTree as LSM
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.Ledger.Tables.Utils
import Ouroboros.Consensus.Storage.LedgerDB.API
import Ouroboros.Consensus.Storage.LedgerDB.Args
import Ouroboros.Consensus.Storage.LedgerDB.Snapshots
import Ouroboros.Consensus.Storage.LedgerDB.V2.Backend
import Ouroboros.Consensus.Storage.LedgerDB.V2.LedgerSeq
import Ouroboros.Consensus.Util (chunks, whenJust)
import Ouroboros.Consensus.Util.CRC
import Ouroboros.Consensus.Util.Enclose
import Ouroboros.Consensus.Util.IOLike
import Ouroboros.Consensus.Util.IndexedMemPack
import qualified Streaming as S
import qualified Streaming.Prelude as S
import qualified System.Directory as D
import System.FS.API
import System.FS.API.Lazy (hGetAll, hPutAll)
import qualified System.FS.BlockIO.API as BIO
import System.FS.BlockIO.IO
import qualified System.FS.IO as FS
import System.FilePath
  ( makeRelative
  , splitDirectories
  , splitFileName
  , takeDirectory
  , takeFileName
  )
import qualified System.FilePath as F
import System.Random
import Prelude hiding (read)

-- | Type alias for convenience
type UTxOTable m = Table m TxInBytes TxOutBytes Void

instance NoThunks (Table m txin txout Void) where
  showTypeOf :: Proxy (Table m txin txout Void) -> [Char]
showTypeOf Proxy (Table m txin txout Void)
_ = [Char]
"Table"
  wNoThunks :: Context -> Table m txin txout Void -> IO (Maybe ThunkInfo)
wNoThunks Context
_ Table m txin txout Void
_ = Maybe ThunkInfo -> IO (Maybe ThunkInfo)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe ThunkInfo
forall a. Maybe a
Nothing

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

type ExportSnapshot m = LSM.SnapshotName -> m ()

{-------------------------------------------------------------------------------
  TxOuts
-------------------------------------------------------------------------------}

newtype TxOutBytes = TxOutBytes {TxOutBytes -> RawBytes
unTxOutBytes :: LSM.RawBytes}

toTxOutBytes :: IndexedMemPack l blk (TxOut blk) => l blk EmptyMK -> TxOut blk -> TxOutBytes
toTxOutBytes :: forall (l :: * -> (* -> * -> *) -> *) blk.
IndexedMemPack l blk (TxOut blk) =>
l blk EmptyMK -> TxOut blk -> TxOutBytes
toTxOutBytes l blk EmptyMK
st TxOut blk
txout =
  let barr :: ByteArray
barr = Bool -> l blk EmptyMK -> TxOut blk -> ByteArray
forall a (l :: * -> (* -> * -> *) -> *) blk.
(IndexedMemPack l blk a, HasCallStack) =>
Bool -> l blk EmptyMK -> a -> ByteArray
indexedPackByteArray Bool
True l blk EmptyMK
st TxOut blk
txout
   in RawBytes -> TxOutBytes
TxOutBytes (RawBytes -> TxOutBytes) -> RawBytes -> TxOutBytes
forall a b. (a -> b) -> a -> b
$ Vector Word8 -> RawBytes
LSM.RawBytes (Int -> Int -> ByteArray -> Vector Word8
forall a. Int -> Int -> ByteArray -> Vector a
VP.Vector Int
0 (ByteArray -> Int
PBA.sizeofByteArray ByteArray
barr) ByteArray
barr)

fromTxOutBytes :: IndexedMemPack l blk (TxOut blk) => l blk EmptyMK -> TxOutBytes -> TxOut blk
fromTxOutBytes :: forall (l :: * -> (* -> * -> *) -> *) blk.
IndexedMemPack l blk (TxOut blk) =>
l blk EmptyMK -> TxOutBytes -> TxOut blk
fromTxOutBytes l blk EmptyMK
st (TxOutBytes (LSM.RawBytes Vector Word8
vec)) =
  case l blk EmptyMK -> Vector Word8 -> Either SomeError (TxOut blk)
forall (l :: * -> (* -> * -> *) -> *) blk a b.
(IndexedMemPack l blk a, Buffer b, HasCallStack) =>
l blk EmptyMK -> b -> Either SomeError a
indexedUnpackEither l blk EmptyMK
st Vector Word8
vec of
    Left SomeError
err ->
      [Char] -> TxOut blk
forall a. HasCallStack => [Char] -> a
error ([Char] -> TxOut blk) -> [Char] -> TxOut blk
forall a b. (a -> b) -> a -> b
$
        Context -> [Char]
unlines
          [ [Char]
"There was an error deserializing a TxOut from the LSM backend."
          , [Char]
"This will likely result in a restart-crash loop."
          , [Char]
"The error: " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> SomeError -> [Char]
forall a. Show a => a -> [Char]
show SomeError
err
          ]
    Right TxOut blk
v -> TxOut blk
v

instance LSM.SerialiseValue TxOutBytes where
  serialiseValue :: TxOutBytes -> RawBytes
serialiseValue = TxOutBytes -> RawBytes
unTxOutBytes
  deserialiseValue :: RawBytes -> TxOutBytes
deserialiseValue = RawBytes -> TxOutBytes
TxOutBytes

deriving via LSM.ResolveAsFirst TxOutBytes instance LSM.ResolveValue TxOutBytes

{-------------------------------------------------------------------------------
  TxIns
-------------------------------------------------------------------------------}

newtype TxInBytes = TxInBytes {TxInBytes -> RawBytes
unTxInBytes :: LSM.RawBytes}

toTxInBytes :: MemPack (TxIn blk) => Proxy blk -> TxIn blk -> TxInBytes
toTxInBytes :: forall blk.
MemPack (TxIn blk) =>
Proxy blk -> TxIn blk -> TxInBytes
toTxInBytes Proxy blk
_ TxIn blk
txin =
  let barr :: ByteArray
barr = Bool -> TxIn blk -> ByteArray
forall a. (MemPack a, HasCallStack) => Bool -> a -> ByteArray
packByteArray Bool
True TxIn blk
txin
   in RawBytes -> TxInBytes
TxInBytes (RawBytes -> TxInBytes) -> RawBytes -> TxInBytes
forall a b. (a -> b) -> a -> b
$ Vector Word8 -> RawBytes
LSM.RawBytes (Int -> Int -> ByteArray -> Vector Word8
forall a. Int -> Int -> ByteArray -> Vector a
VP.Vector Int
0 (ByteArray -> Int
PBA.sizeofByteArray ByteArray
barr) ByteArray
barr)

fromTxInBytes :: MemPack (TxIn blk) => Proxy blk -> TxInBytes -> TxIn blk
fromTxInBytes :: forall blk.
MemPack (TxIn blk) =>
Proxy blk -> TxInBytes -> TxIn blk
fromTxInBytes Proxy blk
_ (TxInBytes (LSM.RawBytes Vector Word8
vec)) =
  case Vector Word8 -> Either SomeError (TxIn blk)
forall a b.
(MemPack a, Buffer b, HasCallStack) =>
b -> Either SomeError a
unpackEither Vector Word8
vec of
    Left SomeError
err ->
      [Char] -> TxIn blk
forall a. HasCallStack => [Char] -> a
error ([Char] -> TxIn blk) -> [Char] -> TxIn blk
forall a b. (a -> b) -> a -> b
$
        Context -> [Char]
unlines
          [ [Char]
"There was an error deserializing a TxIn from the LSM backend."
          , [Char]
"This will likely result in a restart-crash loop."
          , [Char]
"The error: " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> SomeError -> [Char]
forall a. Show a => a -> [Char]
show SomeError
err
          ]
    Right TxIn blk
v -> TxIn blk
v

instance LSM.SerialiseKey TxInBytes where
  serialiseKey :: TxInBytes -> RawBytes
serialiseKey = TxInBytes -> RawBytes
unTxInBytes
  deserialiseKey :: RawBytes -> TxInBytes
deserialiseKey = RawBytes -> TxInBytes
TxInBytes

{-------------------------------------------------------------------------------
  LSM Handle management
-------------------------------------------------------------------------------}

closeLSMTable :: IOLike m => Tracer m LedgerDBV2Trace -> UTxOTable m -> m ()
closeLSMTable :: forall (m :: * -> *).
IOLike m =>
Tracer m LedgerDBV2Trace -> UTxOTable m -> m ()
closeLSMTable Tracer m LedgerDBV2Trace
tracer UTxOTable m
t =
  Tracer m EnclosingTimed -> m () -> m ()
forall (m :: * -> *) a.
MonadMonotonicTime m =>
Tracer m EnclosingTimed -> m a -> m a
encloseTimedWith (EnclosingTimed -> LedgerDBV2Trace
TraceLedgerTablesHandleClose (EnclosingTimed -> LedgerDBV2Trace)
-> Tracer m LedgerDBV2Trace -> Tracer m EnclosingTimed
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
>$< Tracer m LedgerDBV2Trace
tracer) (UTxOTable m -> m ()
forall (m :: * -> *) k v b. IOLike m => Table m k v b -> m ()
LSM.closeTable UTxOTable m
t)

duplicateLSMTable ::
  IOLike m =>
  Tracer m LedgerDBV2Trace ->
  UTxOTable m ->
  m (UTxOTable m)
duplicateLSMTable :: forall (m :: * -> *).
IOLike m =>
Tracer m LedgerDBV2Trace -> UTxOTable m -> m (UTxOTable m)
duplicateLSMTable Tracer m LedgerDBV2Trace
tracer UTxOTable m
t = do
  Tracer m EnclosingTimed -> m (UTxOTable m) -> m (UTxOTable m)
forall (m :: * -> *) a.
MonadMonotonicTime m =>
Tracer m EnclosingTimed -> m a -> m a
encloseTimedWith (EnclosingTimed -> LedgerDBV2Trace
TraceLedgerTablesHandleDuplicate (EnclosingTimed -> LedgerDBV2Trace)
-> Tracer m LedgerDBV2Trace -> Tracer m EnclosingTimed
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
>$< Tracer m LedgerDBV2Trace
tracer) (m (UTxOTable m) -> m (UTxOTable m))
-> m (UTxOTable m) -> m (UTxOTable m)
forall a b. (a -> b) -> a -> b
$ UTxOTable m -> m (UTxOTable m)
forall (m :: * -> *) k v b.
IOLike m =>
Table m k v b -> m (Table m k v b)
LSM.duplicate UTxOTable m
t

{-------------------------------------------------------------------------------
  LedgerTablesHandle
-------------------------------------------------------------------------------}

type LSMConstraints l blk =
  (HasLedgerTables l blk, MemPack (TxIn blk), IndexedMemPack l blk (TxOut blk))

newLSMLedgerTablesHandle ::
  forall m l blk.
  ( IOLike m
  , LSMConstraints l blk
  ) =>
  Tracer m LedgerDBV2Trace ->
  ExportSnapshot m ->
  -- | The size of the tables
  Word64 ->
  UTxOTable m ->
  m (LedgerTablesHandle m l blk)
newLSMLedgerTablesHandle :: forall (m :: * -> *) (l :: * -> (* -> * -> *) -> *) blk.
(IOLike m, LSMConstraints l blk) =>
Tracer m LedgerDBV2Trace
-> ExportSnapshot m
-> Word64
-> UTxOTable m
-> m (LedgerTablesHandle m l blk)
newLSMLedgerTablesHandle Tracer m LedgerDBV2Trace
tracer ExportSnapshot m
exportSnapshot Word64
utxosSize UTxOTable m
t =
  Tracer m EnclosingTimed
-> m (LedgerTablesHandle m l blk) -> m (LedgerTablesHandle m l blk)
forall (m :: * -> *) a.
MonadMonotonicTime m =>
Tracer m EnclosingTimed -> m a -> m a
encloseTimedWith (EnclosingTimed -> LedgerDBV2Trace
TraceLedgerTablesHandleCreate (EnclosingTimed -> LedgerDBV2Trace)
-> Tracer m LedgerDBV2Trace -> Tracer m EnclosingTimed
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
>$< Tracer m LedgerDBV2Trace
tracer) (m (LedgerTablesHandle m l blk) -> m (LedgerTablesHandle m l blk))
-> m (LedgerTablesHandle m l blk) -> m (LedgerTablesHandle m l blk)
forall a b. (a -> b) -> a -> b
$ do
    LedgerTablesHandle m l blk -> m (LedgerTablesHandle m l blk)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
      LedgerTablesHandle
        { close :: m ()
close = Tracer m LedgerDBV2Trace -> UTxOTable m -> m ()
forall (m :: * -> *).
IOLike m =>
Tracer m LedgerDBV2Trace -> UTxOTable m -> m ()
closeLSMTable Tracer m LedgerDBV2Trace
tracer UTxOTable m
t
        , duplicateWithDiffs :: l blk EmptyMK -> l blk DiffMK -> m (LedgerTablesHandle m l blk)
duplicateWithDiffs = Tracer m LedgerDBV2Trace
-> ExportSnapshot m
-> UTxOTable m
-> Word64
-> l blk EmptyMK
-> l blk DiffMK
-> m (LedgerTablesHandle m l blk)
forall (m :: * -> *) (l :: * -> (* -> * -> *) -> *) blk
       (mk :: * -> * -> *).
(IOLike m, LSMConstraints l blk) =>
Tracer m LedgerDBV2Trace
-> ExportSnapshot m
-> UTxOTable m
-> Word64
-> l blk mk
-> l blk DiffMK
-> m (LedgerTablesHandle m l blk)
implDuplicateWithDiffs Tracer m LedgerDBV2Trace
tracer ExportSnapshot m
exportSnapshot UTxOTable m
t Word64
utxosSize
        , duplicate :: m (LedgerTablesHandle m l blk)
duplicate = Word64
-> UTxOTable m
-> Tracer m LedgerDBV2Trace
-> ExportSnapshot m
-> m (LedgerTablesHandle m l blk)
forall (m :: * -> *) (l :: * -> (* -> * -> *) -> *) blk.
(IOLike m, LSMConstraints l blk) =>
Word64
-> UTxOTable m
-> Tracer m LedgerDBV2Trace
-> ExportSnapshot m
-> m (LedgerTablesHandle m l blk)
implDuplicate Word64
utxosSize UTxOTable m
t Tracer m LedgerDBV2Trace
tracer ExportSnapshot m
exportSnapshot
        , read :: l blk EmptyMK
-> LedgerTables blk KeysMK -> m (LedgerTables blk ValuesMK)
read = Tracer m LedgerDBV2Trace
-> UTxOTable m
-> l blk EmptyMK
-> LedgerTables blk KeysMK
-> m (LedgerTables blk ValuesMK)
forall (m :: * -> *) (l :: * -> (* -> * -> *) -> *) blk.
(IOLike m, LSMConstraints l blk) =>
Tracer m LedgerDBV2Trace
-> UTxOTable m
-> l blk EmptyMK
-> LedgerTables blk KeysMK
-> m (LedgerTables blk ValuesMK)
implRead Tracer m LedgerDBV2Trace
tracer UTxOTable m
t
        , readRange :: l blk EmptyMK
-> (Maybe (TxIn blk), Int)
-> m (LedgerTables blk ValuesMK, Maybe (TxIn blk))
readRange = UTxOTable m
-> l blk EmptyMK
-> (Maybe (TxIn blk), Int)
-> m (LedgerTables blk ValuesMK, Maybe (TxIn blk))
forall (m :: * -> *) (l :: * -> (* -> * -> *) -> *) blk.
(IOLike m, LSMConstraints l blk) =>
UTxOTable m
-> l blk EmptyMK
-> (Maybe (TxIn blk), Int)
-> m (LedgerTables blk ValuesMK, Maybe (TxIn blk))
implReadRange UTxOTable m
t
        , readAll :: l blk EmptyMK -> m (LedgerTables blk ValuesMK)
readAll = UTxOTable m -> l blk EmptyMK -> m (LedgerTables blk ValuesMK)
forall (m :: * -> *) (l :: * -> (* -> * -> *) -> *) blk.
(IOLike m, LSMConstraints l blk) =>
UTxOTable m -> l blk EmptyMK -> m (LedgerTables blk ValuesMK)
implReadAll UTxOTable m
t
        , takeHandleSnapshot :: l blk EmptyMK -> [Char] -> m (Maybe CRC)
takeHandleSnapshot = Tracer m LedgerDBV2Trace
-> ExportSnapshot m
-> UTxOTable m
-> l blk EmptyMK
-> [Char]
-> m (Maybe CRC)
forall (m :: * -> *) t a.
IOLike m =>
Tracer m LedgerDBV2Trace
-> (SnapshotName -> m ())
-> UTxOTable m
-> t
-> [Char]
-> m (Maybe a)
implTakeHandleSnapshot Tracer m LedgerDBV2Trace
tracer ExportSnapshot m
exportSnapshot UTxOTable m
t
        , tablesSize :: Int
tablesSize = Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
utxosSize
        }

{-# INLINE implDuplicate #-}
{-# INLINE implRead #-}
{-# INLINE implReadRange #-}
{-# INLINE implReadAll #-}
{-# INLINE implDuplicateWithDiffs #-}
{-# INLINE implTakeHandleSnapshot #-}

implDuplicate ::
  ( IOLike m
  , LSMConstraints l blk
  ) =>
  Word64 ->
  UTxOTable m ->
  Tracer m LedgerDBV2Trace ->
  ExportSnapshot m ->
  m (LedgerTablesHandle m l blk)
implDuplicate :: forall (m :: * -> *) (l :: * -> (* -> * -> *) -> *) blk.
(IOLike m, LSMConstraints l blk) =>
Word64
-> UTxOTable m
-> Tracer m LedgerDBV2Trace
-> ExportSnapshot m
-> m (LedgerTablesHandle m l blk)
implDuplicate Word64
size UTxOTable m
t Tracer m LedgerDBV2Trace
tracer ExportSnapshot m
exportSnapshot =
  Tracer m LedgerDBV2Trace -> UTxOTable m -> m (UTxOTable m)
forall (m :: * -> *).
IOLike m =>
Tracer m LedgerDBV2Trace -> UTxOTable m -> m (UTxOTable m)
duplicateLSMTable Tracer m LedgerDBV2Trace
tracer UTxOTable m
t
    m (UTxOTable m)
-> (UTxOTable m -> m (LedgerTablesHandle m l blk))
-> m (LedgerTablesHandle m l blk)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Tracer m LedgerDBV2Trace
-> ExportSnapshot m
-> Word64
-> UTxOTable m
-> m (LedgerTablesHandle m l blk)
forall (m :: * -> *) (l :: * -> (* -> * -> *) -> *) blk.
(IOLike m, LSMConstraints l blk) =>
Tracer m LedgerDBV2Trace
-> ExportSnapshot m
-> Word64
-> UTxOTable m
-> m (LedgerTablesHandle m l blk)
newLSMLedgerTablesHandle
      Tracer m LedgerDBV2Trace
tracer
      ExportSnapshot m
exportSnapshot
      Word64
size

implDuplicateWithDiffs ::
  forall m l blk mk.
  ( IOLike m
  , LSMConstraints l blk
  ) =>
  Tracer m LedgerDBV2Trace ->
  ExportSnapshot m ->
  UTxOTable m ->
  Word64 ->
  l blk mk ->
  l blk DiffMK ->
  m (LedgerTablesHandle m l blk)
implDuplicateWithDiffs :: forall (m :: * -> *) (l :: * -> (* -> * -> *) -> *) blk
       (mk :: * -> * -> *).
(IOLike m, LSMConstraints l blk) =>
Tracer m LedgerDBV2Trace
-> ExportSnapshot m
-> UTxOTable m
-> Word64
-> l blk mk
-> l blk DiffMK
-> m (LedgerTablesHandle m l blk)
implDuplicateWithDiffs Tracer m LedgerDBV2Trace
tracer ExportSnapshot m
exportSnapshot UTxOTable m
t0 Word64
size l blk mk
_ !l blk DiffMK
st1 = do
  t <- Tracer m LedgerDBV2Trace -> UTxOTable m -> m (UTxOTable m)
forall (m :: * -> *).
IOLike m =>
Tracer m LedgerDBV2Trace -> UTxOTable m -> m (UTxOTable m)
duplicateLSMTable Tracer m LedgerDBV2Trace
tracer UTxOTable m
t0
  encloseTimedWith (TraceLedgerTablesHandleRead >$< tracer) $ do
    let LedgerTables (DiffMK (Diff.Diff diffs)) = projectLedgerTables st1
    let vec = (forall s. ST s (MVector s (TxInBytes, Update TxOutBytes Void)))
-> Vector (TxInBytes, Update TxOutBytes Void)
forall a. (forall s. ST s (MVector s a)) -> Vector a
V.create ((forall s. ST s (MVector s (TxInBytes, Update TxOutBytes Void)))
 -> Vector (TxInBytes, Update TxOutBytes Void))
-> (forall s. ST s (MVector s (TxInBytes, Update TxOutBytes Void)))
-> Vector (TxInBytes, Update TxOutBytes Void)
forall a b. (a -> b) -> a -> b
$ do
          vec' <- Int
-> ST
     s (MVector (PrimState (ST s)) (TxInBytes, Update TxOutBytes Void))
forall (m :: * -> *) a.
PrimMonad m =>
Int -> m (MVector (PrimState m) a)
VM.new (Map (TxIn blk) (Delta (TxOut blk)) -> Int
forall k a. Map k a -> Int
Map.size Map (TxIn blk) (Delta (TxOut blk))
diffs)
          Monad.foldM_
            (\Int
idx (TxIn blk
k, Delta (TxOut blk)
item) -> MVector (PrimState (ST s)) (TxInBytes, Update TxOutBytes Void)
-> Int -> (TxInBytes, Update TxOutBytes Void) -> ST s ()
forall (m :: * -> *) a.
PrimMonad m =>
MVector (PrimState m) a -> Int -> a -> m ()
VM.write MVector s (TxInBytes, Update TxOutBytes Void)
MVector (PrimState (ST s)) (TxInBytes, Update TxOutBytes Void)
vec' Int
idx (Proxy blk -> TxIn blk -> TxInBytes
forall blk.
MemPack (TxIn blk) =>
Proxy blk -> TxIn blk -> TxInBytes
toTxInBytes (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @blk) TxIn blk
k, (Delta (TxOut blk) -> Update TxOutBytes Void
f Delta (TxOut blk)
item)) ST s () -> ST s Int -> ST s Int
forall a b. ST s a -> ST s b -> ST s b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> ST s Int
forall a. a -> ST s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1))
            0
            $ Map.toList diffs
          pure vec'
    let (ins, dels) =
          Map.foldl'
            ( \(Word64
i, Word64
d) Delta (TxOut blk)
delta -> case Delta (TxOut blk)
delta of
                Diff.Insert{} -> (Word64
i Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
1, Word64
d)
                Delta (TxOut blk)
Diff.Delete -> (Word64
i, Word64
d Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
1)
            )
            (0, 0)
            diffs
    let size' =
          Bool -> Word64 -> Word64
forall a. HasCallStack => Bool -> a -> a
assert (Word64
size Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
ins Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word64
size) (Word64 -> Word64) -> Word64 -> Word64
forall a b. (a -> b) -> a -> b
$
            Bool -> Word64 -> Word64
forall a. HasCallStack => Bool -> a -> a
assert (Word64
size Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
ins Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
dels Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word64
size Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
ins) (Word64 -> Word64) -> Word64 -> Word64
forall a b. (a -> b) -> a -> b
$
              Word64
size Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
ins Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
dels

    encloseTimedWith (BackendTrace . SomeBackendTrace . LSMUpdate >$< tracer) $ LSM.updates t vec
    newLSMLedgerTablesHandle tracer exportSnapshot size' t
 where
  f :: Delta (TxOut blk) -> Update TxOutBytes Void
f (Diff.Insert TxOut blk
v) = TxOutBytes -> Maybe Void -> Update TxOutBytes Void
forall v b. v -> Maybe b -> Update v b
LSM.Insert (l blk EmptyMK -> TxOut blk -> TxOutBytes
forall (l :: * -> (* -> * -> *) -> *) blk.
IndexedMemPack l blk (TxOut blk) =>
l blk EmptyMK -> TxOut blk -> TxOutBytes
toTxOutBytes (l blk DiffMK -> l blk EmptyMK
forall (l :: * -> (* -> * -> *) -> *) blk (mk :: * -> * -> *).
HasLedgerTables l blk =>
l blk mk -> l blk EmptyMK
forgetLedgerTables l blk DiffMK
st1) TxOut blk
v) Maybe Void
forall a. Maybe a
Nothing
  f Delta (TxOut blk)
Diff.Delete = Update TxOutBytes Void
forall v b. Update v b
LSM.Delete

implRead ::
  forall m l blk.
  ( IOLike m
  , LSMConstraints l blk
  ) =>
  Tracer m LedgerDBV2Trace ->
  UTxOTable m ->
  l blk EmptyMK ->
  LedgerTables blk KeysMK ->
  m (LedgerTables blk ValuesMK)
implRead :: forall (m :: * -> *) (l :: * -> (* -> * -> *) -> *) blk.
(IOLike m, LSMConstraints l blk) =>
Tracer m LedgerDBV2Trace
-> UTxOTable m
-> l blk EmptyMK
-> LedgerTables blk KeysMK
-> m (LedgerTables blk ValuesMK)
implRead Tracer m LedgerDBV2Trace
tracer UTxOTable m
t l blk EmptyMK
st (LedgerTables (KeysMK Set (TxIn blk)
keys)) =
  Tracer m EnclosingTimed
-> m (LedgerTables blk ValuesMK) -> m (LedgerTables blk ValuesMK)
forall (m :: * -> *) a.
MonadMonotonicTime m =>
Tracer m EnclosingTimed -> m a -> m a
encloseTimedWith (EnclosingTimed -> LedgerDBV2Trace
TraceLedgerTablesHandleRead (EnclosingTimed -> LedgerDBV2Trace)
-> Tracer m LedgerDBV2Trace -> Tracer m EnclosingTimed
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
>$< Tracer m LedgerDBV2Trace
tracer) (m (LedgerTables blk ValuesMK) -> m (LedgerTables blk ValuesMK))
-> m (LedgerTables blk ValuesMK) -> m (LedgerTables blk ValuesMK)
forall a b. (a -> b) -> a -> b
$ do
    let vec' :: Vector TxInBytes
vec' = (forall s. ST s (MVector s TxInBytes)) -> Vector TxInBytes
forall a. (forall s. ST s (MVector s a)) -> Vector a
V.create ((forall s. ST s (MVector s TxInBytes)) -> Vector TxInBytes)
-> (forall s. ST s (MVector s TxInBytes)) -> Vector TxInBytes
forall a b. (a -> b) -> a -> b
$ do
          vec <- Int -> ST s (MVector (PrimState (ST s)) TxInBytes)
forall (m :: * -> *) a.
PrimMonad m =>
Int -> m (MVector (PrimState m) a)
VM.new (Set (TxIn blk) -> Int
forall a. Set a -> Int
Set.size Set (TxIn blk)
keys)
          Monad.foldM_
            (\Int
i TxIn blk
x -> MVector (PrimState (ST s)) TxInBytes -> Int -> TxInBytes -> ST s ()
forall (m :: * -> *) a.
PrimMonad m =>
MVector (PrimState m) a -> Int -> a -> m ()
VM.write MVector s TxInBytes
MVector (PrimState (ST s)) TxInBytes
vec Int
i (Proxy blk -> TxIn blk -> TxInBytes
forall blk.
MemPack (TxIn blk) =>
Proxy blk -> TxIn blk -> TxInBytes
toTxInBytes (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @blk) TxIn blk
x) ST s () -> ST s Int -> ST s Int
forall a b. ST s a -> ST s b -> ST s b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> ST s Int
forall a. a -> ST s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1))
            0
            keys
          pure vec
    res <-
      Tracer m EnclosingTimed
-> m (Vector (LookupResult TxOutBytes (BlobRef m Void)))
-> m (Vector (LookupResult TxOutBytes (BlobRef m Void)))
forall (m :: * -> *) a.
MonadMonotonicTime m =>
Tracer m EnclosingTimed -> m a -> m a
encloseTimedWith (SomeBackendTrace -> LedgerDBV2Trace
BackendTrace (SomeBackendTrace -> LedgerDBV2Trace)
-> (EnclosingTimed -> SomeBackendTrace)
-> EnclosingTimed
-> LedgerDBV2Trace
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Trace LSM -> SomeBackendTrace
forall backend.
(Show (Trace backend), Typeable backend) =>
Trace backend -> SomeBackendTrace
SomeBackendTrace (Trace LSM -> SomeBackendTrace)
-> (EnclosingTimed -> Trace LSM)
-> EnclosingTimed
-> SomeBackendTrace
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EnclosingTimed -> Trace LSM
LSMLookup (EnclosingTimed -> LedgerDBV2Trace)
-> Tracer m LedgerDBV2Trace -> Tracer m EnclosingTimed
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
>$< Tracer m LedgerDBV2Trace
tracer) (m (Vector (LookupResult TxOutBytes (BlobRef m Void)))
 -> m (Vector (LookupResult TxOutBytes (BlobRef m Void))))
-> m (Vector (LookupResult TxOutBytes (BlobRef m Void)))
-> m (Vector (LookupResult TxOutBytes (BlobRef m Void)))
forall a b. (a -> b) -> a -> b
$ UTxOTable m
-> Vector TxInBytes
-> m (Vector (LookupResult TxOutBytes (BlobRef m Void)))
forall (m :: * -> *) k v b.
(IOLike m, SerialiseKey k, SerialiseValue v, ResolveValue v) =>
Table m k v b
-> Vector k -> m (Vector (LookupResult v (BlobRef m b)))
LSM.lookups UTxOTable m
t Vector TxInBytes
vec'
    pure
      . LedgerTables
      . ValuesMK
      . Foldable.foldl'
        ( \Map (TxIn blk) (TxOut blk)
m (TxInBytes
k, LookupResult TxOutBytes (BlobRef m Void)
item) ->
            case LookupResult TxOutBytes (BlobRef m Void)
item of
              LSM.Found TxOutBytes
v -> TxIn blk
-> TxOut blk
-> Map (TxIn blk) (TxOut blk)
-> Map (TxIn blk) (TxOut blk)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (Proxy blk -> TxInBytes -> TxIn blk
forall blk.
MemPack (TxIn blk) =>
Proxy blk -> TxInBytes -> TxIn blk
fromTxInBytes (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @blk) TxInBytes
k) (l blk EmptyMK -> TxOutBytes -> TxOut blk
forall (l :: * -> (* -> * -> *) -> *) blk.
IndexedMemPack l blk (TxOut blk) =>
l blk EmptyMK -> TxOutBytes -> TxOut blk
fromTxOutBytes l blk EmptyMK
st TxOutBytes
v) Map (TxIn blk) (TxOut blk)
m
              LookupResult TxOutBytes (BlobRef m Void)
LSM.NotFound -> Map (TxIn blk) (TxOut blk)
m
              LSM.FoundWithBlob{} -> Map (TxIn blk) (TxOut blk)
m
        )
        Map.empty
      $ V.zip vec' res

implReadRange ::
  forall m l blk.
  (IOLike m, LSMConstraints l blk) =>
  UTxOTable m ->
  l blk EmptyMK ->
  (Maybe (TxIn blk), Int) ->
  m (LedgerTables blk ValuesMK, Maybe (TxIn blk))
implReadRange :: forall (m :: * -> *) (l :: * -> (* -> * -> *) -> *) blk.
(IOLike m, LSMConstraints l blk) =>
UTxOTable m
-> l blk EmptyMK
-> (Maybe (TxIn blk), Int)
-> m (LedgerTables blk ValuesMK, Maybe (TxIn blk))
implReadRange UTxOTable m
table l blk EmptyMK
st (Maybe (TxIn blk)
mPrev, Int
num) = do
  entries <- m (Vector (Entry TxInBytes TxOutBytes (BlobRef m Void)))
-> (TxIn blk
    -> m (Vector (Entry TxInBytes TxOutBytes (BlobRef m Void))))
-> Maybe (TxIn blk)
-> m (Vector (Entry TxInBytes TxOutBytes (BlobRef m Void)))
forall b a. b -> (a -> b) -> Maybe a -> b
maybe m (Vector (Entry TxInBytes TxOutBytes (BlobRef m Void)))
cursorFromStart TxIn blk
-> m (Vector (Entry TxInBytes TxOutBytes (BlobRef m Void)))
cursorFromKey Maybe (TxIn blk)
mPrev
  pure
    ( LedgerTables
        . ValuesMK
        . V.foldl'
          ( \Map (TxIn blk) (TxOut blk)
m -> \case
              LSM.Entry TxInBytes
k TxOutBytes
v -> TxIn blk
-> TxOut blk
-> Map (TxIn blk) (TxOut blk)
-> Map (TxIn blk) (TxOut blk)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (Proxy blk -> TxInBytes -> TxIn blk
forall blk.
MemPack (TxIn blk) =>
Proxy blk -> TxInBytes -> TxIn blk
fromTxInBytes (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @blk) TxInBytes
k) (l blk EmptyMK -> TxOutBytes -> TxOut blk
forall (l :: * -> (* -> * -> *) -> *) blk.
IndexedMemPack l blk (TxOut blk) =>
l blk EmptyMK -> TxOutBytes -> TxOut blk
fromTxOutBytes l blk EmptyMK
st TxOutBytes
v) Map (TxIn blk) (TxOut blk)
m
              LSM.EntryWithBlob{} -> Map (TxIn blk) (TxOut blk)
m
          )
          Map.empty
        $ entries
    , case snd <$> V.unsnoc entries of
        Maybe (Entry TxInBytes TxOutBytes (BlobRef m Void))
Nothing -> Maybe (TxIn blk)
forall a. Maybe a
Nothing
        Just (LSM.Entry TxInBytes
k TxOutBytes
_) -> TxIn blk -> Maybe (TxIn blk)
forall a. a -> Maybe a
Just (Proxy blk -> TxInBytes -> TxIn blk
forall blk.
MemPack (TxIn blk) =>
Proxy blk -> TxInBytes -> TxIn blk
fromTxInBytes (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @blk) TxInBytes
k)
        Just (LSM.EntryWithBlob TxInBytes
k TxOutBytes
_ BlobRef m Void
_) -> TxIn blk -> Maybe (TxIn blk)
forall a. a -> Maybe a
Just (Proxy blk -> TxInBytes -> TxIn blk
forall blk.
MemPack (TxIn blk) =>
Proxy blk -> TxInBytes -> TxIn blk
fromTxInBytes (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @blk) TxInBytes
k)
    )
 where
  cursorFromStart :: m (Vector (Entry TxInBytes TxOutBytes (BlobRef m Void)))
cursorFromStart = UTxOTable m
-> (Cursor m TxInBytes TxOutBytes Void
    -> m (Vector (Entry TxInBytes TxOutBytes (BlobRef m Void))))
-> m (Vector (Entry TxInBytes TxOutBytes (BlobRef m Void)))
forall (m :: * -> *) k v b a.
(IOLike m, ResolveValue v) =>
Table m k v b -> (Cursor m k v b -> m a) -> m a
LSM.withCursor UTxOTable m
table (Int
-> Cursor m TxInBytes TxOutBytes Void
-> m (Vector (Entry TxInBytes TxOutBytes (BlobRef m Void)))
forall (m :: * -> *) k v b.
(IOLike m, SerialiseKey k, SerialiseValue v, ResolveValue v) =>
Int -> Cursor m k v b -> m (Vector (Entry k v (BlobRef m b)))
LSM.take Int
num)
  -- Here we ask for one value more and we drop one value because the
  -- cursor returns also the key at which it was opened.
  cursorFromKey :: TxIn blk
-> m (Vector (Entry TxInBytes TxOutBytes (BlobRef m Void)))
cursorFromKey TxIn blk
k = (Vector (Entry TxInBytes TxOutBytes (BlobRef m Void))
 -> Vector (Entry TxInBytes TxOutBytes (BlobRef m Void)))
-> m (Vector (Entry TxInBytes TxOutBytes (BlobRef m Void)))
-> m (Vector (Entry TxInBytes TxOutBytes (BlobRef m Void)))
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int
-> Vector (Entry TxInBytes TxOutBytes (BlobRef m Void))
-> Vector (Entry TxInBytes TxOutBytes (BlobRef m Void))
forall a. Int -> Vector a -> Vector a
V.drop Int
1) (m (Vector (Entry TxInBytes TxOutBytes (BlobRef m Void)))
 -> m (Vector (Entry TxInBytes TxOutBytes (BlobRef m Void))))
-> m (Vector (Entry TxInBytes TxOutBytes (BlobRef m Void)))
-> m (Vector (Entry TxInBytes TxOutBytes (BlobRef m Void)))
forall a b. (a -> b) -> a -> b
$ UTxOTable m
-> TxInBytes
-> (Cursor m TxInBytes TxOutBytes Void
    -> m (Vector (Entry TxInBytes TxOutBytes (BlobRef m Void))))
-> m (Vector (Entry TxInBytes TxOutBytes (BlobRef m Void)))
forall (m :: * -> *) k v b a.
(IOLike m, SerialiseKey k, ResolveValue v) =>
Table m k v b -> k -> (Cursor m k v b -> m a) -> m a
LSM.withCursorAtOffset UTxOTable m
table (Proxy blk -> TxIn blk -> TxInBytes
forall blk.
MemPack (TxIn blk) =>
Proxy blk -> TxIn blk -> TxInBytes
toTxInBytes (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @blk) TxIn blk
k) (Int
-> Cursor m TxInBytes TxOutBytes Void
-> m (Vector (Entry TxInBytes TxOutBytes (BlobRef m Void)))
forall (m :: * -> *) k v b.
(IOLike m, SerialiseKey k, SerialiseValue v, ResolveValue v) =>
Int -> Cursor m k v b -> m (Vector (Entry k v (BlobRef m b)))
LSM.take (Int
 -> Cursor m TxInBytes TxOutBytes Void
 -> m (Vector (Entry TxInBytes TxOutBytes (BlobRef m Void))))
-> Int
-> Cursor m TxInBytes TxOutBytes Void
-> m (Vector (Entry TxInBytes TxOutBytes (BlobRef m Void)))
forall a b. (a -> b) -> a -> b
$ Int
num Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)

implReadAll ::
  ( IOLike m
  , LSMConstraints l blk
  ) =>
  UTxOTable m ->
  l blk EmptyMK ->
  m (LedgerTables blk ValuesMK)
implReadAll :: forall (m :: * -> *) (l :: * -> (* -> * -> *) -> *) blk.
(IOLike m, LSMConstraints l blk) =>
UTxOTable m -> l blk EmptyMK -> m (LedgerTables blk ValuesMK)
implReadAll UTxOTable m
t l blk EmptyMK
st =
  let readAll' :: Maybe (TxIn blk) -> m (LedgerTables blk ValuesMK)
readAll' Maybe (TxIn blk)
m = do
        (v, n) <- UTxOTable m
-> l blk EmptyMK
-> (Maybe (TxIn blk), Int)
-> m (LedgerTables blk ValuesMK, Maybe (TxIn blk))
forall (m :: * -> *) (l :: * -> (* -> * -> *) -> *) blk.
(IOLike m, LSMConstraints l blk) =>
UTxOTable m
-> l blk EmptyMK
-> (Maybe (TxIn blk), Int)
-> m (LedgerTables blk ValuesMK, Maybe (TxIn blk))
implReadRange UTxOTable m
t l blk EmptyMK
st (Maybe (TxIn blk)
m, Int
100000)
        maybe (pure v) (fmap (ltliftA2 unionValues v) . readAll' . Just) n
   in Maybe (TxIn blk) -> m (LedgerTables blk ValuesMK)
readAll' Maybe (TxIn blk)
forall a. Maybe a
Nothing

implTakeHandleSnapshot ::
  IOLike m =>
  Tracer m LedgerDBV2Trace -> (LSM.SnapshotName -> m ()) -> UTxOTable m -> t -> String -> m (Maybe a)
implTakeHandleSnapshot :: forall (m :: * -> *) t a.
IOLike m =>
Tracer m LedgerDBV2Trace
-> (SnapshotName -> m ())
-> UTxOTable m
-> t
-> [Char]
-> m (Maybe a)
implTakeHandleSnapshot Tracer m LedgerDBV2Trace
tracer SnapshotName -> m ()
exportSnapshot UTxOTable m
t t
_ [Char]
snapshotName = do
  Tracer m EnclosingTimed -> m () -> m ()
forall (m :: * -> *) a.
MonadMonotonicTime m =>
Tracer m EnclosingTimed -> m a -> m a
encloseTimedWith (SomeBackendTrace -> LedgerDBV2Trace
BackendTrace (SomeBackendTrace -> LedgerDBV2Trace)
-> (EnclosingTimed -> SomeBackendTrace)
-> EnclosingTimed
-> LedgerDBV2Trace
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Trace LSM -> SomeBackendTrace
forall backend.
(Show (Trace backend), Typeable backend) =>
Trace backend -> SomeBackendTrace
SomeBackendTrace (Trace LSM -> SomeBackendTrace)
-> (EnclosingTimed -> Trace LSM)
-> EnclosingTimed
-> SomeBackendTrace
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EnclosingTimed -> Trace LSM
LSMSnap (EnclosingTimed -> LedgerDBV2Trace)
-> Tracer m LedgerDBV2Trace -> Tracer m EnclosingTimed
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
>$< Tracer m LedgerDBV2Trace
tracer) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
    SnapshotName -> SnapshotLabel -> UTxOTable m -> m ()
forall (m :: * -> *) k v b.
IOLike m =>
SnapshotName -> SnapshotLabel -> Table m k v b -> m ()
LSM.saveSnapshot
      ([Char] -> SnapshotName
forall a. IsString a => [Char] -> a
fromString [Char]
snapshotName)
      (Text -> SnapshotLabel
LSM.SnapshotLabel (Text -> SnapshotLabel) -> Text -> SnapshotLabel
forall a b. (a -> b) -> a -> b
$ [Char] -> Text
Text.pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ [Char]
"UTxO table")
      UTxOTable m
t
  SnapshotName -> m ()
exportSnapshot ([Char] -> SnapshotName
forall a. IsString a => [Char] -> a
fromString [Char]
snapshotName)
  Maybe a -> m (Maybe a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing

{-------------------------------------------------------------------------------
  SnapshotManager
-------------------------------------------------------------------------------}

-- | Snapshots in LSM trees are split in two parts for now:
--
-- - The @state@ and @meta@ files in the usual location (@./ledger/<slotno>@ in
--   the ChainDB).
--
-- - The ledger tables, which are stored in the LSM-trees session directory,
--   under a @./lsm/snapshots/<slotno>@ directory.
--
-- Note that the name of the folder in which the @state@ file is and the name of
-- the snapshot in the LSM-trees directory have to match. This means that if the
-- user adds a suffix to the snapshot renaming the directory
-- @./ledger/<slotno>@, they will also have to rename the directory
-- @./lsm/snapshots/<slotno>@. Otherwise the initialization logic will exit with
-- failure saying that the snapshot was not found.
--
-- There is [an issue open in
-- LSM-trees](https://github.com/IntersectMBO/lsm-tree/issues/272) such that the
-- ledger tables part of the snapshot could also be stored in the
-- @./ledger/<slotno>@ directory, but it is not implemented yet.
snapshotManager ::
  ( IOLike m
  , LedgerDbSerialiseConstraints blk
  , LedgerSupportsProtocol blk
  ) =>
  Session m ->
  CodecConfig blk ->
  Tracer m (TraceSnapshotEvent blk) ->
  SomeHasFS m ->
  SnapshotManager m blk (StateRef m ExtLedgerState blk)
snapshotManager :: forall (m :: * -> *) blk.
(IOLike m, LedgerDbSerialiseConstraints blk,
 LedgerSupportsProtocol blk) =>
Session m
-> CodecConfig blk
-> Tracer m (TraceSnapshotEvent blk)
-> SomeHasFS m
-> SnapshotManager m blk (StateRef m ExtLedgerState blk)
snapshotManager Session m
session CodecConfig blk
ccfg Tracer m (TraceSnapshotEvent blk)
tracer SomeHasFS m
fs =
  SnapshotManager
    { listSnapshots :: m [DiskSnapshot]
listSnapshots = SomeHasFS m -> m [DiskSnapshot]
forall (m :: * -> *). Monad m => SomeHasFS m -> m [DiskSnapshot]
defaultListSnapshots SomeHasFS m
fs
    , deleteSnapshotIfTemporary :: DiskSnapshot -> m ()
deleteSnapshotIfTemporary = Session m
-> SomeHasFS m
-> Tracer m (TraceSnapshotEvent blk)
-> DiskSnapshot
-> m ()
forall (m :: * -> *) blk.
IOLike m =>
Session m
-> SomeHasFS m
-> Tracer m (TraceSnapshotEvent blk)
-> DiskSnapshot
-> m ()
implDeleteSnapshotIfTemporary Session m
session SomeHasFS m
fs Tracer m (TraceSnapshotEvent blk)
tracer
    , takeSnapshot :: Maybe [Char]
-> StateRef m ExtLedgerState blk
-> m (Maybe (DiskSnapshot, RealPoint blk))
takeSnapshot = CodecConfig blk
-> Tracer m (TraceSnapshotEvent blk)
-> SomeHasFS m
-> Maybe [Char]
-> StateRef m ExtLedgerState blk
-> m (Maybe (DiskSnapshot, RealPoint blk))
forall (m :: * -> *) blk.
(IOLike m, LedgerDbSerialiseConstraints blk,
 LedgerSupportsProtocol blk) =>
CodecConfig blk
-> Tracer m (TraceSnapshotEvent blk)
-> SomeHasFS m
-> Maybe [Char]
-> StateRef m ExtLedgerState blk
-> m (Maybe (DiskSnapshot, RealPoint blk))
implTakeSnapshot CodecConfig blk
ccfg Tracer m (TraceSnapshotEvent blk)
tracer SomeHasFS m
fs
    }

{-# INLINE implTakeSnapshot #-}
{-# INLINE implDeleteSnapshotIfTemporary #-}

implTakeSnapshot ::
  ( 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))
implTakeSnapshot :: forall (m :: * -> *) blk.
(IOLike m, LedgerDbSerialiseConstraints blk,
 LedgerSupportsProtocol blk) =>
CodecConfig blk
-> Tracer m (TraceSnapshotEvent blk)
-> SomeHasFS m
-> Maybe [Char]
-> StateRef m ExtLedgerState blk
-> m (Maybe (DiskSnapshot, RealPoint blk))
implTakeSnapshot CodecConfig blk
ccfg Tracer m (TraceSnapshotEvent blk)
tracer shfs :: SomeHasFS m
shfs@(SomeHasFS HasFS m h
hasFs) Maybe [Char]
suffix StateRef m ExtLedgerState blk
st =
  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 :: (* -> * -> *) -> *) (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 :: * -> (* -> * -> *) -> *) blk.
StateRef m l blk -> l blk 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 [Char] -> DiskSnapshot
DiskSnapshot Word64
number Maybe [Char]
suffix
      diskSnapshots <- SomeHasFS m -> m [DiskSnapshot]
forall (m :: * -> *). Monad m => SomeHasFS m -> m [DiskSnapshot]
defaultListSnapshots SomeHasFS m
shfs
      if List.any (== DiskSnapshot number suffix) diskSnapshots
        then
          return Nothing
        else do
          let sz = LedgerTablesHandle m ExtLedgerState blk -> Int
forall (m :: * -> *) (l :: * -> (* -> * -> *) -> *) blk.
LedgerTablesHandle m l blk -> Int
tablesSize (StateRef m ExtLedgerState blk
-> LedgerTablesHandle m ExtLedgerState blk
forall (m :: * -> *) (l :: * -> (* -> * -> *) -> *) blk.
StateRef m l blk -> LedgerTablesHandle m l blk
tables StateRef m ExtLedgerState blk
st)
          encloseTimedWith (TookSnapshot snapshot t >$< tracer) $
            writeSnapshot sz snapshot
          return $ Just (snapshot, t)
 where
  writeSnapshot :: Int -> DiskSnapshot -> m ()
writeSnapshot Int
sz DiskSnapshot
ds = 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
shfs (CodecConfig blk -> ExtLedgerState blk EmptyMK -> Encoding
forall blk.
(EncodeDisk blk (LedgerState blk EmptyMK),
 EncodeDisk blk (ChainDepState (BlockProtocol blk)),
 EncodeDisk blk (AnnTip blk), EncodeDisk blk (PerasState blk)) =>
CodecConfig blk -> ExtLedgerState blk EmptyMK -> Encoding
encodeDiskExtLedgerState CodecConfig blk
ccfg) (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 :: * -> (* -> * -> *) -> *) blk.
StateRef m l blk -> l blk EmptyMK
state StateRef m ExtLedgerState blk
st
    crc2 <- takeHandleSnapshot (tables st) (state st) $ snapshotToDirName ds
    writeUTxOSizeFile hasFs (snapshotToUTxOSizeFilePath ds) sz
    writeSnapshotMetadata shfs ds $
      SnapshotMetadata
        { snapshotBackend = UTxOHDLSMSnapshot
        , snapshotChecksum = maybe crc1 (crcOfConcat crc1) crc2
        , snapshotTablesCodecVersion = TablesCodecVersion1
        }

snapshotToUTxOSizeFilePath :: DiskSnapshot -> FsPath
snapshotToUTxOSizeFilePath :: DiskSnapshot -> FsPath
snapshotToUTxOSizeFilePath DiskSnapshot
ds = DiskSnapshot -> FsPath
snapshotToDirPath DiskSnapshot
ds FsPath -> FsPath -> FsPath
</> Context -> FsPath
mkFsPath [[Char]
"utxoSize"]

writeUTxOSizeFile :: MonadThrow f => HasFS f h -> FsPath -> Int -> f ()
writeUTxOSizeFile :: forall (f :: * -> *) h.
MonadThrow f =>
HasFS f h -> FsPath -> Int -> f ()
writeUTxOSizeFile HasFS f h
hasFs FsPath
p Int
sz =
  f Word64 -> f ()
forall (f :: * -> *) a. Functor f => f a -> f ()
Monad.void (f Word64 -> f ()) -> f Word64 -> f ()
forall a b. (a -> b) -> a -> b
$ HasFS f h
-> FsPath -> OpenMode -> (Handle h -> f Word64) -> f Word64
forall (m :: * -> *) h a.
(HasCallStack, MonadThrow m) =>
HasFS m h -> FsPath -> OpenMode -> (Handle h -> m a) -> m a
withFile HasFS f h
hasFs FsPath
p (AllowExisting -> OpenMode
WriteMode AllowExisting
MustBeNew) ((Handle h -> f Word64) -> f Word64)
-> (Handle h -> f Word64) -> f Word64
forall a b. (a -> b) -> a -> b
$ \Handle h
h ->
    HasFS f h -> Handle h -> ByteString -> f Word64
forall (m :: * -> *) h.
(HasCallStack, Monad m) =>
HasFS m h -> Handle h -> ByteString -> m Word64
hPutAll HasFS f h
hasFs Handle h
h (ByteString -> f Word64) -> ByteString -> f Word64
forall a b. (a -> b) -> a -> b
$ Builder -> ByteString
BS.toLazyByteString (Builder -> ByteString) -> Builder -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> Builder
BS.intDec Int
sz

readUTxOSizeFile :: MonadThrow m => HasFS m h -> FsPath -> ExceptT (SnapshotFailure blk) m Word64
readUTxOSizeFile :: forall (m :: * -> *) h blk.
MonadThrow m =>
HasFS m h -> FsPath -> ExceptT (SnapshotFailure blk) m Word64
readUTxOSizeFile HasFS m h
hfs FsPath
p = do
  exists <- m Bool -> ExceptT (SnapshotFailure blk) m Bool
forall (m :: * -> *) a.
Monad m =>
m a -> ExceptT (SnapshotFailure blk) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m Bool -> ExceptT (SnapshotFailure blk) m Bool)
-> m Bool -> ExceptT (SnapshotFailure blk) m Bool
forall a b. (a -> b) -> a -> b
$ HasFS m h -> HasCallStack => FsPath -> m Bool
forall (m :: * -> *) h.
HasFS m h -> HasCallStack => FsPath -> m Bool
doesFileExist HasFS m h
hfs FsPath
p
  Monad.unless exists $ throwE (InitFailureRead ReadSnapshotDataCorruption)
  maybeToExceptT (InitFailureRead ReadSnapshotDataCorruption) $
    MaybeT $
      withFile hfs p ReadMode $ \Handle h
h ->
        ( \case
            Maybe Int
Nothing -> Maybe Word64
forall a. Maybe a
Nothing
            Just Int
i ->
              if Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0
                then Maybe Word64
forall a. Maybe a
Nothing
                else Word64 -> Maybe Word64
forall a. a -> Maybe a
Just (Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i)
        )
          (Maybe Int -> Maybe Word64)
-> (ByteString -> Maybe Int) -> ByteString -> Maybe Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int, ByteString) -> Int) -> Maybe (Int, ByteString) -> Maybe Int
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int, ByteString) -> Int
forall a b. (a, b) -> a
fst
          (Maybe (Int, ByteString) -> Maybe Int)
-> (ByteString -> Maybe (Int, ByteString))
-> ByteString
-> Maybe Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Maybe (Int, ByteString)
readInt
          (ByteString -> Maybe (Int, ByteString))
-> (ByteString -> ByteString)
-> ByteString
-> Maybe (Int, ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
toStrict
          (ByteString -> Maybe Word64) -> m ByteString -> m (Maybe Word64)
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
hfs Handle h
h

-- | Delete snapshot from disk and also from the LSM tree database.
implDeleteSnapshotIfTemporary ::
  forall m blk.
  IOLike m =>
  Session m ->
  SomeHasFS m ->
  Tracer m (TraceSnapshotEvent blk) ->
  DiskSnapshot ->
  m ()
implDeleteSnapshotIfTemporary :: forall (m :: * -> *) blk.
IOLike m =>
Session m
-> SomeHasFS m
-> Tracer m (TraceSnapshotEvent blk)
-> DiskSnapshot
-> m ()
implDeleteSnapshotIfTemporary
  Session m
session
  (SomeHasFS HasFS{HasCallStack => FsPath -> m Bool
doesDirectoryExist :: HasCallStack => FsPath -> m Bool
doesDirectoryExist :: forall (m :: * -> *) h.
HasFS m h -> HasCallStack => FsPath -> m Bool
doesDirectoryExist, HasCallStack => FsPath -> m ()
removeDirectoryRecursive :: HasCallStack => FsPath -> m ()
removeDirectoryRecursive :: forall (m :: * -> *) h. HasFS m h -> HasCallStack => FsPath -> m ()
removeDirectoryRecursive})
  Tracer m (TraceSnapshotEvent blk)
tracer
  DiskSnapshot
ss =
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
Monad.when (DiskSnapshot -> Bool
diskSnapshotIsTemporary DiskSnapshot
ss) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
      -- If an exception comes up while trying to delete snapshots we just
      -- swallow it and continue. We don't really care if the snapshot was half
      -- written or whatever, as the running node does not use existing
      -- snapshots.
      (m () -> m (Either SomeException ())) -> [m ()] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
try @m @SomeException) [m ()
deleteState, m ()
deleteLsmTable]
      Tracer m (TraceSnapshotEvent blk) -> TraceSnapshotEvent blk -> m ()
forall (m :: * -> *) a. Monad m => Tracer m a -> a -> m ()
traceWith Tracer m (TraceSnapshotEvent blk)
tracer (DiskSnapshot -> TraceSnapshotEvent blk
forall blk. DiskSnapshot -> TraceSnapshotEvent blk
DeletedSnapshot DiskSnapshot
ss)
   where
    deleteState :: m ()
deleteState = do
      let p :: FsPath
p = DiskSnapshot -> FsPath
snapshotToDirPath DiskSnapshot
ss
      exists <- HasCallStack => FsPath -> m Bool
FsPath -> m Bool
doesDirectoryExist FsPath
p
      Monad.when exists (removeDirectoryRecursive p)

    deleteLsmTable :: m ()
deleteLsmTable =
      Session m -> SnapshotName -> m ()
forall (m :: * -> *). IOLike m => Session m -> SnapshotName -> m ()
LSM.deleteSnapshot
        Session m
session
        ([Char] -> SnapshotName
forall a. IsString a => [Char] -> a
fromString ([Char] -> SnapshotName) -> [Char] -> SnapshotName
forall a b. (a -> b) -> a -> b
$ Word64 -> [Char]
forall a. Show a => a -> [Char]
show (DiskSnapshot -> Word64
dsNumber DiskSnapshot
ss) [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char] -> ShowS -> Maybe [Char] -> [Char]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Char]
"" ([Char]
"_" [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<>) (DiskSnapshot -> Maybe [Char]
dsSuffix DiskSnapshot
ss))

{-------------------------------------------------------------------------------
  Creating the first handle
-------------------------------------------------------------------------------}

-- | 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
  , LSMConstraints LedgerState blk
  , IOLike m
  ) =>
  Tracer m LedgerDBV2Trace ->
  CodecConfig blk ->
  SomeHasFS m ->
  Session m ->
  ExportSnapshot m ->
  LSM.DiskCachePolicy ->
  DiskSnapshot ->
  ExceptT (SnapshotFailure blk) m (StateRef m ExtLedgerState blk, RealPoint blk)
loadSnapshot :: forall blk (m :: * -> *).
(LedgerDbSerialiseConstraints blk, LedgerSupportsProtocol blk,
 LSMConstraints LedgerState blk, IOLike m) =>
Tracer m LedgerDBV2Trace
-> CodecConfig blk
-> SomeHasFS m
-> Session m
-> ExportSnapshot m
-> DiskCachePolicy
-> DiskSnapshot
-> ExceptT
     (SnapshotFailure blk)
     m
     (StateRef m ExtLedgerState blk, RealPoint blk)
loadSnapshot Tracer m LedgerDBV2Trace
tracer CodecConfig blk
ccfg fs :: SomeHasFS m
fs@(SomeHasFS HasFS m h
hfs) Session m
session ExportSnapshot m
exportSnapshot DiskCachePolicy
cachePolicy DiskSnapshot
ds = do
  fileEx <- m Bool -> ExceptT (SnapshotFailure blk) m Bool
forall (m :: * -> *) a.
Monad m =>
m a -> ExceptT (SnapshotFailure blk) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m Bool -> ExceptT (SnapshotFailure blk) m Bool)
-> m Bool -> ExceptT (SnapshotFailure blk) m Bool
forall a b. (a -> b) -> a -> b
$ HasFS m h -> HasCallStack => FsPath -> m Bool
forall (m :: * -> *) h.
HasFS m h -> HasCallStack => FsPath -> m Bool
doesFileExist HasFS m h
hfs (DiskSnapshot -> FsPath
snapshotToDirPath DiskSnapshot
ds)
  Monad.when fileEx $ throwE $ InitFailureRead ReadSnapshotIsLegacy
  snapshotMeta <-
    withExceptT (InitFailureRead . ReadMetadataError (snapshotToMetadataPath ds)) $
      loadSnapshotMetadata fs ds
  Monad.when (snapshotBackend snapshotMeta /= UTxOHDLSMSnapshot) $
    throwE $
      InitFailureRead $
        ReadMetadataError (snapshotToMetadataPath ds) MetadataBackendMismatch
  (extLedgerSt, checksumAsRead) <-
    withExceptT (InitFailureRead . ReadSnapshotFailed) $
      readExtLedgerState fs (decodeDiskExtLedgerState ccfg) decode (snapshotToStatePath ds)
  msz <- readUTxOSizeFile hfs (snapshotToUTxOSizeFilePath ds)
  case pointToWithOriginRealPoint (castPoint (getTip extLedgerSt)) of
    WithOrigin (RealPoint blk)
Origin -> SnapshotFailure blk
-> ExceptT
     (SnapshotFailure blk)
     m
     (StateRef m ExtLedgerState 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 <-
        m (Table m TxInBytes TxOutBytes Void)
-> ExceptT
     (SnapshotFailure blk) m (Table m TxInBytes TxOutBytes Void)
forall (m :: * -> *) a.
Monad m =>
m a -> ExceptT (SnapshotFailure blk) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Table m TxInBytes TxOutBytes Void)
 -> ExceptT
      (SnapshotFailure blk) m (Table m TxInBytes TxOutBytes Void))
-> m (Table m TxInBytes TxOutBytes Void)
-> ExceptT
     (SnapshotFailure blk) m (Table m TxInBytes TxOutBytes Void)
forall a b. (a -> b) -> a -> b
$
          Tracer m EnclosingTimed
-> m (Table m TxInBytes TxOutBytes Void)
-> m (Table m TxInBytes TxOutBytes Void)
forall (m :: * -> *) a.
MonadMonotonicTime m =>
Tracer m EnclosingTimed -> m a -> m a
encloseTimedWith (EnclosingTimed -> LedgerDBV2Trace
TraceLedgerTablesHandleCreateFirst (EnclosingTimed -> LedgerDBV2Trace)
-> Tracer m LedgerDBV2Trace -> Tracer m EnclosingTimed
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
>$< Tracer m LedgerDBV2Trace
tracer) (m (Table m TxInBytes TxOutBytes Void)
 -> m (Table m TxInBytes TxOutBytes Void))
-> m (Table m TxInBytes TxOutBytes Void)
-> m (Table m TxInBytes TxOutBytes Void)
forall a b. (a -> b) -> a -> b
$
            TableConfigOverride
-> Session m
-> SnapshotName
-> SnapshotLabel
-> m (Table m TxInBytes TxOutBytes Void)
forall (m :: * -> *) k v b.
(IOLike m, ResolveValue v) =>
TableConfigOverride
-> Session m -> SnapshotName -> SnapshotLabel -> m (Table m k v b)
LSM.openTableFromSnapshotWith
              TableConfigOverride
LSM.noTableConfigOverride{LSM.overrideDiskCachePolicy = Just cachePolicy}
              Session m
session
              ([Char] -> SnapshotName
forall a. IsString a => [Char] -> a
fromString ([Char] -> SnapshotName) -> [Char] -> SnapshotName
forall a b. (a -> b) -> a -> b
$ DiskSnapshot -> [Char]
snapshotToDirName DiskSnapshot
ds)
              (Text -> SnapshotLabel
LSM.SnapshotLabel (Text -> SnapshotLabel) -> Text -> SnapshotLabel
forall a b. (a -> b) -> a -> b
$ [Char] -> Text
Text.pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ [Char]
"UTxO table")

      h <- lift $ newLSMLedgerTablesHandle tracer exportSnapshot msz values
      Monad.when
        (checksumAsRead /= snapshotChecksum snapshotMeta)
        $ throwE
        $ InitFailureRead
          ReadSnapshotDataCorruption
      pure (StateRef extLedgerSt h, pt)

-- | Create the initial LSM table from values, which should happen only at
-- Genesis.
tableFromValuesMK ::
  forall m l blk.
  ( IOLike m
  , LSMConstraints l blk
  ) =>
  Tracer m LedgerDBV2Trace ->
  Session m ->
  LSM.DiskCachePolicy ->
  l blk EmptyMK ->
  LedgerTables blk ValuesMK ->
  m (UTxOTable m, Word64)
tableFromValuesMK :: forall (m :: * -> *) (l :: * -> (* -> * -> *) -> *) blk.
(IOLike m, LSMConstraints l blk) =>
Tracer m LedgerDBV2Trace
-> Session m
-> DiskCachePolicy
-> l blk EmptyMK
-> LedgerTables blk ValuesMK
-> m (UTxOTable m, Word64)
tableFromValuesMK Tracer m LedgerDBV2Trace
tracer Session m
session DiskCachePolicy
cachePolicy l blk EmptyMK
st (LedgerTables (ValuesMK Map (TxIn blk) (TxOut blk)
values)) = do
  table <-
    Tracer m EnclosingTimed
-> m (Table m TxInBytes TxOutBytes Void)
-> m (Table m TxInBytes TxOutBytes Void)
forall (m :: * -> *) a.
MonadMonotonicTime m =>
Tracer m EnclosingTimed -> m a -> m a
encloseTimedWith (EnclosingTimed -> LedgerDBV2Trace
TraceLedgerTablesHandleCreateFirst (EnclosingTimed -> LedgerDBV2Trace)
-> Tracer m LedgerDBV2Trace -> Tracer m EnclosingTimed
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
>$< Tracer m LedgerDBV2Trace
tracer) (m (Table m TxInBytes TxOutBytes Void)
 -> m (Table m TxInBytes TxOutBytes Void))
-> m (Table m TxInBytes TxOutBytes Void)
-> m (Table m TxInBytes TxOutBytes Void)
forall a b. (a -> b) -> a -> b
$
      TableConfig -> Session m -> m (Table m TxInBytes TxOutBytes Void)
forall (m :: * -> *) k v b.
IOLike m =>
TableConfig -> Session m -> m (Table m k v b)
LSM.newTableWith (TableConfig
LSM.defaultTableConfig{LSM.confDiskCachePolicy = cachePolicy}) Session m
session
  mapM_ (go table) $ chunks 1000 $ Map.toList values
  pure (table, fromIntegral $ Map.size values)
 where
  go :: Table m TxInBytes TxOutBytes Void
-> [(TxIn blk, TxOut blk)] -> m ()
go Table m TxInBytes TxOutBytes Void
table [(TxIn blk, TxOut blk)]
items =
    Table m TxInBytes TxOutBytes Void
-> Vector (TxInBytes, TxOutBytes, Maybe Void) -> m ()
forall (m :: * -> *) k v b.
(IOLike m, SerialiseKey k, SerialiseValue v, ResolveValue v,
 SerialiseValue b) =>
Table m k v b -> Vector (k, v, Maybe b) -> m ()
LSM.inserts Table m TxInBytes TxOutBytes Void
table (Vector (TxInBytes, TxOutBytes, Maybe Void) -> m ())
-> Vector (TxInBytes, TxOutBytes, Maybe Void) -> m ()
forall a b. (a -> b) -> a -> b
$
      Int
-> [(TxInBytes, TxOutBytes, Maybe Void)]
-> Vector (TxInBytes, TxOutBytes, Maybe Void)
forall a. Int -> [a] -> Vector a
V.fromListN ([(TxIn blk, TxOut blk)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(TxIn blk, TxOut blk)]
items) ([(TxInBytes, TxOutBytes, Maybe Void)]
 -> Vector (TxInBytes, TxOutBytes, Maybe Void))
-> [(TxInBytes, TxOutBytes, Maybe Void)]
-> Vector (TxInBytes, TxOutBytes, Maybe Void)
forall a b. (a -> b) -> a -> b
$
        ((TxIn blk, TxOut blk) -> (TxInBytes, TxOutBytes, Maybe Void))
-> [(TxIn blk, TxOut blk)] -> [(TxInBytes, TxOutBytes, Maybe Void)]
forall a b. (a -> b) -> [a] -> [b]
map (\(TxIn blk
k, TxOut blk
v) -> (Proxy blk -> TxIn blk -> TxInBytes
forall blk.
MemPack (TxIn blk) =>
Proxy blk -> TxIn blk -> TxInBytes
toTxInBytes (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @blk) TxIn blk
k, l blk EmptyMK -> TxOut blk -> TxOutBytes
forall (l :: * -> (* -> * -> *) -> *) blk.
IndexedMemPack l blk (TxOut blk) =>
l blk EmptyMK -> TxOut blk -> TxOutBytes
toTxOutBytes l blk EmptyMK
st TxOut blk
v, Maybe Void
forall a. Maybe a
Nothing)) [(TxIn blk, TxOut blk)]
items

{-------------------------------------------------------------------------------
  Helpers
-------------------------------------------------------------------------------}

stdMkBlockIOFS ::
  FilePath -> WithTempRegistry st IO (SomeHasFSAndBlockIO IO)
stdMkBlockIOFS :: forall st.
[Char] -> WithTempRegistry st IO (SomeHasFSAndBlockIO IO)
stdMkBlockIOFS [Char]
fastStoragePath = do
  (HasFS IO HandleIO
 -> HasBlockIO IO HandleIO -> SomeHasFSAndBlockIO IO)
-> (HasFS IO HandleIO, HasBlockIO IO HandleIO)
-> SomeHasFSAndBlockIO IO
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry HasFS IO HandleIO
-> HasBlockIO IO HandleIO -> SomeHasFSAndBlockIO IO
forall h (m :: * -> *).
(Eq h, Typeable h) =>
HasFS m h -> HasBlockIO m h -> SomeHasFSAndBlockIO m
SomeHasFSAndBlockIO
    ((HasFS IO HandleIO, HasBlockIO IO HandleIO)
 -> SomeHasFSAndBlockIO IO)
-> WithTempRegistry
     st IO (HasFS IO HandleIO, HasBlockIO IO HandleIO)
-> WithTempRegistry st IO (SomeHasFSAndBlockIO IO)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (HasFS IO HandleIO, HasBlockIO IO HandleIO)
-> ((HasFS IO HandleIO, HasBlockIO IO HandleIO) -> IO Bool)
-> (st -> (HasFS IO HandleIO, HasBlockIO IO HandleIO) -> Bool)
-> WithTempRegistry
     st IO (HasFS IO HandleIO, HasBlockIO IO HandleIO)
forall (m :: * -> *) a st.
(MonadSTM m, MonadMask m, MonadThread m, MonadEvaluate m,
 HasCallStack) =>
m a
-> (a -> m Bool) -> (st -> a -> Bool) -> WithTempRegistry st m a
allocateTemp
      (MountPoint
-> IOCtxParams -> IO (HasFS IO HandleIO, HasBlockIO IO HandleIO)
ioHasBlockIO ([Char] -> MountPoint
MountPoint [Char]
fastStoragePath) IOCtxParams
defaultIOCtxParams)
      (\(HasFS IO HandleIO
_, HasBlockIO IO HandleIO
bio) -> HasBlockIO IO HandleIO -> HasCallStack => IO ()
forall (m :: * -> *) h. HasBlockIO m h -> HasCallStack => m ()
BIO.close HasBlockIO IO HandleIO
bio IO () -> IO Bool -> IO Bool
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True)
      st -> (HasFS IO HandleIO, HasBlockIO IO HandleIO) -> Bool
forall a b. a -> b -> Bool
impossibleToNotTransfer

{-------------------------------------------------------------------------------
  Backend
-------------------------------------------------------------------------------}

type data LSM

-- | Create arguments for initializing the LedgerDB using the LSM-trees backend.
mkLSMArgsIO ::
  ( LedgerSupportsProtocol blk
  , LedgerDbSerialiseConstraints blk
  ) =>
  Proxy blk ->
  -- | LSM database path, relative to the FS root.
  FilePath ->
  -- | LSM export path, relative to the FS root.
  Maybe FilePath ->
  -- | Root for the LSM filesystem.
  FilePath ->
  -- | Disk cache policy for the UTxO table, see 'LSM.DiskCachePolicy'.
  LSM.DiskCachePolicy ->
  StdGen ->
  (LedgerDbBackendArgs IO blk, StdGen)
mkLSMArgsIO :: forall blk.
(LedgerSupportsProtocol blk, LedgerDbSerialiseConstraints blk) =>
Proxy blk
-> [Char]
-> Maybe [Char]
-> [Char]
-> DiskCachePolicy
-> StdGen
-> (LedgerDbBackendArgs IO blk, StdGen)
mkLSMArgsIO Proxy blk
_ [Char]
fpDb Maybe [Char]
fpExport [Char]
fastStorage DiskCachePolicy
cachePolicy StdGen
gen =
  let (Word64
lsmSalt, StdGen
gen') = StdGen -> (Word64, StdGen)
forall g. RandomGen g => g -> (Word64, g)
genWord64 StdGen
gen
   in ( SomeBackendArgs IO blk -> LedgerDbBackendArgs IO blk
forall (m :: * -> *) blk.
SomeBackendArgs m blk -> LedgerDbBackendArgs m blk
LedgerDbBackendArgsV2 (SomeBackendArgs IO blk -> LedgerDbBackendArgs IO blk)
-> SomeBackendArgs IO blk -> LedgerDbBackendArgs IO blk
forall a b. (a -> b) -> a -> b
$
          Args IO LSM -> SomeBackendArgs IO blk
forall (m :: * -> *) backend blk.
Backend m backend blk =>
Args m backend -> SomeBackendArgs m blk
SomeBackendArgs (Args IO LSM -> SomeBackendArgs IO blk)
-> Args IO LSM -> SomeBackendArgs IO blk
forall a b. (a -> b) -> a -> b
$
            FsPath
-> Maybe FsPath
-> Word64
-> DiskCachePolicy
-> (forall st. WithTempRegistry st IO (SomeHasFSAndBlockIO IO))
-> Args IO LSM
forall (m :: * -> *).
FsPath
-> Maybe FsPath
-> Word64
-> DiskCachePolicy
-> (forall st. WithTempRegistry st m (SomeHasFSAndBlockIO m))
-> Args m LSM
LSMArgs
              (Context -> FsPath
mkFsPath (Context -> FsPath) -> Context -> FsPath
forall a b. (a -> b) -> a -> b
$ [Char] -> Context
splitDirectories [Char]
fpDb)
              (([Char] -> FsPath) -> Maybe [Char] -> Maybe FsPath
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Context -> FsPath
mkFsPath (Context -> FsPath) -> ([Char] -> Context) -> [Char] -> FsPath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Context
splitDirectories) Maybe [Char]
fpExport)
              Word64
lsmSalt
              DiskCachePolicy
cachePolicy
              ([Char] -> WithTempRegistry st IO (SomeHasFSAndBlockIO IO)
forall st.
[Char] -> WithTempRegistry st IO (SomeHasFSAndBlockIO IO)
stdMkBlockIOFS [Char]
fastStorage)
      , StdGen
gen'
      )

instance
  ( LedgerSupportsProtocol blk
  , IOLike m
  , LedgerDbSerialiseConstraints blk
  , HasLedgerTables LedgerState blk
  ) =>
  Backend m LSM blk
  where
  data Args m LSM
    = LSMArgs
        FsPath
        -- \^ The file path relative to the fast storage directory in which the LSM
        -- trees database will be located.
        (Maybe FsPath)
        -- \^ The file path relative to the fast storage directory in which the LSM
        -- trees database will dump its exports.
        Salt
        LSM.DiskCachePolicy
        -- \^ The disk cache policy to use for UTxO table reads/writes.
        (forall st. WithTempRegistry st m (SomeHasFSAndBlockIO m))

  data Resources m LSM = LSMResources
    { forall (m :: * -> *). Resources m LSM -> Session m
sessionResource :: !(Session m)
    , forall (m :: * -> *). Resources m LSM -> ExportSnapshot m
exportSnapshotResource :: !(ExportSnapshot m)
    , forall (m :: * -> *). Resources m LSM -> SomeHasFSAndBlockIO m
someHasFSAndBlockIO :: !(SomeHasFSAndBlockIO m)
    , forall (m :: * -> *). Resources m LSM -> DiskCachePolicy
cachePolicyResource :: !LSM.DiskCachePolicy
    }
    deriving (forall x. Resources m LSM -> Rep (Resources m LSM) x)
-> (forall x. Rep (Resources m LSM) x -> Resources m LSM)
-> Generic (Resources m LSM)
forall x. Rep (Resources m LSM) x -> Resources m LSM
forall x. Resources m LSM -> Rep (Resources m LSM) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (m :: * -> *) x. Rep (Resources m LSM) x -> Resources m LSM
forall (m :: * -> *) x. Resources m LSM -> Rep (Resources m LSM) x
$cfrom :: forall (m :: * -> *) x. Resources m LSM -> Rep (Resources m LSM) x
from :: forall x. Resources m LSM -> Rep (Resources m LSM) x
$cto :: forall (m :: * -> *) x. Rep (Resources m LSM) x -> Resources m LSM
to :: forall x. Rep (Resources m LSM) x -> Resources m LSM
Generic

  data Trace LSM
    = LSMTreeTrace !LSM.LSMTreeTrace
    | LSMLookup EnclosingTimed
    | LSMUpdate EnclosingTimed
    | LSMSnap EnclosingTimed
    | LSMOpenSession EnclosingTimed
    deriving Int -> Trace LSM -> ShowS
[Trace LSM] -> ShowS
Trace LSM -> [Char]
(Int -> Trace LSM -> ShowS)
-> (Trace LSM -> [Char])
-> ([Trace LSM] -> ShowS)
-> Show (Trace LSM)
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Trace LSM -> ShowS
showsPrec :: Int -> Trace LSM -> ShowS
$cshow :: Trace LSM -> [Char]
show :: Trace LSM -> [Char]
$cshowList :: [Trace LSM] -> ShowS
showList :: [Trace LSM] -> ShowS
Show

  mkResources :: forall fState.
Proxy blk
-> Tracer m LedgerDBV2Trace
-> Args m LSM
-> SomeHasFS m
-> WithTempRegistry fState m (Resources m LSM)
mkResources Proxy blk
_ Tracer m LedgerDBV2Trace
trcr (LSMArgs FsPath
pathDb Maybe FsPath
pathExp Word64
salt DiskCachePolicy
cachePolicy forall st. WithTempRegistry st m (SomeHasFSAndBlockIO m)
mkFS) SomeHasFS m
_ = do
    sblockio@(SomeHasFSAndBlockIO fs blockio) <- WithTempRegistry fState m (SomeHasFSAndBlockIO m)
forall st. WithTempRegistry st m (SomeHasFSAndBlockIO m)
mkFS
    lift $ createDirectoryIfMissing fs True pathDb
    whenJust pathExp (lift . createDirectoryIfMissing fs True)
    session <-
      allocateTemp
        ( encloseTimedWith (BackendTrace . SomeBackendTrace . LSMOpenSession >$< trcr) $
            LSM.openSession
              (BackendTrace . SomeBackendTrace . LSMTreeTrace >$< trcr)
              fs
              blockio
              salt
              pathDb
        )
        (\Session m
s -> Session m -> m ()
forall (m :: * -> *). IOLike m => Session m -> m ()
LSM.closeSession Session m
s m () -> m Bool -> m Bool
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> m Bool
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True)
        impossibleToNotTransfer
    let exportSnap = case Maybe FsPath
pathExp of
          Maybe FsPath
Nothing -> m () -> SnapshotName -> m ()
forall a b. a -> b -> a
const (() -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
          Just FsPath
p -> \SnapshotName
snap -> Session m -> SnapshotName -> FsPath -> m ()
forall (m :: * -> *).
IOLike m =>
Session m -> SnapshotName -> FsPath -> m ()
LSM.exportSnapshot Session m
session SnapshotName
snap FsPath
p
    pure (LSMResources session exportSnap sblockio cachePolicy)

  releaseResources :: Proxy blk -> Resources m LSM -> m ()
releaseResources Proxy blk
_ (LSMResources Session m
session SnapshotName -> m ()
_ (SomeHasFSAndBlockIO HasFS m h
_ HasBlockIO m h
blockio) DiskCachePolicy
_) = do
    Session m -> m ()
forall (m :: * -> *). IOLike m => Session m -> m ()
LSM.closeSession Session m
session
    HasBlockIO m h -> HasCallStack => m ()
forall (m :: * -> *) h. HasBlockIO m h -> HasCallStack => m ()
BIO.close HasBlockIO m h
blockio

  openStateRefFromSnapshot :: Tracer m LedgerDBV2Trace
-> CodecConfig blk
-> SomeHasFS m
-> Resources m LSM
-> DiskSnapshot
-> ExceptT
     (SnapshotFailure blk)
     m
     (StateRef m ExtLedgerState blk, RealPoint blk)
openStateRefFromSnapshot Tracer m LedgerDBV2Trace
trcr CodecConfig blk
ccfg SomeHasFS m
shfs Resources m LSM
res DiskSnapshot
ds = do
    Tracer m LedgerDBV2Trace
-> CodecConfig blk
-> SomeHasFS m
-> Session m
-> (SnapshotName -> m ())
-> DiskCachePolicy
-> DiskSnapshot
-> ExceptT
     (SnapshotFailure blk)
     m
     (StateRef m ExtLedgerState blk, RealPoint blk)
forall blk (m :: * -> *).
(LedgerDbSerialiseConstraints blk, LedgerSupportsProtocol blk,
 LSMConstraints LedgerState blk, IOLike m) =>
Tracer m LedgerDBV2Trace
-> CodecConfig blk
-> SomeHasFS m
-> Session m
-> ExportSnapshot m
-> DiskCachePolicy
-> DiskSnapshot
-> ExceptT
     (SnapshotFailure blk)
     m
     (StateRef m ExtLedgerState blk, RealPoint blk)
loadSnapshot
      Tracer m LedgerDBV2Trace
trcr
      CodecConfig blk
ccfg
      SomeHasFS m
shfs
      (Resources m LSM -> Session m
forall (m :: * -> *). Resources m LSM -> Session m
sessionResource Resources m LSM
res)
      (Resources m LSM -> SnapshotName -> m ()
forall (m :: * -> *). Resources m LSM -> ExportSnapshot m
exportSnapshotResource Resources m LSM
res)
      (Resources m LSM -> DiskCachePolicy
forall (m :: * -> *). Resources m LSM -> DiskCachePolicy
cachePolicyResource Resources m LSM
res)
      DiskSnapshot
ds

  createAndPopulateStateRefFromGenesis :: Tracer m LedgerDBV2Trace
-> Resources m LSM
-> ExtLedgerState blk ValuesMK
-> m (StateRef m ExtLedgerState blk)
createAndPopulateStateRefFromGenesis Tracer m LedgerDBV2Trace
trcr Resources m LSM
res ExtLedgerState blk ValuesMK
st = do
    let st' :: ExtLedgerState blk EmptyMK
st' = ExtLedgerState blk ValuesMK -> ExtLedgerState blk EmptyMK
forall (l :: * -> (* -> * -> *) -> *) blk (mk :: * -> * -> *).
HasLedgerTables l blk =>
l blk mk -> l blk EmptyMK
forgetLedgerTables ExtLedgerState blk ValuesMK
st
    (table, sz) <-
      Tracer m LedgerDBV2Trace
-> Session m
-> DiskCachePolicy
-> ExtLedgerState blk EmptyMK
-> LedgerTables blk ValuesMK
-> m (UTxOTable m, Word64)
forall (m :: * -> *) (l :: * -> (* -> * -> *) -> *) blk.
(IOLike m, LSMConstraints l blk) =>
Tracer m LedgerDBV2Trace
-> Session m
-> DiskCachePolicy
-> l blk EmptyMK
-> LedgerTables blk ValuesMK
-> m (UTxOTable m, Word64)
tableFromValuesMK Tracer m LedgerDBV2Trace
trcr (Resources m LSM -> Session m
forall (m :: * -> *). Resources m LSM -> Session m
sessionResource Resources m LSM
res) (Resources m LSM -> DiskCachePolicy
forall (m :: * -> *). Resources m LSM -> DiskCachePolicy
cachePolicyResource Resources m LSM
res) ExtLedgerState blk EmptyMK
st' (ExtLedgerState blk ValuesMK -> LedgerTables blk ValuesMK
forall (l :: * -> (* -> * -> *) -> *) blk (mk :: * -> * -> *).
(HasLedgerTables l blk, CanMapMK mk, CanMapKeysMK mk,
 ZeroableMK mk) =>
l blk mk -> LedgerTables blk mk
ltprj ExtLedgerState blk ValuesMK
st)
    StateRef st' <$> newLSMLedgerTablesHandle trcr (exportSnapshotResource res) sz table

  snapshotManager :: Proxy blk
-> Resources m LSM
-> CodecConfig blk
-> Tracer m (TraceSnapshotEvent blk)
-> SomeHasFS m
-> SnapshotManager m blk (StateRef m ExtLedgerState blk)
snapshotManager Proxy blk
_ Resources m LSM
res = Session m
-> CodecConfig blk
-> Tracer m (TraceSnapshotEvent blk)
-> SomeHasFS m
-> SnapshotManager m blk (StateRef m ExtLedgerState blk)
forall (m :: * -> *) blk.
(IOLike m, LedgerDbSerialiseConstraints blk,
 LedgerSupportsProtocol blk) =>
Session m
-> CodecConfig blk
-> Tracer m (TraceSnapshotEvent blk)
-> SomeHasFS m
-> SnapshotManager m blk (StateRef m ExtLedgerState blk)
Ouroboros.Consensus.Storage.LedgerDB.V2.LSM.snapshotManager (Resources m LSM -> Session m
forall (m :: * -> *). Resources m LSM -> Session m
sessionResource Resources m LSM
res)

instance
  ( LSMConstraints l blk
  , IOLike m
  ) =>
  StreamingBackend m LSM l blk
  where
  data YieldArgs m LSM l blk
    = -- \| Yield an LSM snapshot
      YieldLSM
        Int
        (LedgerTablesHandle m l blk)
        -- \| Only to be closed by 'releaseYieldArgs'
        (Session m)
        -- \| Only to be closed by 'releaseYieldArgs'
        (SomeHasFSAndBlockIO m)
        -- \| Cleanup hook run by 'releaseYieldArgs' /after/ the session has been
        -- closed. Used to remove the temporary scratch session created when
        -- yielding from a standalone (exported) snapshot. 'pure ()' for a plain
        -- database yield.
        (m ())

  data SinkArgs m LSM l blk
    = SinkLSM
        -- \| Chunk size
        Int
        -- \| LedgerDB snapshot fs
        (SomeHasFS m)
        -- \| Only to be closed by 'releaseSinkArgs'
        (SomeHasFSAndBlockIO m)
        -- \| DiskSnapshot
        DiskSnapshot
        (Session m)
        -- \| \"After save\" hook, run by 'sink' /while the session is still
        -- open/, right after the snapshot has been saved into it. Used to
        -- export the freshly saved snapshot to a standalone directory. 'pure ()'
        -- for a plain database sink.
        (m ())
        -- \| Cleanup hook run by 'releaseSinkArgs' /after/ the session has been
        -- closed. Used to remove the temporary scratch session created when
        -- sinking to a standalone (exported) snapshot. 'pure ()' for a plain
        -- database sink.
        (m ())

  releaseYieldArgs :: YieldArgs m LSM l blk -> m ()
releaseYieldArgs (YieldLSM Int
_ LedgerTablesHandle m l blk
hdl Session m
session (SomeHasFSAndBlockIO HasFS m h
_ HasBlockIO m h
bio) m ()
cleanup) = do
    LedgerTablesHandle m l blk -> m ()
forall (m :: * -> *) (l :: * -> (* -> * -> *) -> *) blk.
LedgerTablesHandle m l blk -> m ()
close LedgerTablesHandle m l blk
hdl
    Session m -> m ()
forall (m :: * -> *). IOLike m => Session m -> m ()
LSM.closeSession Session m
session
    m ()
cleanup
    HasBlockIO m h -> HasCallStack => m ()
forall (m :: * -> *) h. HasBlockIO m h -> HasCallStack => m ()
BIO.close HasBlockIO m h
bio

  releaseSinkArgs :: SinkArgs m LSM l blk -> m ()
releaseSinkArgs (SinkLSM Int
_ SomeHasFS m
_ (SomeHasFSAndBlockIO HasFS m h
_ HasBlockIO m h
bio) DiskSnapshot
_ Session m
session m ()
_afterSave m ()
cleanup) = do
    Session m -> m ()
forall (m :: * -> *). IOLike m => Session m -> m ()
LSM.closeSession Session m
session
    m ()
cleanup
    HasBlockIO m h -> HasCallStack => m ()
forall (m :: * -> *) h. HasBlockIO m h -> HasCallStack => m ()
BIO.close HasBlockIO m h
bio

  yield :: Proxy LSM -> YieldArgs m LSM l blk -> Yield m l blk
yield Proxy LSM
_ (YieldLSM Int
chunkSize LedgerTablesHandle m l blk
hdl Session m
_ SomeHasFSAndBlockIO m
_ m ()
_) = Int -> LedgerTablesHandle m l blk -> Yield m l blk
forall (m :: * -> *) (l :: * -> (* -> * -> *) -> *) blk.
Monad m =>
Int -> LedgerTablesHandle m l blk -> Yield m l blk
yieldLsmS Int
chunkSize LedgerTablesHandle m l blk
hdl

  sink :: Proxy LSM -> SinkArgs m LSM l blk -> Sink m l blk
sink Proxy LSM
_ (SinkLSM Int
chunkSize SomeHasFS m
shfs SomeHasFSAndBlockIO m
_ DiskSnapshot
ds Session m
session m ()
afterSave m ()
_cleanup) =
    Int
-> SomeHasFS m -> DiskSnapshot -> Session m -> m () -> Sink m l blk
forall (m :: * -> *) (l :: * -> (* -> * -> *) -> *) blk.
(MonadAsync m, MonadMVar m, MonadThrow (STM m), MonadMask m,
 MonadST m, MonadEvaluate m, LSMConstraints l blk) =>
Int
-> SomeHasFS m -> DiskSnapshot -> Session m -> m () -> Sink m l blk
sinkLsmS Int
chunkSize SomeHasFS m
shfs DiskSnapshot
ds Session m
session m ()
afterSave

data SomeHasFSAndBlockIO m where
  SomeHasFSAndBlockIO ::
    (Eq h, Typeable h) => HasFS m h -> BIO.HasBlockIO m h -> SomeHasFSAndBlockIO m

instance IOLike m => NoThunks (Resources m LSM) where
  wNoThunks :: Context -> Resources m LSM -> IO (Maybe ThunkInfo)
wNoThunks Context
_ (LSMResources Session m
_ ExportSnapshot m
_ (SomeHasFSAndBlockIO HasFS m h
_ HasBlockIO m h
_) DiskCachePolicy
_) = Maybe ThunkInfo -> IO (Maybe ThunkInfo)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe ThunkInfo
forall a. Maybe a
Nothing

{-------------------------------------------------------------------------------
  Streaming
-------------------------------------------------------------------------------}

yieldLsmS ::
  Monad m =>
  Int ->
  LedgerTablesHandle m l blk ->
  Yield m l blk
yieldLsmS :: forall (m :: * -> *) (l :: * -> (* -> * -> *) -> *) blk.
Monad m =>
Int -> LedgerTablesHandle m l blk -> Yield m l blk
yieldLsmS Int
readChunkSize LedgerTablesHandle m l blk
tb l blk EmptyMK
hint Stream
  (Of (TxIn blk, TxOut blk))
  (ExceptT DeserialiseFailure m)
  (Stream (Of ByteString) m (Maybe CRC))
-> ExceptT
     DeserialiseFailure
     m
     (Stream (Of ByteString) m (Maybe CRC, Maybe CRC))
k = do
  r <- Stream
  (Of (TxIn blk, TxOut blk))
  (ExceptT DeserialiseFailure m)
  (Stream (Of ByteString) m (Maybe CRC))
-> ExceptT
     DeserialiseFailure
     m
     (Stream (Of ByteString) m (Maybe CRC, Maybe CRC))
k ((Maybe (TxIn blk), Int)
-> Stream
     (Of (TxIn blk, TxOut blk))
     (ExceptT DeserialiseFailure m)
     (Stream (Of ByteString) m (Maybe CRC))
go (Maybe (TxIn blk)
forall a. Maybe a
Nothing, Int
readChunkSize))
  lift $ S.effects r
 where
  go :: (Maybe (TxIn blk), Int)
-> Stream
     (Of (TxIn blk, TxOut blk))
     (ExceptT DeserialiseFailure m)
     (Stream (Of ByteString) m (Maybe CRC))
go (Maybe (TxIn blk), Int)
p = do
    (LedgerTables (ValuesMK values), mx) <- ExceptT
  DeserialiseFailure m (LedgerTables blk ValuesMK, Maybe (TxIn blk))
-> Stream
     (Of (TxIn blk, TxOut blk))
     (ExceptT DeserialiseFailure m)
     (LedgerTables blk ValuesMK, Maybe (TxIn blk))
forall (m :: * -> *) a.
Monad m =>
m a -> Stream (Of (TxIn blk, TxOut blk)) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ExceptT
   DeserialiseFailure m (LedgerTables blk ValuesMK, Maybe (TxIn blk))
 -> Stream
      (Of (TxIn blk, TxOut blk))
      (ExceptT DeserialiseFailure m)
      (LedgerTables blk ValuesMK, Maybe (TxIn blk)))
-> ExceptT
     DeserialiseFailure m (LedgerTables blk ValuesMK, Maybe (TxIn blk))
-> Stream
     (Of (TxIn blk, TxOut blk))
     (ExceptT DeserialiseFailure m)
     (LedgerTables blk ValuesMK, Maybe (TxIn blk))
forall a b. (a -> b) -> a -> b
$ m (LedgerTables blk ValuesMK, Maybe (TxIn blk))
-> ExceptT
     DeserialiseFailure m (LedgerTables blk ValuesMK, Maybe (TxIn blk))
forall (m :: * -> *) a.
Monad m =>
m a -> ExceptT DeserialiseFailure m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
S.lift (m (LedgerTables blk ValuesMK, Maybe (TxIn blk))
 -> ExceptT
      DeserialiseFailure m (LedgerTables blk ValuesMK, Maybe (TxIn blk)))
-> m (LedgerTables blk ValuesMK, Maybe (TxIn blk))
-> ExceptT
     DeserialiseFailure m (LedgerTables blk ValuesMK, Maybe (TxIn blk))
forall a b. (a -> b) -> a -> b
$ LedgerTablesHandle m l blk
-> l blk EmptyMK
-> (Maybe (TxIn blk), Int)
-> m (LedgerTables blk ValuesMK, Maybe (TxIn blk))
forall (m :: * -> *) (l :: * -> (* -> * -> *) -> *) blk.
LedgerTablesHandle m l blk
-> l blk EmptyMK
-> (Maybe (TxIn blk), Int)
-> m (LedgerTables blk ValuesMK, Maybe (TxIn blk))
readRange LedgerTablesHandle m l blk
tb l blk EmptyMK
hint (Maybe (TxIn blk), Int)
p
    if Map.null values
      then pure $ pure Nothing
      else do
        S.each $ Map.toList values
        go (mx, readChunkSize)

sinkLsmS ::
  forall m l blk.
  ( MonadAsync m
  , MonadMVar m
  , MonadThrow (STM m)
  , MonadMask m
  , MonadST m
  , MonadEvaluate m
  , LSMConstraints l blk
  ) =>
  Int ->
  SomeHasFS m ->
  DiskSnapshot ->
  Session m ->
  -- | \"After save\" hook, run while the session is still open, right after the
  -- snapshot has been saved into it.
  m () ->
  Sink m l blk
sinkLsmS :: forall (m :: * -> *) (l :: * -> (* -> * -> *) -> *) blk.
(MonadAsync m, MonadMVar m, MonadThrow (STM m), MonadMask m,
 MonadST m, MonadEvaluate m, LSMConstraints l blk) =>
Int
-> SomeHasFS m -> DiskSnapshot -> Session m -> m () -> Sink m l blk
sinkLsmS Int
writeChunkSize (SomeHasFS HasFS m h
hfs) DiskSnapshot
ds Session m
session m ()
afterSave l blk EmptyMK
st Stream
  (Of (TxIn blk, TxOut blk))
  (ExceptT DeserialiseFailure m)
  (Stream (Of ByteString) m (Maybe CRC))
stream = do
  r <-
    ExceptT DeserialiseFailure m (Table m TxInBytes TxOutBytes Void)
-> (Table m TxInBytes TxOutBytes Void
    -> ExceptT DeserialiseFailure m ())
-> (Table m TxInBytes TxOutBytes Void
    -> ExceptT
         DeserialiseFailure m (Stream (Of ByteString) m (Maybe CRC)))
-> ExceptT
     DeserialiseFailure m (Stream (Of ByteString) m (Maybe CRC))
forall a b c.
ExceptT DeserialiseFailure m a
-> (a -> ExceptT DeserialiseFailure m b)
-> (a -> ExceptT DeserialiseFailure m c)
-> ExceptT DeserialiseFailure m c
forall (m :: * -> *) a b c.
MonadThrow m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket
      (m (Table m TxInBytes TxOutBytes Void)
-> ExceptT DeserialiseFailure m (Table m TxInBytes TxOutBytes Void)
forall (m :: * -> *) a.
Monad m =>
m a -> ExceptT DeserialiseFailure m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Table m TxInBytes TxOutBytes Void)
 -> ExceptT
      DeserialiseFailure m (Table m TxInBytes TxOutBytes Void))
-> m (Table m TxInBytes TxOutBytes Void)
-> ExceptT DeserialiseFailure m (Table m TxInBytes TxOutBytes Void)
forall a b. (a -> b) -> a -> b
$ Session m -> m (Table m TxInBytes TxOutBytes Void)
forall (m :: * -> *) k v b.
IOLike m =>
Session m -> m (Table m k v b)
LSM.newTable Session m
session)
      (m () -> ExceptT DeserialiseFailure m ()
forall (m :: * -> *) a.
Monad m =>
m a -> ExceptT DeserialiseFailure m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> ExceptT DeserialiseFailure m ())
-> (Table m TxInBytes TxOutBytes Void -> m ())
-> Table m TxInBytes TxOutBytes Void
-> ExceptT DeserialiseFailure m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Table m TxInBytes TxOutBytes Void -> m ()
forall (m :: * -> *) k v b. IOLike m => Table m k v b -> m ()
LSM.closeTable)
      ( \Table m TxInBytes TxOutBytes Void
lsmTable -> do
          (r, utxosSize) <- Int
-> Table m TxInBytes TxOutBytes Void
-> Int
-> [(TxIn blk, TxOut blk)]
-> Stream
     (Of (TxIn blk, TxOut blk))
     (ExceptT DeserialiseFailure m)
     (Stream (Of ByteString) m (Maybe CRC))
-> ExceptT
     DeserialiseFailure m (Stream (Of ByteString) m (Maybe CRC), Int)
go (Int
0 :: Int) Table m TxInBytes TxOutBytes Void
lsmTable Int
writeChunkSize [(TxIn blk, TxOut blk)]
forall a. Monoid a => a
mempty Stream
  (Of (TxIn blk, TxOut blk))
  (ExceptT DeserialiseFailure m)
  (Stream (Of ByteString) m (Maybe CRC))
stream
          lift $
            LSM.saveSnapshot
              (LSM.toSnapshotName (snapshotToDirName ds))
              (LSM.SnapshotLabel $ T.pack "UTxO table")
              lsmTable
          lift $ writeUTxOSizeFile hfs (snapshotToUTxOSizeFilePath ds) utxosSize
          lift afterSave
          pure r
      )
  pure (fmap (,Nothing) r)
 where
  writeToTable :: UTxOTable m -> [(TxIn blk, TxOut blk)] -> m ()
  writeToTable :: Table m TxInBytes TxOutBytes Void
-> [(TxIn blk, TxOut blk)] -> m ()
writeToTable Table m TxInBytes TxOutBytes Void
lsmTable [(TxIn blk, TxOut blk)]
accUTxOs =
    Table m TxInBytes TxOutBytes Void
-> Vector (TxInBytes, TxOutBytes, Maybe Void) -> m ()
forall (m :: * -> *) k v b.
(IOLike m, SerialiseKey k, SerialiseValue v, ResolveValue v,
 SerialiseValue b) =>
Table m k v b -> Vector (k, v, Maybe b) -> m ()
LSM.inserts Table m TxInBytes TxOutBytes Void
lsmTable (Vector (TxInBytes, TxOutBytes, Maybe Void) -> m ())
-> Vector (TxInBytes, TxOutBytes, Maybe Void) -> m ()
forall a b. (a -> b) -> a -> b
$
      [(TxInBytes, TxOutBytes, Maybe Void)]
-> Vector (TxInBytes, TxOutBytes, Maybe Void)
forall a. [a] -> Vector a
V.fromList
        [(Proxy blk -> TxIn blk -> TxInBytes
forall blk.
MemPack (TxIn blk) =>
Proxy blk -> TxIn blk -> TxInBytes
toTxInBytes (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @blk) TxIn blk
txin, l blk EmptyMK -> TxOut blk -> TxOutBytes
forall (l :: * -> (* -> * -> *) -> *) blk.
IndexedMemPack l blk (TxOut blk) =>
l blk EmptyMK -> TxOut blk -> TxOutBytes
toTxOutBytes l blk EmptyMK
st TxOut blk
txout, Maybe Void
forall a. Maybe a
Nothing) | (TxIn blk
txin, TxOut blk
txout) <- [(TxIn blk, TxOut blk)]
accUTxOs]

  go :: Int
-> Table m TxInBytes TxOutBytes Void
-> Int
-> [(TxIn blk, TxOut blk)]
-> Stream
     (Of (TxIn blk, TxOut blk))
     (ExceptT DeserialiseFailure m)
     (Stream (Of ByteString) m (Maybe CRC))
-> ExceptT
     DeserialiseFailure m (Stream (Of ByteString) m (Maybe CRC), Int)
go Int
utxosSize Table m TxInBytes TxOutBytes Void
lsmTable Int
0 [(TxIn blk, TxOut blk)]
accUTxOs Stream
  (Of (TxIn blk, TxOut blk))
  (ExceptT DeserialiseFailure m)
  (Stream (Of ByteString) m (Maybe CRC))
stream' = do
    m () -> ExceptT DeserialiseFailure m ()
forall (m :: * -> *) a.
Monad m =>
m a -> ExceptT DeserialiseFailure m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> ExceptT DeserialiseFailure m ())
-> m () -> ExceptT DeserialiseFailure m ()
forall a b. (a -> b) -> a -> b
$ Table m TxInBytes TxOutBytes Void
-> [(TxIn blk, TxOut blk)] -> m ()
writeToTable Table m TxInBytes TxOutBytes Void
lsmTable [(TxIn blk, TxOut blk)]
accUTxOs
    Int
-> Table m TxInBytes TxOutBytes Void
-> Int
-> [(TxIn blk, TxOut blk)]
-> Stream
     (Of (TxIn blk, TxOut blk))
     (ExceptT DeserialiseFailure m)
     (Stream (Of ByteString) m (Maybe CRC))
-> ExceptT
     DeserialiseFailure m (Stream (Of ByteString) m (Maybe CRC), Int)
go Int
utxosSize Table m TxInBytes TxOutBytes Void
lsmTable Int
writeChunkSize [(TxIn blk, TxOut blk)]
forall a. Monoid a => a
mempty Stream
  (Of (TxIn blk, TxOut blk))
  (ExceptT DeserialiseFailure m)
  (Stream (Of ByteString) m (Maybe CRC))
stream'
  go Int
utxosSize Table m TxInBytes TxOutBytes Void
lsmTable Int
numToRead [(TxIn blk, TxOut blk)]
accUTxOs Stream
  (Of (TxIn blk, TxOut blk))
  (ExceptT DeserialiseFailure m)
  (Stream (Of ByteString) m (Maybe CRC))
stream' = do
    mItem <- Stream
  (Of (TxIn blk, TxOut blk))
  (ExceptT DeserialiseFailure m)
  (Stream (Of ByteString) m (Maybe CRC))
-> ExceptT
     DeserialiseFailure
     m
     (Either
        (Stream (Of ByteString) m (Maybe CRC))
        ((TxIn blk, TxOut blk),
         Stream
           (Of (TxIn blk, TxOut blk))
           (ExceptT DeserialiseFailure m)
           (Stream (Of ByteString) m (Maybe CRC))))
forall (m :: * -> *) a r.
Monad m =>
Stream (Of a) m r -> m (Either r (a, Stream (Of a) m r))
S.next Stream
  (Of (TxIn blk, TxOut blk))
  (ExceptT DeserialiseFailure m)
  (Stream (Of ByteString) m (Maybe CRC))
stream'
    case mItem of
      Left Stream (Of ByteString) m (Maybe CRC)
r -> do
        m () -> ExceptT DeserialiseFailure m ()
forall (m :: * -> *) a.
Monad m =>
m a -> ExceptT DeserialiseFailure m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> ExceptT DeserialiseFailure m ())
-> m () -> ExceptT DeserialiseFailure m ()
forall a b. (a -> b) -> a -> b
$ Table m TxInBytes TxOutBytes Void
-> [(TxIn blk, TxOut blk)] -> m ()
writeToTable Table m TxInBytes TxOutBytes Void
lsmTable [(TxIn blk, TxOut blk)]
accUTxOs
        (Stream (Of ByteString) m (Maybe CRC), Int)
-> ExceptT
     DeserialiseFailure m (Stream (Of ByteString) m (Maybe CRC), Int)
forall a. a -> ExceptT DeserialiseFailure m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Stream (Of ByteString) m (Maybe CRC)
r, Int
utxosSize)
      Right ((TxIn blk, TxOut blk)
item, Stream
  (Of (TxIn blk, TxOut blk))
  (ExceptT DeserialiseFailure m)
  (Stream (Of ByteString) m (Maybe CRC))
stream'') -> Int
-> Table m TxInBytes TxOutBytes Void
-> Int
-> [(TxIn blk, TxOut blk)]
-> Stream
     (Of (TxIn blk, TxOut blk))
     (ExceptT DeserialiseFailure m)
     (Stream (Of ByteString) m (Maybe CRC))
-> ExceptT
     DeserialiseFailure m (Stream (Of ByteString) m (Maybe CRC), Int)
go (Int
utxosSize Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Table m TxInBytes TxOutBytes Void
lsmTable (Int
numToRead Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) ((TxIn blk, TxOut blk)
item (TxIn blk, TxOut blk)
-> [(TxIn blk, TxOut blk)] -> [(TxIn blk, TxOut blk)]
forall a. a -> [a] -> [a]
: [(TxIn blk, TxOut blk)]
accUTxOs) Stream
  (Of (TxIn blk, TxOut blk))
  (ExceptT DeserialiseFailure m)
  (Stream (Of ByteString) m (Maybe CRC))
stream''

-- | Create Yield arguments for LSM
mkLSMYieldArgs ::
  ( IOLike m
  , LSMConstraints l blk
  ) =>
  -- | The filepath in which the LSM database lives. Must not have a trailing slash!
  FilePath ->
  -- | The complete name of the snapshot to open, so @<slotno>[_<suffix>]@.
  DiskSnapshot ->
  -- | Usually 'stdMkBlockIOFS'
  (FilePath -> WithTempRegistry () m (SomeHasFSAndBlockIO m)) ->
  -- | Usually 'newStdGen'
  (m StdGen) ->
  m (YieldArgs m LSM l blk)
mkLSMYieldArgs :: forall (m :: * -> *) (l :: * -> (* -> * -> *) -> *) blk.
(IOLike m, LSMConstraints l blk) =>
[Char]
-> DiskSnapshot
-> ([Char] -> WithTempRegistry () m (SomeHasFSAndBlockIO m))
-> m StdGen
-> m (YieldArgs m LSM l blk)
mkLSMYieldArgs [Char]
lsmDbPath DiskSnapshot
ds [Char] -> WithTempRegistry () m (SomeHasFSAndBlockIO m)
mkFS m StdGen
mkGen = do
  shfsbio@(SomeHasFSAndBlockIO hasFS blockIO) <-
    -- The Yield args will be created in the alloc step of a bracket so we do the
    -- 'runWithTempRegistry' here as the resource will be closed by the outer
    -- bracket anyways.
    WithTempRegistry () m (SomeHasFSAndBlockIO m, ())
-> m (SomeHasFSAndBlockIO m)
forall (m :: * -> *) st a.
(MonadSTM m, MonadMask m, MonadThread m, MonadEvaluate m,
 HasCallStack) =>
WithTempRegistry st m (a, st) -> m a
runWithTempRegistry (WithTempRegistry () m (SomeHasFSAndBlockIO m, ())
 -> m (SomeHasFSAndBlockIO m))
-> WithTempRegistry () m (SomeHasFSAndBlockIO m, ())
-> m (SomeHasFSAndBlockIO m)
forall a b. (a -> b) -> a -> b
$ (\SomeHasFSAndBlockIO m
x -> (SomeHasFSAndBlockIO m
x, ())) (SomeHasFSAndBlockIO m -> (SomeHasFSAndBlockIO m, ()))
-> WithTempRegistry () m (SomeHasFSAndBlockIO m)
-> WithTempRegistry () m (SomeHasFSAndBlockIO m, ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> WithTempRegistry () m (SomeHasFSAndBlockIO m)
mkFS [Char]
lsmDbPath
  salt <- fst . genWord64 <$> mkGen
  session <- LSM.openSession nullTracer hasFS blockIO salt (mkFsPath [])
  tb <-
    LSM.openTableFromSnapshot
      session
      (LSM.toSnapshotName (snapshotToDirName ds))
      (LSM.SnapshotLabel $ T.pack "UTxO table")
  h <- newLSMLedgerTablesHandle nullTracer (const (pure ())) 0 tb
  pure $ YieldLSM 1000 h session shfsbio (pure ())

-- | Create Yield arguments for a standalone (exported) LSM snapshot.
--
-- Unlike 'mkLSMYieldArgs', which reads a snapshot out of a live LSM database,
-- this opens a /temporary/ scratch session next to the exported snapshot,
-- imports the exported snapshot into it, and then streams it as usual. The
-- scratch session is removed by 'releaseYieldArgs'.
--
-- The scratch session is created in the parent directory of the exported
-- snapshot, so that it lives on the same volume (a requirement of importing).
mkExportedLSMYieldArgs ::
  ( IOLike m
  , LSMConstraints l blk
  ) =>
  -- | The directory containing the exported snapshot. Must not have a trailing
  -- slash!
  FilePath ->
  -- | The complete name of the snapshot, so @<slotno>[_<suffix>]@.
  DiskSnapshot ->
  -- | Usually 'stdMkBlockIOFS'
  (FilePath -> WithTempRegistry () m (SomeHasFSAndBlockIO m)) ->
  -- | Usually 'ioHasFS'
  (FilePath -> SomeHasFS m) ->
  -- | Usually 'newStdGen'
  (m StdGen) ->
  m (YieldArgs m LSM l blk)
mkExportedLSMYieldArgs :: forall (m :: * -> *) (l :: * -> (* -> * -> *) -> *) blk.
(IOLike m, LSMConstraints l blk) =>
[Char]
-> DiskSnapshot
-> ([Char] -> WithTempRegistry () m (SomeHasFSAndBlockIO m))
-> ([Char] -> SomeHasFS m)
-> m StdGen
-> m (YieldArgs m LSM l blk)
mkExportedLSMYieldArgs [Char]
exportDir DiskSnapshot
ds [Char] -> WithTempRegistry () m (SomeHasFSAndBlockIO m)
mkFSBIO [Char] -> SomeHasFS m
mkFS m StdGen
mkGen = do
  shfsbio@(SomeHasFSAndBlockIO hasFS blockIO) <-
    WithTempRegistry () m (SomeHasFSAndBlockIO m, ())
-> m (SomeHasFSAndBlockIO m)
forall (m :: * -> *) st a.
(MonadSTM m, MonadMask m, MonadThread m, MonadEvaluate m,
 HasCallStack) =>
WithTempRegistry st m (a, st) -> m a
runWithTempRegistry (WithTempRegistry () m (SomeHasFSAndBlockIO m, ())
 -> m (SomeHasFSAndBlockIO m))
-> WithTempRegistry () m (SomeHasFSAndBlockIO m, ())
-> m (SomeHasFSAndBlockIO m)
forall a b. (a -> b) -> a -> b
$ (\SomeHasFSAndBlockIO m
x -> (SomeHasFSAndBlockIO m
x, ())) (SomeHasFSAndBlockIO m -> (SomeHasFSAndBlockIO m, ()))
-> WithTempRegistry () m (SomeHasFSAndBlockIO m)
-> WithTempRegistry () m (SomeHasFSAndBlockIO m, ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> WithTempRegistry () m (SomeHasFSAndBlockIO m)
mkFSBIO (ShowS
takeDirectory [Char]
exportDir)
  nonce <- hACK_GET_SALT_FROM_BLOOMFILTER mkGen $ mkFS exportDir
  let scratch = Word64 -> FsPath
scratchSessionPath Word64
nonce
  freshDirectory hasFS scratch
  let snapName = [Char] -> SnapshotName
LSM.toSnapshotName (DiskSnapshot -> [Char]
snapshotToDirName DiskSnapshot
ds)
  session <-
    LSM.newSession
      nullTracer
      hasFS
      blockIO
      nonce
      scratch
  LSM.importSnapshot
    session
    snapName
    (mkFsPath [takeFileName exportDir])
  tb <-
    LSM.openTableFromSnapshot
      session
      snapName
      (LSM.SnapshotLabel $ T.pack "UTxO table")
  -- A scratch session used only for reading; it never exports snapshots.
  h <- newLSMLedgerTablesHandle nullTracer (const (pure ())) 0 tb
  pure $ YieldLSM 1000 h session shfsbio (removeDirectoryRecursive hasFS scratch)

-- | Create Sink arguments for a standalone (exported) LSM snapshot.
--
-- Unlike 'mkLSMSinkArgs', which sinks into a live LSM database, this sinks into
-- a /temporary/ scratch session next to the destination directory, and then
-- exports the resulting snapshot to that directory (see 'LSM.exportSnapshot').
-- The scratch session is removed by 'releaseSinkArgs'.
--
-- The scratch session is created in the parent directory of the destination, so
-- that it lives on the same volume (a requirement of 'LSM.exportSnapshot').
mkExportedLSMSinkArgs ::
  IOLike m =>
  -- | The destination directory for the exported snapshot. It will be
  -- (re)created, and must not have a trailing slash!
  FilePath ->
  -- | The complete name of the snapshot, so @<slotno>[_<suffix>]@.
  DiskSnapshot ->
  -- | Usually 'ioHasFS', for the LedgerDB snapshot (@state@/@meta@) files.
  SomeHasFS m ->
  -- | Usually 'stdMkBlockIOFS'
  (FilePath -> WithTempRegistry () m (SomeHasFSAndBlockIO m)) ->
  -- | Usually 'newStdGen'
  (m StdGen) ->
  m (SinkArgs m LSM l blk)
mkExportedLSMSinkArgs :: forall (m :: * -> *) (l :: * -> (* -> * -> *) -> *) blk.
IOLike m =>
[Char]
-> DiskSnapshot
-> SomeHasFS m
-> ([Char] -> WithTempRegistry () m (SomeHasFSAndBlockIO m))
-> m StdGen
-> m (SinkArgs m LSM l blk)
mkExportedLSMSinkArgs [Char]
exportDir DiskSnapshot
ds SomeHasFS m
snapFs [Char] -> WithTempRegistry () m (SomeHasFSAndBlockIO m)
mkBlockIOFS m StdGen
mkGen = do
  shfsbio@(SomeHasFSAndBlockIO hasFS blockIO) <-
    WithTempRegistry () m (SomeHasFSAndBlockIO m, ())
-> m (SomeHasFSAndBlockIO m)
forall (m :: * -> *) st a.
(MonadSTM m, MonadMask m, MonadThread m, MonadEvaluate m,
 HasCallStack) =>
WithTempRegistry st m (a, st) -> m a
runWithTempRegistry (WithTempRegistry () m (SomeHasFSAndBlockIO m, ())
 -> m (SomeHasFSAndBlockIO m))
-> WithTempRegistry () m (SomeHasFSAndBlockIO m, ())
-> m (SomeHasFSAndBlockIO m)
forall a b. (a -> b) -> a -> b
$ (\SomeHasFSAndBlockIO m
x -> (SomeHasFSAndBlockIO m
x, ())) (SomeHasFSAndBlockIO m -> (SomeHasFSAndBlockIO m, ()))
-> WithTempRegistry () m (SomeHasFSAndBlockIO m)
-> WithTempRegistry () m (SomeHasFSAndBlockIO m, ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> WithTempRegistry () m (SomeHasFSAndBlockIO m)
mkBlockIOFS (ShowS
takeDirectory [Char]
exportDir)
  (nonce, gen') <- genWord64 <$> mkGen
  let salt = (Word64, StdGen) -> Word64
forall a b. (a, b) -> a
fst ((Word64, StdGen) -> Word64) -> (Word64, StdGen) -> Word64
forall a b. (a -> b) -> a -> b
$ StdGen -> (Word64, StdGen)
forall g. RandomGen g => g -> (Word64, g)
genWord64 StdGen
gen'
      scratch = Word64 -> FsPath
scratchSessionPath Word64
nonce
      exportFsPath = Context -> FsPath
mkFsPath [ShowS
takeFileName [Char]
exportDir]
  freshDirectory hasFS scratch
  -- 'LSM.exportSnapshot' requires the destination directory to not exist.
  whenM (doesDirectoryExist hasFS exportFsPath) $
    removeDirectoryRecursive hasFS exportFsPath
  session <- LSM.newSession nullTracer hasFS blockIO salt scratch
  let afterSave =
        Session m -> SnapshotName -> FsPath -> m ()
forall (m :: * -> *).
IOLike m =>
Session m -> SnapshotName -> FsPath -> m ()
LSM.exportSnapshot Session m
session ([Char] -> SnapshotName
LSM.toSnapshotName (DiskSnapshot -> [Char]
snapshotToDirName DiskSnapshot
ds)) FsPath
exportFsPath
  pure (SinkLSM 1000 snapFs shfsbio ds session afterSave (removeDirectoryRecursive hasFS scratch))

-- | Export a snapshot out of a (offline) LSM database into a standalone
-- directory, which must not exist yet.
--
-- The database session and the destination must live on the same volume.
lsmDbExportSnapshot ::
  -- | The LSM database (session) directory.
  FilePath ->
  -- | The name of the snapshot to export, so @<slotno>[_<suffix>]@.
  String ->
  -- | The destination directory, which must not exist yet.
  FilePath ->
  IO ()
lsmDbExportSnapshot :: [Char] -> [Char] -> [Char] -> IO ()
lsmDbExportSnapshot [Char]
dbPath [Char]
snapName [Char]
exportDir = do
  salt <- (Word64, StdGen) -> Word64
forall a b. (a, b) -> a
fst ((Word64, StdGen) -> Word64)
-> (StdGen -> (Word64, StdGen)) -> StdGen -> Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StdGen -> (Word64, StdGen)
forall g. RandomGen g => g -> (Word64, g)
genWord64 (StdGen -> Word64) -> IO StdGen -> IO Word64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO StdGen
forall (m :: * -> *). MonadIO m => m StdGen
newStdGen
  withRootFS $ \HasFS IO h
hasFS HasBlockIO IO h
blockIO -> do
    sessionDir <- [Char] -> IO FsPath
toRootFsPath [Char]
dbPath
    exportFs <- toRootFsPath exportDir
    bracket
      (LSM.openSession nullTracer hasFS blockIO salt sessionDir)
      LSM.closeSession
      (\Session IO
session -> Session IO -> SnapshotName -> FsPath -> IO ()
forall (m :: * -> *).
IOLike m =>
Session m -> SnapshotName -> FsPath -> m ()
LSM.exportSnapshot Session IO
session ([Char] -> SnapshotName
LSM.toSnapshotName [Char]
snapName) FsPath
exportFs)

-- | Import a snapshot from a standalone directory into a new (offline) LSM
-- database, created at the given (empty or absent) directory.
--
-- The database session and the source must live on the same volume.
lsmDbImportSnapshot ::
  -- | The LSM database (session) directory. Created if it does not exist; must
  -- be empty otherwise.
  FilePath ->
  -- | The name to give the imported snapshot, so @<slotno>[_<suffix>]@.
  String ->
  -- | The source directory containing the exported snapshot.
  FilePath ->
  IO ()
lsmDbImportSnapshot :: [Char] -> [Char] -> [Char] -> IO ()
lsmDbImportSnapshot [Char]
dbPath [Char]
snapName [Char]
srcDir =
  (forall h.
 (Eq h, Typeable h) =>
 HasFS IO h -> HasBlockIO IO h -> IO ())
-> IO ()
forall a.
(forall h.
 (Eq h, Typeable h) =>
 HasFS IO h -> HasBlockIO IO h -> IO a)
-> IO a
withRootFS ((forall h.
  (Eq h, Typeable h) =>
  HasFS IO h -> HasBlockIO IO h -> IO ())
 -> IO ())
-> (forall h.
    (Eq h, Typeable h) =>
    HasFS IO h -> HasBlockIO IO h -> IO ())
-> IO ()
forall a b. (a -> b) -> a -> b
$ \HasFS IO h
hasFS HasBlockIO IO h
blockIO -> do
    sessionDir <- [Char] -> IO FsPath
toRootFsPath [Char]
dbPath
    srcFs <- toRootFsPath srcDir
    createDirectoryIfMissing hasFS True sessionDir
    salt <- hACK_GET_SALT_FROM_BLOOMFILTER newStdGen $ SomeHasFS $ FS.ioHasFS $ MountPoint srcDir

    bracket
      ( LSM.newSession
          nullTracer
          hasFS
          blockIO
          salt
          sessionDir
      )
      LSM.closeSession
      (\Session IO
s -> Session IO -> SnapshotName -> FsPath -> IO ()
forall (m :: * -> *).
IOLike m =>
Session m -> SnapshotName -> FsPath -> m ()
LSM.importSnapshot Session IO
s ([Char] -> SnapshotName
LSM.toSnapshotName [Char]
snapName) FsPath
srcFs)

-- HACK: while we wait for https://github.com/IntersectMBO/lsm-tree/pull/855
--
-- Read the salt from one of the bloomfilter files in the snapshot.
hACK_GET_SALT_FROM_BLOOMFILTER ::
  forall m.
  IOLike m =>
  -- | To generate a salt if we don't get it from an existing bloom filter
  m StdGen ->
  -- | A FS anchored at the exported LSM snapshot.
  SomeHasFS m ->
  m Salt
hACK_GET_SALT_FROM_BLOOMFILTER :: forall (m :: * -> *).
IOLike m =>
m StdGen -> SomeHasFS m -> m Word64
hACK_GET_SALT_FROM_BLOOMFILTER m StdGen
gen (SomeHasFS HasFS m h
fs) = do
  files <- HasFS m h -> HasCallStack => FsPath -> m (Set [Char])
forall (m :: * -> *) h.
HasFS m h -> HasCallStack => FsPath -> m (Set [Char])
listDirectory HasFS m h
fs (Context -> FsPath
mkFsPath [])
  case List.find ((".filter" ==) . F.takeExtension) files of
    Just [Char]
f ->
      HasFS m h
-> FsPath -> OpenMode -> (Handle h -> m Word64) -> m Word64
forall (m :: * -> *) h a.
(HasCallStack, MonadThrow m) =>
HasFS m h -> FsPath -> OpenMode -> (Handle h -> m a) -> m a
withFile HasFS m h
fs (Context -> FsPath
mkFsPath [[Char]
f]) OpenMode
ReadMode ((Handle h -> m Word64) -> m Word64)
-> (Handle h -> m Word64) -> m Word64
forall a b. (a -> b) -> a -> b
$ \Handle h
h -> do
        -- We read exactly 24 bytes
        header <- HasFS m h -> Handle h -> Int -> m ByteArray
forall {m :: * -> *} {h}.
(PrimMonad m, MonadThrow m) =>
HasFS m h -> Handle h -> Int -> m ByteArray
hGetByteArrayExactly HasFS m h
fs Handle h
h Int
24
        -- We then read the 3rd Word64 from those bytes, which happens to be the
        -- Salt of the filter.
        --
        -- Can be inspected in Bash with:
        --
        -- @
        -- echo "ibase=16; $(hexdump -s 16 -n 8 -e '1/8 "%X"' path/to/nnn.filter)" | bc
        -- @
        pure $ P.indexByteArray header 2 :: m LSM.Salt
    Maybe [Char]
Nothing ->
      (Word64, StdGen) -> Word64
forall a b. (a, b) -> a
fst ((Word64, StdGen) -> Word64)
-> (StdGen -> (Word64, StdGen)) -> StdGen -> Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StdGen -> (Word64, StdGen)
forall g. RandomGen g => g -> (Word64, g)
genWord64 (StdGen -> Word64) -> m StdGen -> m Word64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m StdGen
gen
 where
  hGetByteArrayExactly :: HasFS m h -> Handle h -> Int -> m ByteArray
hGetByteArrayExactly HasFS m h
hfs Handle h
h Int
len = do
    buf <- Int -> m (MutableByteArray (PrimState m))
forall (m :: * -> *).
PrimMonad m =>
Int -> m (MutableByteArray (PrimState m))
P.newByteArray Int
len
    _ <- hGetBufExactly hfs h buf 0 (fromIntegral len)
    P.unsafeFreezeByteArray buf

-- | Mount the filesystem at the root, run an action with the resulting handles,
-- and close the underlying block IO afterwards.
--
-- Mounting at the root means that any 'FsPath' (the session directory itself,
-- as well as the import/export directories) can be expressed relative to a
-- single mount point, even when they live in unrelated parts of the filesystem
-- (as long as they are on the same volume, which the caller must guarantee).
withRootFS ::
  (forall h. (Eq h, Typeable h) => HasFS IO h -> BIO.HasBlockIO IO h -> IO a) ->
  IO a
withRootFS :: forall a.
(forall h.
 (Eq h, Typeable h) =>
 HasFS IO h -> HasBlockIO IO h -> IO a)
-> IO a
withRootFS forall h.
(Eq h, Typeable h) =>
HasFS IO h -> HasBlockIO IO h -> IO a
act = do
  SomeHasFSAndBlockIO hasFS blockIO <-
    WithTempRegistry () IO (SomeHasFSAndBlockIO IO, ())
-> IO (SomeHasFSAndBlockIO IO)
forall (m :: * -> *) st a.
(MonadSTM m, MonadMask m, MonadThread m, MonadEvaluate m,
 HasCallStack) =>
WithTempRegistry st m (a, st) -> m a
runWithTempRegistry (WithTempRegistry () IO (SomeHasFSAndBlockIO IO, ())
 -> IO (SomeHasFSAndBlockIO IO))
-> WithTempRegistry () IO (SomeHasFSAndBlockIO IO, ())
-> IO (SomeHasFSAndBlockIO IO)
forall a b. (a -> b) -> a -> b
$ (\SomeHasFSAndBlockIO IO
x -> (SomeHasFSAndBlockIO IO
x, ())) (SomeHasFSAndBlockIO IO -> (SomeHasFSAndBlockIO IO, ()))
-> WithTempRegistry () IO (SomeHasFSAndBlockIO IO)
-> WithTempRegistry () IO (SomeHasFSAndBlockIO IO, ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> WithTempRegistry () IO (SomeHasFSAndBlockIO IO)
forall st.
[Char] -> WithTempRegistry st IO (SomeHasFSAndBlockIO IO)
stdMkBlockIOFS [Char]
"/"
  act hasFS blockIO
    `finally` BIO.close blockIO

-- | A 'FsPath' (relative to the filesystem root) for a temporary scratch
-- session directory, named after a nonce to make collisions unlikely.
scratchSessionPath :: Word64 -> FsPath
scratchSessionPath :: Word64 -> FsPath
scratchSessionPath Word64
nonce = Context -> FsPath
mkFsPath [[Char]
"lsm-convert-scratch-" [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Word64 -> [Char]
forall a. Show a => a -> [Char]
show Word64
nonce]

-- | Interpret a (possibly relative) 'FilePath' as a 'FsPath' relative to the
-- filesystem root, so that it can be used with a session mounted at the root.
toRootFsPath :: FilePath -> IO FsPath
toRootFsPath :: [Char] -> IO FsPath
toRootFsPath [Char]
p = do
  absPath <- [Char] -> IO [Char]
D.makeAbsolute [Char]
p
  pure $ mkFsPath $ splitDirectories $ makeRelative "/" absPath

-- | Ensure a directory exists and is empty.
freshDirectory :: Monad m => HasFS m h -> FsPath -> m ()
freshDirectory :: forall (m :: * -> *) h. Monad m => HasFS m h -> FsPath -> m ()
freshDirectory HasFS m h
hasFS FsPath
p = do
  m Bool -> m () -> m ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (HasFS m h -> HasCallStack => FsPath -> m Bool
forall (m :: * -> *) h.
HasFS m h -> HasCallStack => FsPath -> m Bool
doesDirectoryExist HasFS m h
hasFS FsPath
p) (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 ()
removeDirectoryRecursive HasFS m h
hasFS FsPath
p
  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
p

whenM :: Monad m => m Bool -> m () -> m ()
whenM :: forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM m Bool
mb m ()
act = m Bool
mb m Bool -> (Bool -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Bool
b -> Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
Monad.when Bool
b m ()
act

-- | Create Sink arguments for LSM
mkLSMSinkArgs ::
  IOLike m =>
  -- | The filepath for the LSM database
  FilePath ->
  -- | The filepath to the snapshot to be created, so @.../.../ledger/<slotno>[_<suffix>]@.
  DiskSnapshot ->
  -- | Usually 'ioHasFS'
  SomeHasFS m ->
  -- | Usually 'stdMkBlockIOFS'
  (FilePath -> WithTempRegistry () m (SomeHasFSAndBlockIO m)) ->
  -- | Usually 'newStdGen'
  (m StdGen) ->
  m (SinkArgs m LSM l blk)
mkLSMSinkArgs :: forall (m :: * -> *) (l :: * -> (* -> * -> *) -> *) blk.
IOLike m =>
[Char]
-> DiskSnapshot
-> SomeHasFS m
-> ([Char] -> WithTempRegistry () m (SomeHasFSAndBlockIO m))
-> m StdGen
-> m (SinkArgs m LSM l blk)
mkLSMSinkArgs ([Char] -> ([Char], [Char])
splitFileName -> ([Char]
lsmDbParentPath, [Char]
lsmDbPath)) DiskSnapshot
ds SomeHasFS m
snapFs [Char] -> WithTempRegistry () m (SomeHasFSAndBlockIO m)
mkBlockIOFS m StdGen
mkGen = do
  shfsbio@(SomeHasFSAndBlockIO hasFS blockIO) <-
    -- The Sink args will be created in the alloc step of a bracket so we do the
    -- 'runWithTempRegistry' here as the resource will be closed by the outer
    -- bracket anyways.
    WithTempRegistry () m (SomeHasFSAndBlockIO m, ())
-> m (SomeHasFSAndBlockIO m)
forall (m :: * -> *) st a.
(MonadSTM m, MonadMask m, MonadThread m, MonadEvaluate m,
 HasCallStack) =>
WithTempRegistry st m (a, st) -> m a
runWithTempRegistry (WithTempRegistry () m (SomeHasFSAndBlockIO m, ())
 -> m (SomeHasFSAndBlockIO m))
-> WithTempRegistry () m (SomeHasFSAndBlockIO m, ())
-> m (SomeHasFSAndBlockIO m)
forall a b. (a -> b) -> a -> b
$ (\SomeHasFSAndBlockIO m
x -> (SomeHasFSAndBlockIO m
x, ())) (SomeHasFSAndBlockIO m -> (SomeHasFSAndBlockIO m, ()))
-> WithTempRegistry () m (SomeHasFSAndBlockIO m)
-> WithTempRegistry () m (SomeHasFSAndBlockIO m, ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> WithTempRegistry () m (SomeHasFSAndBlockIO m)
mkBlockIOFS [Char]
lsmDbParentPath
  let lsmDbPath' = Context -> FsPath
mkFsPath [[Char]
lsmDbPath]
  removeDirectoryRecursive hasFS lsmDbPath'
  createDirectory hasFS lsmDbPath'
  salt <- fst . genWord64 <$> mkGen
  session <- LSM.newSession nullTracer hasFS blockIO salt lsmDbPath'
  pure (SinkLSM 1000 snapFs shfsbio ds session (pure ()) (pure ()))