{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeData #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ViewPatterns #-}

module Ouroboros.Consensus.Storage.LedgerDB.V2.InMemory
  ( Backend (..)
  , Args (InMemArgs)
  , Trace (NoTrace)
  , Mem
  , YieldArgs (YieldInMemory)
  , SinkArgs (SinkInMemory)
  , mkInMemoryArgs
  ) where

import Cardano.Binary as CBOR
import Cardano.Slotting.Slot
import Codec.CBOR.Read
import qualified Codec.CBOR.Write as CBOR
import Codec.Serialise (decode)
import Control.Monad (replicateM_, unless)
import qualified Control.Monad as Monad
import Control.Monad.Class.MonadST
import Control.Monad.Class.MonadThrow
import Control.Monad.Except
import Control.Monad.State.Strict (execStateT)
import Control.Monad.Trans.Except
import Control.Tracer
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import Data.ByteString.Builder.Extra (defaultChunkSize)
import Data.Functor.Contravariant ((>$<))
import Data.Functor.Identity
import qualified Data.List as List
import qualified Data.Map.Strict as Map
import Data.Maybe
import Data.MemPack
import Data.Void
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 hiding (tables)
import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.LedgerSeq as StateRef
import Ouroboros.Consensus.Util.CBOR (readIncremental)
import Ouroboros.Consensus.Util.CRC
import Ouroboros.Consensus.Util.Enclose
import Ouroboros.Consensus.Util.IOLike
import Streaming
import qualified Streaming as S
import qualified Streaming.Prelude as S
import System.FS.API
import System.FS.CRC
import Prelude hiding (read)

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

newInMemoryLedgerTablesHandle ::
  forall m l blk.
  ( IOLike m
  , HasLedgerTables l blk
  , CanUpgradeLedgerTables l blk
  , SerializeTablesWithHint l blk
  , StandardHash (l blk)
  , GetTip (l blk)
  ) =>
  Tracer m LedgerDBV2Trace ->
  -- | FileSystem in order to take snapshots
  SomeHasFS m ->
  -- | The tables
  LedgerTables blk ValuesMK ->
  m (LedgerTablesHandle m l blk)
newInMemoryLedgerTablesHandle :: forall (m :: * -> *) (l :: StateKind) blk.
(IOLike m, HasLedgerTables l blk, CanUpgradeLedgerTables l blk,
 SerializeTablesWithHint l blk, StandardHash (l blk),
 GetTip (l blk)) =>
Tracer m LedgerDBV2Trace
-> SomeHasFS m
-> LedgerTables blk ValuesMK
-> m (LedgerTablesHandle m l blk)
newInMemoryLedgerTablesHandle !Tracer m LedgerDBV2Trace
tracer !someFS :: SomeHasFS m
someFS@(SomeHasFS !HasFS m h
hasFS) LedgerTables blk ValuesMK
tables =
  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
$
    let h :: LedgerTablesHandle m l blk
h =
          LedgerTablesHandle
            { close :: m ()
close = 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) (() -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
            , duplicate :: m (LedgerTablesHandle m l blk)
duplicate = 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
$ LedgerTablesHandle m l blk -> m (LedgerTablesHandle m l blk)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure LedgerTablesHandle m l blk
h
            , read :: l blk EmptyMK
-> LedgerTables blk KeysMK -> m (LedgerTables blk ValuesMK)
read = LedgerTables blk ValuesMK
-> l blk EmptyMK
-> LedgerTables blk KeysMK
-> m (LedgerTables blk ValuesMK)
forall (m :: * -> *) (l :: StateKind) blk.
(IOLike m, HasLedgerTables l blk) =>
LedgerTables blk ValuesMK
-> l blk EmptyMK
-> LedgerTables blk KeysMK
-> m (LedgerTables blk ValuesMK)
implRead LedgerTables blk ValuesMK
tables
            , readRange :: l blk EmptyMK
-> (Maybe (TxIn blk), Int)
-> m (LedgerTables blk ValuesMK, Maybe (TxIn blk))
readRange = LedgerTables blk ValuesMK
-> l blk EmptyMK
-> (Maybe (TxIn blk), Int)
-> m (LedgerTables blk ValuesMK, Maybe (TxIn blk))
forall (m :: * -> *) (l :: StateKind) blk.
(IOLike m, HasLedgerTables l blk) =>
LedgerTables blk ValuesMK
-> l blk EmptyMK
-> (Maybe (TxIn blk), Int)
-> m (LedgerTables blk ValuesMK, Maybe (TxIn blk))
implReadRange LedgerTables blk ValuesMK
tables
            , readAll :: l blk EmptyMK -> m (LedgerTables blk ValuesMK)
readAll = \l blk EmptyMK
_ -> LedgerTables blk ValuesMK -> m (LedgerTables blk ValuesMK)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure LedgerTables blk ValuesMK
tables
            , duplicateWithDiffs :: l blk EmptyMK -> l blk DiffMK -> m (LedgerTablesHandle m l blk)
duplicateWithDiffs = Tracer m LedgerDBV2Trace
-> LedgerTables blk ValuesMK
-> SomeHasFS m
-> l blk EmptyMK
-> l blk DiffMK
-> m (LedgerTablesHandle m l blk)
forall (m :: * -> *) (l :: StateKind) blk (mk1 :: MapKind).
(IOLike m, HasLedgerTables l blk, CanUpgradeLedgerTables l blk,
 StandardHash (l blk), GetTip (l blk),
 SerializeTablesWithHint l blk) =>
Tracer m LedgerDBV2Trace
-> LedgerTables blk ValuesMK
-> SomeHasFS m
-> l blk mk1
-> l blk DiffMK
-> m (LedgerTablesHandle m l blk)
implDuplicateWithDiffs Tracer m LedgerDBV2Trace
tracer LedgerTables blk ValuesMK
tables SomeHasFS m
someFS
            , takeHandleSnapshot :: l blk EmptyMK -> String -> m (Maybe CRC)
takeHandleSnapshot = LedgerTables blk ValuesMK
-> HasFS m h -> l blk EmptyMK -> String -> m (Maybe CRC)
forall (m :: * -> *) (l :: StateKind) blk h.
(IOLike m, SerializeTablesWithHint l blk) =>
LedgerTables blk ValuesMK
-> HasFS m h -> l blk EmptyMK -> String -> m (Maybe CRC)
implTakeHandleSnapshot LedgerTables blk ValuesMK
tables HasFS m h
hasFS
            , tablesSize :: Int
tablesSize = Map (TxIn blk) (TxOut blk) -> Int
forall k a. Map k a -> Int
Map.size (Map (TxIn blk) (TxOut blk) -> Int)
-> (LedgerTables blk ValuesMK -> Map (TxIn blk) (TxOut blk))
-> LedgerTables blk ValuesMK
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ValuesMK (TxIn blk) (TxOut blk) -> Map (TxIn blk) (TxOut blk)
forall k v. ValuesMK k v -> Map k v
getValuesMK (ValuesMK (TxIn blk) (TxOut blk) -> Map (TxIn blk) (TxOut blk))
-> (LedgerTables blk ValuesMK -> ValuesMK (TxIn blk) (TxOut blk))
-> LedgerTables blk ValuesMK
-> Map (TxIn blk) (TxOut blk)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerTables blk ValuesMK -> ValuesMK (TxIn blk) (TxOut blk)
forall blk (mk :: MapKind).
LedgerTables blk mk -> mk (TxIn blk) (TxOut blk)
getLedgerTables (LedgerTables blk ValuesMK -> Int)
-> LedgerTables blk ValuesMK -> Int
forall a b. (a -> b) -> a -> b
$ LedgerTables blk ValuesMK
tables
            }
     in LedgerTablesHandle m l blk -> m (LedgerTablesHandle m l blk)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure LedgerTablesHandle m l blk
h

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

implRead ::
  ( IOLike m
  , HasLedgerTables l blk
  ) =>
  LedgerTables blk ValuesMK ->
  l blk EmptyMK ->
  LedgerTables blk KeysMK ->
  m (LedgerTables blk ValuesMK)
implRead :: forall (m :: * -> *) (l :: StateKind) blk.
(IOLike m, HasLedgerTables l blk) =>
LedgerTables blk ValuesMK
-> l blk EmptyMK
-> LedgerTables blk KeysMK
-> m (LedgerTables blk ValuesMK)
implRead LedgerTables blk ValuesMK
tables l blk EmptyMK
_ LedgerTables blk KeysMK
keys = do
  LedgerTables blk ValuesMK -> m (LedgerTables blk ValuesMK)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LedgerTables blk ValuesMK -> m (LedgerTables blk ValuesMK))
-> LedgerTables blk ValuesMK -> m (LedgerTables blk ValuesMK)
forall a b. (a -> b) -> a -> b
$ (LedgerTables blk ValuesMK
 -> LedgerTables blk KeysMK -> LedgerTables blk ValuesMK)
-> LedgerTables blk KeysMK
-> LedgerTables blk ValuesMK
-> LedgerTables blk ValuesMK
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((forall k v.
 LedgerTableConstraints' blk k v =>
 ValuesMK k v -> KeysMK k v -> ValuesMK k v)
-> LedgerTables blk ValuesMK
-> LedgerTables blk KeysMK
-> LedgerTables blk ValuesMK
forall l (mk1 :: MapKind) (mk2 :: MapKind) (mk3 :: MapKind).
LedgerTableConstraints l =>
(forall k v.
 LedgerTableConstraints' blk k v =>
 mk1 k v -> mk2 k v -> mk3 k v)
-> LedgerTables l mk1 -> LedgerTables l mk2 -> LedgerTables l mk3
ltliftA2 (\(ValuesMK Map k v
v) (KeysMK Set k
k) -> Map k v -> ValuesMK k v
forall k v. Map k v -> ValuesMK k v
ValuesMK (Map k v -> ValuesMK k v) -> Map k v -> ValuesMK k v
forall a b. (a -> b) -> a -> b
$ Map k v
v Map k v -> Set k -> Map k v
forall k a. Ord k => Map k a -> Set k -> Map k a
`Map.restrictKeys` Set k
k)) LedgerTables blk KeysMK
keys LedgerTables blk ValuesMK
tables

implReadRange ::
  (IOLike m, HasLedgerTables l blk) =>
  LedgerTables blk ValuesMK ->
  l blk EmptyMK ->
  (Maybe (TxIn blk), Int) ->
  m (LedgerTables blk ValuesMK, Maybe (TxIn blk))
implReadRange :: forall (m :: * -> *) (l :: StateKind) blk.
(IOLike m, HasLedgerTables l blk) =>
LedgerTables blk ValuesMK
-> l blk EmptyMK
-> (Maybe (TxIn blk), Int)
-> m (LedgerTables blk ValuesMK, Maybe (TxIn blk))
implReadRange (LedgerTables (ValuesMK Map (TxIn blk) (TxOut blk)
m)) l blk EmptyMK
_ (Maybe (TxIn blk)
f, Int
t) =
  let m' :: Map (TxIn blk) (TxOut blk)
m' = Int -> Map (TxIn blk) (TxOut blk) -> Map (TxIn blk) (TxOut blk)
forall k a. Int -> Map k a -> Map k a
Map.take Int
t (Map (TxIn blk) (TxOut blk) -> Map (TxIn blk) (TxOut blk))
-> (Map (TxIn blk) (TxOut blk) -> Map (TxIn blk) (TxOut blk))
-> Map (TxIn blk) (TxOut blk)
-> Map (TxIn blk) (TxOut blk)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Map (TxIn blk) (TxOut blk) -> Map (TxIn blk) (TxOut blk))
-> (TxIn blk
    -> Map (TxIn blk) (TxOut blk) -> Map (TxIn blk) (TxOut blk))
-> Maybe (TxIn blk)
-> Map (TxIn blk) (TxOut blk)
-> Map (TxIn blk) (TxOut blk)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Map (TxIn blk) (TxOut blk) -> Map (TxIn blk) (TxOut blk)
forall a. a -> a
id (\TxIn blk
g -> (Map (TxIn blk) (TxOut blk), Map (TxIn blk) (TxOut blk))
-> Map (TxIn blk) (TxOut blk)
forall a b. (a, b) -> b
snd ((Map (TxIn blk) (TxOut blk), Map (TxIn blk) (TxOut blk))
 -> Map (TxIn blk) (TxOut blk))
-> (Map (TxIn blk) (TxOut blk)
    -> (Map (TxIn blk) (TxOut blk), Map (TxIn blk) (TxOut blk)))
-> Map (TxIn blk) (TxOut blk)
-> Map (TxIn blk) (TxOut blk)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxIn blk
-> Map (TxIn blk) (TxOut blk)
-> (Map (TxIn blk) (TxOut blk), Map (TxIn blk) (TxOut blk))
forall k a. Ord k => k -> Map k a -> (Map k a, Map k a)
Map.split TxIn blk
g) Maybe (TxIn blk)
f) (Map (TxIn blk) (TxOut blk) -> Map (TxIn blk) (TxOut blk))
-> Map (TxIn blk) (TxOut blk) -> Map (TxIn blk) (TxOut blk)
forall a b. (a -> b) -> a -> b
$ Map (TxIn blk) (TxOut blk)
m
   in (LedgerTables blk ValuesMK, Maybe (TxIn blk))
-> m (LedgerTables blk ValuesMK, Maybe (TxIn blk))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ValuesMK (TxIn blk) (TxOut blk) -> LedgerTables blk ValuesMK
forall blk (mk :: MapKind).
mk (TxIn blk) (TxOut blk) -> LedgerTables blk mk
LedgerTables (Map (TxIn blk) (TxOut blk) -> ValuesMK (TxIn blk) (TxOut blk)
forall k v. Map k v -> ValuesMK k v
ValuesMK Map (TxIn blk) (TxOut blk)
m'), (TxIn blk, TxOut blk) -> TxIn blk
forall a b. (a, b) -> a
fst ((TxIn blk, TxOut blk) -> TxIn blk)
-> Maybe (TxIn blk, TxOut blk) -> Maybe (TxIn blk)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map (TxIn blk) (TxOut blk) -> Maybe (TxIn blk, TxOut blk)
forall k a. Map k a -> Maybe (k, a)
Map.lookupMax Map (TxIn blk) (TxOut blk)
m')

implDuplicateWithDiffs ::
  ( IOLike m
  , HasLedgerTables l blk
  , CanUpgradeLedgerTables l blk
  , StandardHash (l blk)
  , GetTip (l blk)
  , SerializeTablesWithHint l blk
  ) =>
  Tracer m LedgerDBV2Trace ->
  LedgerTables blk ValuesMK ->
  SomeHasFS m ->
  l blk mk1 ->
  l blk DiffMK ->
  m (LedgerTablesHandle m l blk)
implDuplicateWithDiffs :: forall (m :: * -> *) (l :: StateKind) blk (mk1 :: MapKind).
(IOLike m, HasLedgerTables l blk, CanUpgradeLedgerTables l blk,
 StandardHash (l blk), GetTip (l blk),
 SerializeTablesWithHint l blk) =>
Tracer m LedgerDBV2Trace
-> LedgerTables blk ValuesMK
-> SomeHasFS m
-> l blk mk1
-> l blk DiffMK
-> m (LedgerTablesHandle m l blk)
implDuplicateWithDiffs !Tracer m LedgerDBV2Trace
tracer LedgerTables blk ValuesMK
tables !SomeHasFS m
someFS l blk mk1
st0 !l blk DiffMK
diffs = do
  let newtables :: LedgerTables blk ValuesMK
newtables =
        (LedgerTables blk ValuesMK
 -> LedgerTables blk DiffMK -> LedgerTables blk ValuesMK)
-> LedgerTables blk DiffMK
-> LedgerTables blk ValuesMK
-> LedgerTables blk ValuesMK
forall a b c. (a -> b -> c) -> b -> a -> c
flip
          ((forall k v.
 LedgerTableConstraints' blk k v =>
 ValuesMK k v -> DiffMK k v -> ValuesMK k v)
-> LedgerTables blk ValuesMK
-> LedgerTables blk DiffMK
-> LedgerTables blk ValuesMK
forall l (mk1 :: MapKind) (mk2 :: MapKind) (mk3 :: MapKind).
LedgerTableConstraints l =>
(forall k v.
 LedgerTableConstraints' blk k v =>
 mk1 k v -> mk2 k v -> mk3 k v)
-> LedgerTables l mk1 -> LedgerTables l mk2 -> LedgerTables l mk3
ltliftA2 (\(ValuesMK Map k v
vals) (DiffMK Diff k v
d) -> Map k v -> ValuesMK k v
forall k v. Map k v -> ValuesMK k v
ValuesMK (Map k v -> Diff k v -> Map k v
forall k v. Ord k => Map k v -> Diff k v -> Map k v
Diff.applyDiff Map k v
vals Diff k v
d)))
          (l blk DiffMK -> LedgerTables blk DiffMK
forall (mk :: MapKind).
(CanMapMK mk, CanMapKeysMK mk, ZeroableMK mk) =>
l blk mk -> LedgerTables blk mk
forall (l :: StateKind) blk (mk :: MapKind).
(HasLedgerTables l blk, CanMapMK mk, CanMapKeysMK mk,
 ZeroableMK mk) =>
l blk mk -> LedgerTables blk mk
projectLedgerTables l blk DiffMK
diffs)
          (LedgerTables blk ValuesMK -> LedgerTables blk ValuesMK)
-> (LedgerTables blk ValuesMK -> LedgerTables blk ValuesMK)
-> LedgerTables blk ValuesMK
-> LedgerTables blk ValuesMK
forall b c a. (b -> c) -> (a -> b) -> a -> c
. l blk mk1
-> l blk DiffMK
-> LedgerTables blk ValuesMK
-> LedgerTables blk ValuesMK
forall (mk1 :: MapKind) (mk2 :: MapKind).
l blk mk1
-> l blk mk2
-> LedgerTables blk ValuesMK
-> LedgerTables blk ValuesMK
forall (l :: StateKind) blk (mk1 :: MapKind) (mk2 :: MapKind).
CanUpgradeLedgerTables l blk =>
l blk mk1
-> l blk mk2
-> LedgerTables blk ValuesMK
-> LedgerTables blk ValuesMK
upgradeTables l blk mk1
st0 l blk DiffMK
diffs
          (LedgerTables blk ValuesMK -> LedgerTables blk ValuesMK)
-> LedgerTables blk ValuesMK -> LedgerTables blk ValuesMK
forall a b. (a -> b) -> a -> b
$ LedgerTables blk ValuesMK
tables
  Tracer m LedgerDBV2Trace
-> SomeHasFS m
-> LedgerTables blk ValuesMK
-> m (LedgerTablesHandle m l blk)
forall (m :: * -> *) (l :: StateKind) blk.
(IOLike m, HasLedgerTables l blk, CanUpgradeLedgerTables l blk,
 SerializeTablesWithHint l blk, StandardHash (l blk),
 GetTip (l blk)) =>
Tracer m LedgerDBV2Trace
-> SomeHasFS m
-> LedgerTables blk ValuesMK
-> m (LedgerTablesHandle m l blk)
newInMemoryLedgerTablesHandle Tracer m LedgerDBV2Trace
tracer SomeHasFS m
someFS LedgerTables blk ValuesMK
newtables

implTakeHandleSnapshot ::
  (IOLike m, SerializeTablesWithHint l blk) =>
  LedgerTables blk ValuesMK ->
  HasFS m h ->
  l blk EmptyMK ->
  String ->
  m (Maybe CRC)
implTakeHandleSnapshot :: forall (m :: * -> *) (l :: StateKind) blk h.
(IOLike m, SerializeTablesWithHint l blk) =>
LedgerTables blk ValuesMK
-> HasFS m h -> l blk EmptyMK -> String -> m (Maybe CRC)
implTakeHandleSnapshot LedgerTables blk ValuesMK
values HasFS m h
hasFS l blk EmptyMK
hint String
snapshotName = do
  HasFS m h -> HasCallStack => Bool -> FsPath -> m ()
forall (m :: * -> *) h.
HasFS m h -> HasCallStack => Bool -> FsPath -> m ()
createDirectoryIfMissing HasFS m h
hasFS Bool
True (FsPath -> m ()) -> FsPath -> m ()
forall a b. (a -> b) -> a -> b
$ [String] -> FsPath
mkFsPath [String
snapshotName]
  HasFS m h
-> FsPath
-> OpenMode
-> (Handle h -> m (Maybe CRC))
-> m (Maybe CRC)
forall (m :: * -> *) h a.
(HasCallStack, MonadThrow m) =>
HasFS m h -> FsPath -> OpenMode -> (Handle h -> m a) -> m a
withFile HasFS m h
hasFS ([String] -> FsPath
mkFsPath [String
snapshotName, String
"tables"]) (AllowExisting -> OpenMode
WriteMode AllowExisting
MustBeNew) ((Handle h -> m (Maybe CRC)) -> m (Maybe CRC))
-> (Handle h -> m (Maybe CRC)) -> m (Maybe CRC)
forall a b. (a -> b) -> a -> b
$ \Handle h
hf ->
    ((Word64, CRC) -> Maybe CRC) -> m (Word64, CRC) -> m (Maybe CRC)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (CRC -> Maybe CRC
forall a. a -> Maybe a
Just (CRC -> Maybe CRC)
-> ((Word64, CRC) -> CRC) -> (Word64, CRC) -> Maybe CRC
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word64, CRC) -> CRC
forall a b. (a, b) -> b
snd) (m (Word64, CRC) -> m (Maybe CRC))
-> m (Word64, CRC) -> m (Maybe CRC)
forall a b. (a -> b) -> a -> b
$
      HasFS m h -> Handle h -> ByteString -> m (Word64, CRC)
forall (m :: * -> *) h.
(HasCallStack, Monad m) =>
HasFS m h -> Handle h -> ByteString -> m (Word64, CRC)
hPutAllCRC HasFS m h
hasFS Handle h
hf (ByteString -> m (Word64, CRC)) -> ByteString -> m (Word64, CRC)
forall a b. (a -> b) -> a -> b
$
        Encoding -> ByteString
CBOR.toLazyByteString (Encoding -> ByteString) -> Encoding -> ByteString
forall a b. (a -> b) -> a -> b
$
          l blk EmptyMK -> LedgerTables blk ValuesMK -> Encoding
forall (l :: StateKind) blk.
SerializeTablesWithHint l blk =>
l blk EmptyMK -> LedgerTables blk ValuesMK -> Encoding
valuesMKEncoder l blk EmptyMK
hint LedgerTables blk ValuesMK
values

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

snapshotManager ::
  ( IOLike m
  , LedgerDbSerialiseConstraints blk
  , LedgerSupportsProtocol blk
  ) =>
  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) =>
CodecConfig blk
-> Tracer m (TraceSnapshotEvent blk)
-> SomeHasFS m
-> SnapshotManager m blk (StateRef m ExtLedgerState blk)
snapshotManager 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 = SomeHasFS m
-> Tracer m (TraceSnapshotEvent blk) -> DiskSnapshot -> m ()
forall (m :: * -> *) blk.
(MonadCatch m, HasCallStack) =>
SomeHasFS m
-> Tracer m (TraceSnapshotEvent blk) -> DiskSnapshot -> m ()
defaultDeleteSnapshotIfTemporary SomeHasFS m
fs Tracer m (TraceSnapshotEvent blk)
tracer
    , takeSnapshot :: Maybe String
-> StateRef m ExtLedgerState blk
-> m (Maybe (DiskSnapshot, RealPoint blk))
takeSnapshot = CodecConfig blk
-> Tracer m (TraceSnapshotEvent blk)
-> SomeHasFS m
-> Maybe String
-> 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 String
-> StateRef m ExtLedgerState blk
-> m (Maybe (DiskSnapshot, RealPoint blk))
implTakeSnapshot CodecConfig blk
ccfg Tracer m (TraceSnapshotEvent blk)
tracer SomeHasFS m
fs
    }

{-# INLINE implTakeSnapshot #-}
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 String
-> 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 String
suffix StateRef m ExtLedgerState blk
st = do
  case Point blk -> WithOrigin (RealPoint blk)
forall blk. Point blk -> WithOrigin (RealPoint blk)
pointToWithOriginRealPoint (Point (ExtLedgerState blk) -> Point blk
forall {k1} {k2} (b :: k1) (b' :: k2).
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint (ExtLedgerState blk EmptyMK -> Point (ExtLedgerState blk)
forall (mk :: MapKind).
ExtLedgerState blk mk -> Point (ExtLedgerState blk)
forall (l :: LedgerStateKind) (mk :: MapKind).
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 :: StateKind) 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 String -> DiskSnapshot
DiskSnapshot Word64
number Maybe String
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
          encloseTimedWith (TookSnapshot snapshot t >$< tracer) $
            writeSnapshot snapshot
          return $ Just (snapshot, t)
 where
  writeSnapshot :: DiskSnapshot -> m ()
writeSnapshot 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)) =>
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 :: StateKind) blk.
StateRef m l blk -> l blk EmptyMK
state StateRef m ExtLedgerState blk
st
    crc2 <- takeHandleSnapshot (StateRef.tables st) (state st) $ snapshotToDirName ds
    writeSnapshotMetadata shfs ds $
      SnapshotMetadata
        { snapshotBackend = UTxOHDMemSnapshot
        , snapshotChecksum = maybe crc1 (crcOfConcat crc1) crc2
        , snapshotTablesCodecVersion = TablesCodecVersion1
        }

-- | 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
  , CanUpgradeLedgerTables LedgerState blk
  , IOLike m
  ) =>
  Tracer m LedgerDBV2Trace ->
  CodecConfig blk ->
  SomeHasFS m ->
  DiskSnapshot ->
  ExceptT (SnapshotFailure blk) m (StateRef m ExtLedgerState blk, RealPoint blk)
loadSnapshot :: forall blk (m :: * -> *).
(LedgerDbSerialiseConstraints blk, LedgerSupportsProtocol blk,
 CanUpgradeLedgerTables LedgerState blk, IOLike m) =>
Tracer m LedgerDBV2Trace
-> CodecConfig blk
-> SomeHasFS m
-> 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) 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 /= UTxOHDMemSnapshot) $
    throwE $
      InitFailureRead $
        ReadMetadataError (snapshotToMetadataPath ds) MetadataBackendMismatch
  (extLedgerSt, checksumAsRead) <-
    withExceptT
      (InitFailureRead . ReadSnapshotFailed)
      $ readExtLedgerState fs (decodeDiskExtLedgerState ccfg) decode (snapshotToStatePath ds)
  case pointToWithOriginRealPoint (castPoint (getTip extLedgerSt)) of
    WithOrigin (RealPoint blk)
Origin -> SnapshotFailure blk
-> ExceptT
     (SnapshotFailure blk)
     m
     (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, Identity crcTables) <-
        (ReadIncrementalErr -> SnapshotFailure blk)
-> ExceptT
     ReadIncrementalErr m (LedgerTables blk ValuesMK, Identity CRC)
-> ExceptT
     (SnapshotFailure blk) m (LedgerTables blk ValuesMK, Identity CRC)
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT (ReadSnapshotErr -> SnapshotFailure blk
forall blk. ReadSnapshotErr -> SnapshotFailure blk
InitFailureRead (ReadSnapshotErr -> SnapshotFailure blk)
-> (ReadIncrementalErr -> ReadSnapshotErr)
-> ReadIncrementalErr
-> SnapshotFailure blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReadIncrementalErr -> ReadSnapshotErr
ReadSnapshotFailed) (ExceptT
   ReadIncrementalErr m (LedgerTables blk ValuesMK, Identity CRC)
 -> ExceptT
      (SnapshotFailure blk) m (LedgerTables blk ValuesMK, Identity CRC))
-> ExceptT
     ReadIncrementalErr m (LedgerTables blk ValuesMK, Identity CRC)
-> ExceptT
     (SnapshotFailure blk) m (LedgerTables blk ValuesMK, Identity CRC)
forall a b. (a -> b) -> a -> b
$
          m (Either
     ReadIncrementalErr (LedgerTables blk ValuesMK, Identity CRC))
-> ExceptT
     ReadIncrementalErr m (LedgerTables blk ValuesMK, Identity CRC)
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (m (Either
      ReadIncrementalErr (LedgerTables blk ValuesMK, Identity CRC))
 -> ExceptT
      ReadIncrementalErr m (LedgerTables blk ValuesMK, Identity CRC))
-> m (Either
        ReadIncrementalErr (LedgerTables blk ValuesMK, Identity CRC))
-> ExceptT
     ReadIncrementalErr m (LedgerTables blk ValuesMK, Identity CRC)
forall a b. (a -> b) -> a -> b
$
            SomeHasFS m
-> (CRC -> Identity CRC)
-> Decoder (PrimState m) (LedgerTables blk ValuesMK)
-> FsPath
-> m (Either
        ReadIncrementalErr (LedgerTables blk ValuesMK, Identity CRC))
forall (m :: * -> *) (f :: * -> *) a.
(IOLike m, Functor f) =>
SomeHasFS m
-> (CRC -> f CRC)
-> Decoder (PrimState m) a
-> FsPath
-> m (Either ReadIncrementalErr (a, f CRC))
readIncremental
              SomeHasFS m
fs
              CRC -> Identity CRC
forall a. a -> Identity a
Identity
              (ExtLedgerState blk EmptyMK
-> Decoder (PrimState m) (LedgerTables blk ValuesMK)
forall (l :: StateKind) blk s.
SerializeTablesWithHint l blk =>
l blk EmptyMK -> Decoder s (LedgerTables blk ValuesMK)
valuesMKDecoder ExtLedgerState blk EmptyMK
extLedgerSt)
              (DiskSnapshot -> FsPath
snapshotToTablesPath DiskSnapshot
ds)
      let computedCRC = CRC -> CRC -> CRC
crcOfConcat CRC
checksumAsRead CRC
crcTables
      Monad.when (computedCRC /= snapshotChecksum snapshotMeta) $
        throwE $
          InitFailureRead $
            ReadSnapshotDataCorruption
      h <- lift $ newInMemoryLedgerTablesHandle tracer fs values
      pure (StateRef extLedgerSt h, pt)

snapshotToTablesPath :: DiskSnapshot -> FsPath
snapshotToTablesPath :: DiskSnapshot -> FsPath
snapshotToTablesPath DiskSnapshot
ds = DiskSnapshot -> FsPath
snapshotToDirPath DiskSnapshot
ds FsPath -> FsPath -> FsPath
</> [String] -> FsPath
mkFsPath [String
"tables"]

type data Mem

instance
  ( IOLike m
  , LedgerDbSerialiseConstraints blk
  , LedgerSupportsProtocol blk
  , CanUpgradeLedgerTables LedgerState blk
  ) =>
  Backend m Mem blk
  where
  data Args m Mem = InMemArgs
  newtype Resources m Mem = Resources (SomeHasFS m)
    deriving newtype [String] -> Resources m Mem -> IO (Maybe ThunkInfo)
Proxy (Resources m Mem) -> String
([String] -> Resources m Mem -> IO (Maybe ThunkInfo))
-> ([String] -> Resources m Mem -> IO (Maybe ThunkInfo))
-> (Proxy (Resources m Mem) -> String)
-> NoThunks (Resources m Mem)
forall a.
([String] -> a -> IO (Maybe ThunkInfo))
-> ([String] -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
forall (m :: * -> *).
[String] -> Resources m Mem -> IO (Maybe ThunkInfo)
forall (m :: * -> *). Proxy (Resources m Mem) -> String
$cnoThunks :: forall (m :: * -> *).
[String] -> Resources m Mem -> IO (Maybe ThunkInfo)
noThunks :: [String] -> Resources m Mem -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall (m :: * -> *).
[String] -> Resources m Mem -> IO (Maybe ThunkInfo)
wNoThunks :: [String] -> Resources m Mem -> IO (Maybe ThunkInfo)
$cshowTypeOf :: forall (m :: * -> *). Proxy (Resources m Mem) -> String
showTypeOf :: Proxy (Resources m Mem) -> String
NoThunks
  newtype Trace Mem = NoTrace Void
    deriving newtype Int -> Trace Mem -> ShowS
[Trace Mem] -> ShowS
Trace Mem -> String
(Int -> Trace Mem -> ShowS)
-> (Trace Mem -> String)
-> ([Trace Mem] -> ShowS)
-> Show (Trace Mem)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Trace Mem -> ShowS
showsPrec :: Int -> Trace Mem -> ShowS
$cshow :: Trace Mem -> String
show :: Trace Mem -> String
$cshowList :: [Trace Mem] -> ShowS
showList :: [Trace Mem] -> ShowS
Show

  mkResources :: forall fState.
Proxy blk
-> Tracer m LedgerDBV2Trace
-> Args m Mem
-> SomeHasFS m
-> WithTempRegistry fState m (Resources m Mem)
mkResources Proxy blk
_ Tracer m LedgerDBV2Trace
_ Args m Mem
_ = Resources m Mem -> WithTempRegistry fState m (Resources m Mem)
forall a. a -> WithTempRegistry fState m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Resources m Mem -> WithTempRegistry fState m (Resources m Mem))
-> (SomeHasFS m -> Resources m Mem)
-> SomeHasFS m
-> WithTempRegistry fState m (Resources m Mem)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeHasFS m -> Resources m Mem
forall (m :: * -> *). SomeHasFS m -> Resources m Mem
Resources
  releaseResources :: Proxy blk -> Resources m Mem -> m ()
releaseResources Proxy blk
_ Resources m Mem
_ = () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  createAndPopulateStateRefFromGenesis :: Tracer m LedgerDBV2Trace
-> Resources m Mem
-> ExtLedgerState blk ValuesMK
-> m (StateRef m ExtLedgerState blk)
createAndPopulateStateRefFromGenesis Tracer m LedgerDBV2Trace
tracer (Resources SomeHasFS m
shfs) ExtLedgerState blk ValuesMK
values =
    ExtLedgerState blk EmptyMK
-> LedgerTablesHandle m ExtLedgerState blk
-> StateRef m ExtLedgerState blk
forall (m :: * -> *) (l :: StateKind) blk.
l blk EmptyMK -> LedgerTablesHandle m l blk -> StateRef m l blk
StateRef (ExtLedgerState blk ValuesMK -> ExtLedgerState blk EmptyMK
forall (l :: StateKind) blk (mk :: MapKind).
HasLedgerTables l blk =>
l blk mk -> l blk EmptyMK
forgetLedgerTables ExtLedgerState blk ValuesMK
values)
      (LedgerTablesHandle m ExtLedgerState blk
 -> StateRef m ExtLedgerState blk)
-> m (LedgerTablesHandle m ExtLedgerState blk)
-> m (StateRef m ExtLedgerState blk)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Tracer m LedgerDBV2Trace
-> SomeHasFS m
-> LedgerTables blk ValuesMK
-> m (LedgerTablesHandle m ExtLedgerState blk)
forall (m :: * -> *) (l :: StateKind) blk.
(IOLike m, HasLedgerTables l blk, CanUpgradeLedgerTables l blk,
 SerializeTablesWithHint l blk, StandardHash (l blk),
 GetTip (l blk)) =>
Tracer m LedgerDBV2Trace
-> SomeHasFS m
-> LedgerTables blk ValuesMK
-> m (LedgerTablesHandle m l blk)
newInMemoryLedgerTablesHandle Tracer m LedgerDBV2Trace
tracer SomeHasFS m
shfs (ExtLedgerState blk ValuesMK -> LedgerTables blk ValuesMK
forall (l :: StateKind) blk (mk :: MapKind).
(HasLedgerTables l blk, CanMapMK mk, CanMapKeysMK mk,
 ZeroableMK mk) =>
l blk mk -> LedgerTables blk mk
ltprj ExtLedgerState blk ValuesMK
values)
  openStateRefFromSnapshot :: Tracer m LedgerDBV2Trace
-> CodecConfig blk
-> SomeHasFS m
-> Resources m Mem
-> DiskSnapshot
-> ExceptT
     (SnapshotFailure blk)
     m
     (StateRef m ExtLedgerState blk, RealPoint blk)
openStateRefFromSnapshot Tracer m LedgerDBV2Trace
trcr CodecConfig blk
ccfg SomeHasFS m
shfs Resources m Mem
_ DiskSnapshot
ds =
    Tracer m LedgerDBV2Trace
-> CodecConfig blk
-> SomeHasFS m
-> DiskSnapshot
-> ExceptT
     (SnapshotFailure blk)
     m
     (StateRef m ExtLedgerState blk, RealPoint blk)
forall blk (m :: * -> *).
(LedgerDbSerialiseConstraints blk, LedgerSupportsProtocol blk,
 CanUpgradeLedgerTables LedgerState blk, IOLike m) =>
Tracer m LedgerDBV2Trace
-> CodecConfig blk
-> SomeHasFS m
-> DiskSnapshot
-> ExceptT
     (SnapshotFailure blk)
     m
     (StateRef m ExtLedgerState blk, RealPoint blk)
loadSnapshot Tracer m LedgerDBV2Trace
trcr CodecConfig blk
ccfg SomeHasFS m
shfs DiskSnapshot
ds
  snapshotManager :: Proxy blk
-> Resources m Mem
-> CodecConfig blk
-> Tracer m (TraceSnapshotEvent blk)
-> SomeHasFS m
-> SnapshotManager m blk (StateRef m ExtLedgerState blk)
snapshotManager Proxy blk
_ Resources m Mem
_ =
    CodecConfig blk
-> Tracer m (TraceSnapshotEvent blk)
-> SomeHasFS m
-> SnapshotManager m blk (StateRef m ExtLedgerState blk)
forall (m :: * -> *) blk.
(IOLike m, LedgerDbSerialiseConstraints blk,
 LedgerSupportsProtocol blk) =>
CodecConfig blk
-> Tracer m (TraceSnapshotEvent blk)
-> SomeHasFS m
-> SnapshotManager m blk (StateRef m ExtLedgerState blk)
Ouroboros.Consensus.Storage.LedgerDB.V2.InMemory.snapshotManager

-- | Create arguments for initializing the LedgerDB using the InMemory backend.
mkInMemoryArgs ::
  ( IOLike m
  , LedgerDbSerialiseConstraints blk
  , LedgerSupportsProtocol blk
  , CanUpgradeLedgerTables LedgerState blk
  ) =>
  a -> (LedgerDbBackendArgs m blk, a)
mkInMemoryArgs :: forall (m :: * -> *) blk a.
(IOLike m, LedgerDbSerialiseConstraints blk,
 LedgerSupportsProtocol blk,
 CanUpgradeLedgerTables LedgerState blk) =>
a -> (LedgerDbBackendArgs m blk, a)
mkInMemoryArgs = (,) (LedgerDbBackendArgs m blk -> a -> (LedgerDbBackendArgs m blk, a))
-> LedgerDbBackendArgs m blk -> a -> (LedgerDbBackendArgs m blk, a)
forall a b. (a -> b) -> a -> b
$ SomeBackendArgs m blk -> LedgerDbBackendArgs m blk
forall (m :: * -> *) blk.
SomeBackendArgs m blk -> LedgerDbBackendArgs m blk
LedgerDbBackendArgsV2 (SomeBackendArgs m blk -> LedgerDbBackendArgs m blk)
-> SomeBackendArgs m blk -> LedgerDbBackendArgs m blk
forall a b. (a -> b) -> a -> b
$ Args m Mem -> SomeBackendArgs m blk
forall (m :: * -> *) backend blk.
Backend m backend blk =>
Args m backend -> SomeBackendArgs m blk
SomeBackendArgs Args m Mem
forall (m :: * -> *). Args m Mem
InMemArgs

instance IOLike m => StreamingBackend m Mem l blk where
  data YieldArgs m Mem l blk
    = -- \| Yield an in-memory snapshot
      YieldInMemory
        -- \| The file system anchored at the snapshots directory
        (SomeHasFS m)
        -- \| The snapshot
        DiskSnapshot
        (Decoders blk)

  data SinkArgs m Mem l blk
    = SinkInMemory
        Int
        (TxIn blk -> Encoding)
        (TxOut blk -> Encoding)
        (SomeHasFS m)
        DiskSnapshot

  releaseYieldArgs :: YieldArgs m Mem l blk -> m ()
releaseYieldArgs YieldArgs m Mem l blk
_ = () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  yield :: Proxy Mem -> YieldArgs m Mem l blk -> Yield m l blk
yield Proxy Mem
_ (YieldInMemory SomeHasFS m
fs DiskSnapshot
ds (Decoders forall s. Decoder s (TxIn blk)
decK forall s. Decoder s (TxOut blk)
decV)) =
    SomeHasFS m
-> DiskSnapshot
-> (forall s. Decoder s (TxIn blk))
-> (forall s. Decoder s (TxOut blk))
-> Yield m l blk
forall (m :: * -> *) blk (l :: StateKind).
(MonadThrow m, MonadST m) =>
SomeHasFS m
-> DiskSnapshot
-> (forall s. Decoder s (TxIn blk))
-> (forall s. Decoder s (TxOut blk))
-> Yield m l blk
yieldInMemoryS SomeHasFS m
fs DiskSnapshot
ds Decoder s (TxIn blk)
forall s. Decoder s (TxIn blk)
decK Decoder s (TxOut blk)
forall s. Decoder s (TxOut blk)
decV

  releaseSinkArgs :: SinkArgs m Mem l blk -> m ()
releaseSinkArgs SinkArgs m Mem l blk
_ = () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  sink :: Proxy Mem -> SinkArgs m Mem l blk -> Sink m l blk
sink Proxy Mem
_ (SinkInMemory Int
chunkSize TxIn blk -> Encoding
encK TxOut blk -> Encoding
encV SomeHasFS m
shfs DiskSnapshot
ds) =
    Int
-> (TxIn blk -> Encoding)
-> (TxOut blk -> Encoding)
-> SomeHasFS m
-> DiskSnapshot
-> Sink m l blk
forall (m :: * -> *) (l :: StateKind) blk.
MonadThrow m =>
Int
-> (TxIn blk -> Encoding)
-> (TxOut blk -> Encoding)
-> SomeHasFS m
-> DiskSnapshot
-> Sink m l blk
sinkInMemoryS Int
chunkSize TxIn blk -> Encoding
encK TxOut blk -> Encoding
encV SomeHasFS m
shfs DiskSnapshot
ds

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

streamingFile ::
  forall m.
  MonadThrow m =>
  SomeHasFS m ->
  FsPath ->
  ( Stream (Of ByteString) m (Maybe CRC) ->
    ExceptT DeserialiseFailure m (Stream (Of ByteString) m (Maybe CRC, Maybe CRC))
  ) ->
  ExceptT DeserialiseFailure m (Maybe CRC, Maybe CRC)
streamingFile :: forall (m :: * -> *).
MonadThrow m =>
SomeHasFS m
-> FsPath
-> (Stream (Of ByteString) m (Maybe CRC)
    -> ExceptT
         DeserialiseFailure
         m
         (Stream (Of ByteString) m (Maybe CRC, Maybe CRC)))
-> ExceptT DeserialiseFailure m (Maybe CRC, Maybe CRC)
streamingFile (SomeHasFS HasFS m h
fs') FsPath
path Stream (Of ByteString) m (Maybe CRC)
-> ExceptT
     DeserialiseFailure
     m
     (Stream (Of ByteString) m (Maybe CRC, Maybe CRC))
cont =
  m (Either DeserialiseFailure (Maybe CRC, Maybe CRC))
-> ExceptT DeserialiseFailure m (Maybe CRC, Maybe CRC)
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (m (Either DeserialiseFailure (Maybe CRC, Maybe CRC))
 -> ExceptT DeserialiseFailure m (Maybe CRC, Maybe CRC))
-> m (Either DeserialiseFailure (Maybe CRC, Maybe CRC))
-> ExceptT DeserialiseFailure m (Maybe CRC, Maybe CRC)
forall a b. (a -> b) -> a -> b
$ HasFS m h
-> FsPath
-> OpenMode
-> (Handle h
    -> m (Either DeserialiseFailure (Maybe CRC, Maybe CRC)))
-> m (Either DeserialiseFailure (Maybe CRC, Maybe CRC))
forall (m :: * -> *) h a.
(HasCallStack, MonadThrow m) =>
HasFS m h -> FsPath -> OpenMode -> (Handle h -> m a) -> m a
withFile HasFS m h
fs' FsPath
path OpenMode
ReadMode ((Handle h -> m (Either DeserialiseFailure (Maybe CRC, Maybe CRC)))
 -> m (Either DeserialiseFailure (Maybe CRC, Maybe CRC)))
-> (Handle h
    -> m (Either DeserialiseFailure (Maybe CRC, Maybe CRC)))
-> m (Either DeserialiseFailure (Maybe CRC, Maybe CRC))
forall a b. (a -> b) -> a -> b
$ \Handle h
hdl ->
    ExceptT DeserialiseFailure m (Maybe CRC, Maybe CRC)
-> m (Either DeserialiseFailure (Maybe CRC, Maybe CRC))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT DeserialiseFailure m (Maybe CRC, Maybe CRC)
 -> m (Either DeserialiseFailure (Maybe CRC, Maybe CRC)))
-> ExceptT DeserialiseFailure m (Maybe CRC, Maybe CRC)
-> m (Either DeserialiseFailure (Maybe CRC, Maybe CRC))
forall a b. (a -> b) -> a -> b
$ Stream (Of ByteString) m (Maybe CRC)
-> ExceptT
     DeserialiseFailure
     m
     (Stream (Of ByteString) m (Maybe CRC, Maybe CRC))
cont (Handle h -> CRC -> Stream (Of ByteString) m (Maybe CRC)
getBS Handle h
hdl CRC
initCRC) ExceptT
  DeserialiseFailure
  m
  (Stream (Of ByteString) m (Maybe CRC, Maybe CRC))
-> (Stream (Of ByteString) m (Maybe CRC, Maybe CRC)
    -> ExceptT DeserialiseFailure m (Maybe CRC, Maybe CRC))
-> ExceptT DeserialiseFailure m (Maybe CRC, Maybe CRC)
forall a b.
ExceptT DeserialiseFailure m a
-> (a -> ExceptT DeserialiseFailure m b)
-> ExceptT DeserialiseFailure m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Stream (Of ByteString) m (Maybe CRC, Maybe CRC)
-> ExceptT DeserialiseFailure m (Maybe CRC, Maybe CRC)
forall {t :: (* -> *) -> * -> *} {m :: * -> *} {b}.
(MonadTrans t, Monad m, MonadError DeserialiseFailure (t m)) =>
Stream (Of ByteString) m b -> t m b
noRemainingBytes
 where
  getBS :: Handle h -> CRC -> Stream (Of ByteString) m (Maybe CRC)
getBS Handle h
h !CRC
crc = do
    bs <- m ByteString -> Stream (Of ByteString) m ByteString
forall (m :: * -> *) a.
Monad m =>
m a -> Stream (Of ByteString) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
S.lift (m ByteString -> Stream (Of ByteString) m ByteString)
-> m ByteString -> Stream (Of ByteString) m ByteString
forall a b. (a -> b) -> a -> b
$ HasFS m h -> HasCallStack => Handle h -> Word64 -> m ByteString
forall (m :: * -> *) h.
HasFS m h -> HasCallStack => Handle h -> Word64 -> m ByteString
hGetSome HasFS m h
fs' Handle h
h (Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
defaultChunkSize)
    if BS.null bs
      then pure (Just crc)
      else do
        S.yield bs
        getBS h $! updateCRC bs crc

  noRemainingBytes :: Stream (Of ByteString) m b -> t m b
noRemainingBytes Stream (Of ByteString) m b
s =
    m (Maybe (ByteString, Stream (Of ByteString) m b))
-> t m (Maybe (ByteString, Stream (Of ByteString) m b))
forall (m :: * -> *) a. Monad m => m a -> t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Stream (Of ByteString) m b
-> m (Maybe (ByteString, Stream (Of ByteString) m b))
forall (m :: * -> *) a r.
Monad m =>
Stream (Of a) m r -> m (Maybe (a, Stream (Of a) m r))
S.uncons Stream (Of ByteString) m b
s) t m (Maybe (ByteString, Stream (Of ByteString) m b))
-> (Maybe (ByteString, Stream (Of ByteString) m b) -> t m b)
-> t m b
forall a b. t m a -> (a -> t m b) -> t m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Maybe (ByteString, Stream (Of ByteString) m b)
Nothing -> m b -> t m b
forall (m :: * -> *) a. Monad m => m a -> t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m b -> t m b) -> m b -> t m b
forall a b. (a -> b) -> a -> b
$ Stream (Of ByteString) m b -> m b
forall (m :: * -> *) a r. Monad m => Stream (Of a) m r -> m r
S.effects Stream (Of ByteString) m b
s
      Just (ByteString -> Bool
BS.null -> Bool
True, Stream (Of ByteString) m b
s') -> Stream (Of ByteString) m b -> t m b
noRemainingBytes Stream (Of ByteString) m b
s'
      Just (ByteString, Stream (Of ByteString) m b)
_ -> DeserialiseFailure -> t m b
forall a. DeserialiseFailure -> t m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (DeserialiseFailure -> t m b) -> DeserialiseFailure -> t m b
forall a b. (a -> b) -> a -> b
$ ByteOffset -> String -> DeserialiseFailure
DeserialiseFailure ByteOffset
0 String
"Remaining bytes"

yieldCborMapS ::
  forall m a b.
  MonadST m =>
  (forall s. Decoder s a) ->
  (forall s. Decoder s b) ->
  Stream (Of ByteString) m (Maybe CRC) ->
  Stream (Of (a, b)) (ExceptT DeserialiseFailure m) (Stream (Of ByteString) m (Maybe CRC))
yieldCborMapS :: forall (m :: * -> *) a b.
MonadST m =>
(forall s. Decoder s a)
-> (forall s. Decoder s b)
-> Stream (Of ByteString) m (Maybe CRC)
-> Stream
     (Of (a, b))
     (ExceptT DeserialiseFailure m)
     (Stream (Of ByteString) m (Maybe CRC))
yieldCborMapS forall s. Decoder s a
decK forall s. Decoder s b
decV = StateT
  (Stream (Of ByteString) m (Maybe CRC))
  (Stream (Of (a, b)) (ExceptT DeserialiseFailure m))
  ()
-> Stream (Of ByteString) m (Maybe CRC)
-> Stream
     (Of (a, b))
     (ExceptT DeserialiseFailure m)
     (Stream (Of ByteString) m (Maybe CRC))
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
execStateT (StateT
   (Stream (Of ByteString) m (Maybe CRC))
   (Stream (Of (a, b)) (ExceptT DeserialiseFailure m))
   ()
 -> Stream (Of ByteString) m (Maybe CRC)
 -> Stream
      (Of (a, b))
      (ExceptT DeserialiseFailure m)
      (Stream (Of ByteString) m (Maybe CRC)))
-> StateT
     (Stream (Of ByteString) m (Maybe CRC))
     (Stream (Of (a, b)) (ExceptT DeserialiseFailure m))
     ()
-> Stream (Of ByteString) m (Maybe CRC)
-> Stream
     (Of (a, b))
     (ExceptT DeserialiseFailure m)
     (Stream (Of ByteString) m (Maybe CRC))
forall a b. (a -> b) -> a -> b
$ do
  (forall a.
 ExceptT DeserialiseFailure m a
 -> Stream (Of (a, b)) (ExceptT DeserialiseFailure m) a)
-> StateT
     (Stream (Of ByteString) m (Maybe CRC))
     (ExceptT DeserialiseFailure m)
     (Maybe Int)
-> StateT
     (Stream (Of ByteString) m (Maybe CRC))
     (Stream (Of (a, b)) (ExceptT DeserialiseFailure m))
     (Maybe Int)
forall {k} (t :: (* -> *) -> k -> *) (m :: * -> *) (n :: * -> *)
       (b :: k).
(MFunctor t, Monad m) =>
(forall a. m a -> n a) -> t m b -> t n b
forall (m :: * -> *) (n :: * -> *) b.
Monad m =>
(forall a. m a -> n a)
-> StateT (Stream (Of ByteString) m (Maybe CRC)) m b
-> StateT (Stream (Of ByteString) m (Maybe CRC)) n b
hoist ExceptT DeserialiseFailure m a
-> Stream (Of (a, b)) (ExceptT DeserialiseFailure m) a
forall a.
ExceptT DeserialiseFailure m a
-> Stream (Of (a, b)) (ExceptT DeserialiseFailure m) a
forall (m :: * -> *) a. Monad m => m a -> Stream (Of (a, b)) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Decoder (PrimState m) Int
-> StateT
     (Stream (Of ByteString) m (Maybe CRC))
     (ExceptT DeserialiseFailure m)
     Int
forall {t :: (* -> *) -> * -> *} {m :: * -> *} {a} {b}.
(MonadTrans t, MonadST m, MonadError DeserialiseFailure (t m)) =>
Decoder (PrimState m) a
-> StateT (Stream (Of ByteString) m b) (t m) a
decodeCbor Decoder (PrimState m) Int
forall s. Decoder s Int
decodeListLen StateT
  (Stream (Of ByteString) m (Maybe CRC))
  (ExceptT DeserialiseFailure m)
  Int
-> StateT
     (Stream (Of ByteString) m (Maybe CRC))
     (ExceptT DeserialiseFailure m)
     (Maybe Int)
-> StateT
     (Stream (Of ByteString) m (Maybe CRC))
     (ExceptT DeserialiseFailure m)
     (Maybe Int)
forall a b.
StateT
  (Stream (Of ByteString) m (Maybe CRC))
  (ExceptT DeserialiseFailure m)
  a
-> StateT
     (Stream (Of ByteString) m (Maybe CRC))
     (ExceptT DeserialiseFailure m)
     b
-> StateT
     (Stream (Of ByteString) m (Maybe CRC))
     (ExceptT DeserialiseFailure m)
     b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Decoder (PrimState m) (Maybe Int)
-> StateT
     (Stream (Of ByteString) m (Maybe CRC))
     (ExceptT DeserialiseFailure m)
     (Maybe Int)
forall {t :: (* -> *) -> * -> *} {m :: * -> *} {a} {b}.
(MonadTrans t, MonadST m, MonadError DeserialiseFailure (t m)) =>
Decoder (PrimState m) a
-> StateT (Stream (Of ByteString) m b) (t m) a
decodeCbor Decoder (PrimState m) (Maybe Int)
forall s. Decoder s (Maybe Int)
decodeMapLenOrIndef) StateT
  (Stream (Of ByteString) m (Maybe CRC))
  (Stream (Of (a, b)) (ExceptT DeserialiseFailure m))
  (Maybe Int)
-> (Maybe Int
    -> StateT
         (Stream (Of ByteString) m (Maybe CRC))
         (Stream (Of (a, b)) (ExceptT DeserialiseFailure m))
         ())
-> StateT
     (Stream (Of ByteString) m (Maybe CRC))
     (Stream (Of (a, b)) (ExceptT DeserialiseFailure m))
     ()
forall a b.
StateT
  (Stream (Of ByteString) m (Maybe CRC))
  (Stream (Of (a, b)) (ExceptT DeserialiseFailure m))
  a
-> (a
    -> StateT
         (Stream (Of ByteString) m (Maybe CRC))
         (Stream (Of (a, b)) (ExceptT DeserialiseFailure m))
         b)
-> StateT
     (Stream (Of ByteString) m (Maybe CRC))
     (Stream (Of (a, b)) (ExceptT DeserialiseFailure m))
     b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe Int
Nothing -> StateT
  (Stream (Of ByteString) m (Maybe CRC))
  (Stream (Of (a, b)) (ExceptT DeserialiseFailure m))
  ()
go
    Just Int
n -> Int
-> StateT
     (Stream (Of ByteString) m (Maybe CRC))
     (Stream (Of (a, b)) (ExceptT DeserialiseFailure m))
     ()
-> StateT
     (Stream (Of ByteString) m (Maybe CRC))
     (Stream (Of (a, b)) (ExceptT DeserialiseFailure m))
     ()
forall (m :: * -> *) a. Applicative m => Int -> m a -> m ()
replicateM_ Int
n StateT
  (Stream (Of ByteString) m (Maybe CRC))
  (Stream (Of (a, b)) (ExceptT DeserialiseFailure m))
  ()
yieldKV
 where
  yieldKV :: StateT
  (Stream (Of ByteString) m (Maybe CRC))
  (Stream (Of (a, b)) (ExceptT DeserialiseFailure m))
  ()
yieldKV = do
    kv <- (forall a.
 ExceptT DeserialiseFailure m a
 -> Stream (Of (a, b)) (ExceptT DeserialiseFailure m) a)
-> StateT
     (Stream (Of ByteString) m (Maybe CRC))
     (ExceptT DeserialiseFailure m)
     (a, b)
-> StateT
     (Stream (Of ByteString) m (Maybe CRC))
     (Stream (Of (a, b)) (ExceptT DeserialiseFailure m))
     (a, b)
forall {k} (t :: (* -> *) -> k -> *) (m :: * -> *) (n :: * -> *)
       (b :: k).
(MFunctor t, Monad m) =>
(forall a. m a -> n a) -> t m b -> t n b
forall (m :: * -> *) (n :: * -> *) b.
Monad m =>
(forall a. m a -> n a)
-> StateT (Stream (Of ByteString) m (Maybe CRC)) m b
-> StateT (Stream (Of ByteString) m (Maybe CRC)) n b
hoist ExceptT DeserialiseFailure m a
-> Stream (Of (a, b)) (ExceptT DeserialiseFailure m) a
forall a.
ExceptT DeserialiseFailure m a
-> Stream (Of (a, b)) (ExceptT DeserialiseFailure m) a
forall (m :: * -> *) a. Monad m => m a -> Stream (Of (a, b)) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT
   (Stream (Of ByteString) m (Maybe CRC))
   (ExceptT DeserialiseFailure m)
   (a, b)
 -> StateT
      (Stream (Of ByteString) m (Maybe CRC))
      (Stream (Of (a, b)) (ExceptT DeserialiseFailure m))
      (a, b))
-> StateT
     (Stream (Of ByteString) m (Maybe CRC))
     (ExceptT DeserialiseFailure m)
     (a, b)
-> StateT
     (Stream (Of ByteString) m (Maybe CRC))
     (Stream (Of (a, b)) (ExceptT DeserialiseFailure m))
     (a, b)
forall a b. (a -> b) -> a -> b
$ Decoder (PrimState m) (a, b)
-> StateT
     (Stream (Of ByteString) m (Maybe CRC))
     (ExceptT DeserialiseFailure m)
     (a, b)
forall {t :: (* -> *) -> * -> *} {m :: * -> *} {a} {b}.
(MonadTrans t, MonadST m, MonadError DeserialiseFailure (t m)) =>
Decoder (PrimState m) a
-> StateT (Stream (Of ByteString) m b) (t m) a
decodeCbor (Decoder (PrimState m) (a, b)
 -> StateT
      (Stream (Of ByteString) m (Maybe CRC))
      (ExceptT DeserialiseFailure m)
      (a, b))
-> Decoder (PrimState m) (a, b)
-> StateT
     (Stream (Of ByteString) m (Maybe CRC))
     (ExceptT DeserialiseFailure m)
     (a, b)
forall a b. (a -> b) -> a -> b
$ (,) (a -> b -> (a, b))
-> Decoder (PrimState m) a -> Decoder (PrimState m) (b -> (a, b))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder (PrimState m) a
forall s. Decoder s a
decK Decoder (PrimState m) (b -> (a, b))
-> Decoder (PrimState m) b -> Decoder (PrimState m) (a, b)
forall a b.
Decoder (PrimState m) (a -> b)
-> Decoder (PrimState m) a -> Decoder (PrimState m) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Decoder (PrimState m) b
forall s. Decoder s b
decV
    lift $ S.yield kv

  go :: StateT
  (Stream (Of ByteString) m (Maybe CRC))
  (Stream (Of (a, b)) (ExceptT DeserialiseFailure m))
  ()
go = do
    doBreak <- (forall a.
 ExceptT DeserialiseFailure m a
 -> Stream (Of (a, b)) (ExceptT DeserialiseFailure m) a)
-> StateT
     (Stream (Of ByteString) m (Maybe CRC))
     (ExceptT DeserialiseFailure m)
     Bool
-> StateT
     (Stream (Of ByteString) m (Maybe CRC))
     (Stream (Of (a, b)) (ExceptT DeserialiseFailure m))
     Bool
forall {k} (t :: (* -> *) -> k -> *) (m :: * -> *) (n :: * -> *)
       (b :: k).
(MFunctor t, Monad m) =>
(forall a. m a -> n a) -> t m b -> t n b
forall (m :: * -> *) (n :: * -> *) b.
Monad m =>
(forall a. m a -> n a)
-> StateT (Stream (Of ByteString) m (Maybe CRC)) m b
-> StateT (Stream (Of ByteString) m (Maybe CRC)) n b
hoist ExceptT DeserialiseFailure m a
-> Stream (Of (a, b)) (ExceptT DeserialiseFailure m) a
forall a.
ExceptT DeserialiseFailure m a
-> Stream (Of (a, b)) (ExceptT DeserialiseFailure m) a
forall (m :: * -> *) a. Monad m => m a -> Stream (Of (a, b)) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT
   (Stream (Of ByteString) m (Maybe CRC))
   (ExceptT DeserialiseFailure m)
   Bool
 -> StateT
      (Stream (Of ByteString) m (Maybe CRC))
      (Stream (Of (a, b)) (ExceptT DeserialiseFailure m))
      Bool)
-> StateT
     (Stream (Of ByteString) m (Maybe CRC))
     (ExceptT DeserialiseFailure m)
     Bool
-> StateT
     (Stream (Of ByteString) m (Maybe CRC))
     (Stream (Of (a, b)) (ExceptT DeserialiseFailure m))
     Bool
forall a b. (a -> b) -> a -> b
$ Decoder (PrimState m) Bool
-> StateT
     (Stream (Of ByteString) m (Maybe CRC))
     (ExceptT DeserialiseFailure m)
     Bool
forall {t :: (* -> *) -> * -> *} {m :: * -> *} {a} {b}.
(MonadTrans t, MonadST m, MonadError DeserialiseFailure (t m)) =>
Decoder (PrimState m) a
-> StateT (Stream (Of ByteString) m b) (t m) a
decodeCbor Decoder (PrimState m) Bool
forall s. Decoder s Bool
decodeBreakOr
    unless doBreak $ yieldKV *> go

  decodeCbor :: Decoder (PrimState m) a
-> StateT (Stream (Of ByteString) m b) (t m) a
decodeCbor Decoder (PrimState m) a
dec =
    (Stream (Of ByteString) m b -> t m (a, Stream (Of ByteString) m b))
-> StateT (Stream (Of ByteString) m b) (t m) a
forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
StateT ((Stream (Of ByteString) m b
  -> t m (a, Stream (Of ByteString) m b))
 -> StateT (Stream (Of ByteString) m b) (t m) a)
-> (Stream (Of ByteString) m b
    -> t m (a, Stream (Of ByteString) m b))
-> StateT (Stream (Of ByteString) m b) (t m) a
forall a b. (a -> b) -> a -> b
$ \Stream (Of ByteString) m b
s -> Stream (Of ByteString) m b
-> IDecode (PrimState m) a -> t m (a, Stream (Of ByteString) m b)
forall {t :: (* -> *) -> * -> *} {m :: * -> *} {b} {a}.
(MonadTrans t, MonadST m, MonadError DeserialiseFailure (t m)) =>
Stream (Of ByteString) m b
-> IDecode (PrimState m) a -> t m (a, Stream (Of ByteString) m b)
go' Stream (Of ByteString) m b
s (IDecode (PrimState m) a -> t m (a, Stream (Of ByteString) m b))
-> t m (IDecode (PrimState m) a)
-> t m (a, Stream (Of ByteString) m b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< m (IDecode (PrimState m) a) -> t m (IDecode (PrimState m) a)
forall (m :: * -> *) a. Monad m => m a -> t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ST (PrimState m) (IDecode (PrimState m) a)
-> m (IDecode (PrimState m) a)
forall a. ST (PrimState m) a -> m a
forall (m :: * -> *) a. MonadST m => ST (PrimState m) a -> m a
stToIO (Decoder (PrimState m) a
-> ST (PrimState m) (IDecode (PrimState m) a)
forall s a. Decoder s a -> ST s (IDecode s a)
deserialiseIncremental Decoder (PrimState m) a
dec))
   where
    go' :: Stream (Of ByteString) m b
-> IDecode (PrimState m) a -> t m (a, Stream (Of ByteString) m b)
go' Stream (Of ByteString) m b
s = \case
      Partial Maybe ByteString -> ST (PrimState m) (IDecode (PrimState m) a)
k ->
        m (Either b (ByteString, Stream (Of ByteString) m b))
-> t m (Either b (ByteString, Stream (Of ByteString) m b))
forall (m :: * -> *) a. Monad m => m a -> t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Stream (Of ByteString) m b
-> m (Either b (ByteString, Stream (Of ByteString) m b))
forall (m :: * -> *) a r.
Monad m =>
Stream (Of a) m r -> m (Either r (a, Stream (Of a) m r))
S.next Stream (Of ByteString) m b
s) t m (Either b (ByteString, Stream (Of ByteString) m b))
-> (Either b (ByteString, Stream (Of ByteString) m b)
    -> t m (a, Stream (Of ByteString) m b))
-> t m (a, Stream (Of ByteString) m b)
forall a b. t m a -> (a -> t m b) -> t m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          Right (ByteString
bs, Stream (Of ByteString) m b
s') -> Stream (Of ByteString) m b
-> IDecode (PrimState m) a -> t m (a, Stream (Of ByteString) m b)
go' Stream (Of ByteString) m b
s' (IDecode (PrimState m) a -> t m (a, Stream (Of ByteString) m b))
-> t m (IDecode (PrimState m) a)
-> t m (a, Stream (Of ByteString) m b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< m (IDecode (PrimState m) a) -> t m (IDecode (PrimState m) a)
forall (m :: * -> *) a. Monad m => m a -> t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ST (PrimState m) (IDecode (PrimState m) a)
-> m (IDecode (PrimState m) a)
forall a. ST (PrimState m) a -> m a
forall (m :: * -> *) a. MonadST m => ST (PrimState m) a -> m a
stToIO (Maybe ByteString -> ST (PrimState m) (IDecode (PrimState m) a)
k (ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
bs)))
          Left b
r -> Stream (Of ByteString) m b
-> IDecode (PrimState m) a -> t m (a, Stream (Of ByteString) m b)
go' (b -> Stream (Of ByteString) m b
forall a. a -> Stream (Of ByteString) m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure b
r) (IDecode (PrimState m) a -> t m (a, Stream (Of ByteString) m b))
-> t m (IDecode (PrimState m) a)
-> t m (a, Stream (Of ByteString) m b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< m (IDecode (PrimState m) a) -> t m (IDecode (PrimState m) a)
forall (m :: * -> *) a. Monad m => m a -> t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ST (PrimState m) (IDecode (PrimState m) a)
-> m (IDecode (PrimState m) a)
forall a. ST (PrimState m) a -> m a
forall (m :: * -> *) a. MonadST m => ST (PrimState m) a -> m a
stToIO (Maybe ByteString -> ST (PrimState m) (IDecode (PrimState m) a)
k Maybe ByteString
forall a. Maybe a
Nothing))
      Codec.CBOR.Read.Done ByteString
bs ByteOffset
_off a
a -> (a, Stream (Of ByteString) m b)
-> t m (a, Stream (Of ByteString) m b)
forall a. a -> t m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
a, ByteString -> Stream (Of ByteString) m ()
forall (m :: * -> *) a. Monad m => a -> Stream (Of a) m ()
S.yield ByteString
bs Stream (Of ByteString) m ()
-> Stream (Of ByteString) m b -> Stream (Of ByteString) m b
forall a b.
Stream (Of ByteString) m a
-> Stream (Of ByteString) m b -> Stream (Of ByteString) m b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Stream (Of ByteString) m b
s)
      Codec.CBOR.Read.Fail ByteString
_bs ByteOffset
_off DeserialiseFailure
err -> DeserialiseFailure -> t m (a, Stream (Of ByteString) m b)
forall a. DeserialiseFailure -> t m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError DeserialiseFailure
err

yieldInMemoryS ::
  (MonadThrow m, MonadST m) =>
  SomeHasFS m ->
  DiskSnapshot ->
  (forall s. Decoder s (TxIn blk)) ->
  (forall s. Decoder s (TxOut blk)) ->
  Yield m l blk
yieldInMemoryS :: forall (m :: * -> *) blk (l :: StateKind).
(MonadThrow m, MonadST m) =>
SomeHasFS m
-> DiskSnapshot
-> (forall s. Decoder s (TxIn blk))
-> (forall s. Decoder s (TxOut blk))
-> Yield m l blk
yieldInMemoryS SomeHasFS m
fs DiskSnapshot
ds forall s. Decoder s (TxIn blk)
decK forall s. Decoder s (TxOut blk)
decV l blk EmptyMK
_ 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 =
  SomeHasFS m
-> FsPath
-> (Stream (Of ByteString) m (Maybe CRC)
    -> ExceptT
         DeserialiseFailure
         m
         (Stream (Of ByteString) m (Maybe CRC, Maybe CRC)))
-> ExceptT DeserialiseFailure m (Maybe CRC, Maybe CRC)
forall (m :: * -> *).
MonadThrow m =>
SomeHasFS m
-> FsPath
-> (Stream (Of ByteString) m (Maybe CRC)
    -> ExceptT
         DeserialiseFailure
         m
         (Stream (Of ByteString) m (Maybe CRC, Maybe CRC)))
-> ExceptT DeserialiseFailure m (Maybe CRC, Maybe CRC)
streamingFile SomeHasFS m
fs (DiskSnapshot -> FsPath
snapshotToTablesPath DiskSnapshot
ds) ((Stream (Of ByteString) m (Maybe CRC)
  -> ExceptT
       DeserialiseFailure
       m
       (Stream (Of ByteString) m (Maybe CRC, Maybe CRC)))
 -> ExceptT DeserialiseFailure m (Maybe CRC, Maybe CRC))
-> (Stream (Of ByteString) m (Maybe CRC)
    -> ExceptT
         DeserialiseFailure
         m
         (Stream (Of ByteString) m (Maybe CRC, Maybe CRC)))
-> ExceptT DeserialiseFailure m (Maybe CRC, Maybe CRC)
forall a b. (a -> b) -> a -> b
$ \Stream (Of ByteString) m (Maybe CRC)
s -> do
    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 (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)))
-> 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))
forall a b. (a -> b) -> a -> b
$ (forall s. Decoder s (TxIn blk))
-> (forall s. Decoder s (TxOut blk))
-> Stream (Of ByteString) m (Maybe CRC)
-> Stream
     (Of (TxIn blk, TxOut blk))
     (ExceptT DeserialiseFailure m)
     (Stream (Of ByteString) m (Maybe CRC))
forall (m :: * -> *) a b.
MonadST m =>
(forall s. Decoder s a)
-> (forall s. Decoder s b)
-> Stream (Of ByteString) m (Maybe CRC)
-> Stream
     (Of (a, b))
     (ExceptT DeserialiseFailure m)
     (Stream (Of ByteString) m (Maybe CRC))
yieldCborMapS Decoder s (TxIn blk)
forall s. Decoder s (TxIn blk)
decK Decoder s (TxOut blk)
forall s. Decoder s (TxOut blk)
decV Stream (Of ByteString) m (Maybe CRC)
s

sinkInMemoryS ::
  forall m l blk.
  MonadThrow m =>
  Int ->
  (TxIn blk -> Encoding) ->
  (TxOut blk -> Encoding) ->
  SomeHasFS m ->
  DiskSnapshot ->
  Sink m l blk
sinkInMemoryS :: forall (m :: * -> *) (l :: StateKind) blk.
MonadThrow m =>
Int
-> (TxIn blk -> Encoding)
-> (TxOut blk -> Encoding)
-> SomeHasFS m
-> DiskSnapshot
-> Sink m l blk
sinkInMemoryS Int
writeChunkSize TxIn blk -> Encoding
encK TxOut blk -> Encoding
encV (SomeHasFS HasFS m h
fs) DiskSnapshot
ds l blk EmptyMK
_ Stream
  (Of (TxIn blk, TxOut blk))
  (ExceptT DeserialiseFailure m)
  (Stream (Of ByteString) m (Maybe CRC))
s =
  m (Either
     DeserialiseFailure
     (Stream (Of ByteString) m (Maybe CRC, Maybe CRC)))
-> ExceptT
     DeserialiseFailure
     m
     (Stream (Of ByteString) m (Maybe CRC, Maybe CRC))
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (m (Either
      DeserialiseFailure
      (Stream (Of ByteString) m (Maybe CRC, Maybe CRC)))
 -> ExceptT
      DeserialiseFailure
      m
      (Stream (Of ByteString) m (Maybe CRC, Maybe CRC)))
-> m (Either
        DeserialiseFailure
        (Stream (Of ByteString) m (Maybe CRC, Maybe CRC)))
-> ExceptT
     DeserialiseFailure
     m
     (Stream (Of ByteString) m (Maybe CRC, Maybe CRC))
forall a b. (a -> b) -> a -> b
$ HasFS m h
-> FsPath
-> OpenMode
-> (Handle h
    -> m (Either
            DeserialiseFailure
            (Stream (Of ByteString) m (Maybe CRC, Maybe CRC))))
-> m (Either
        DeserialiseFailure
        (Stream (Of ByteString) m (Maybe CRC, Maybe CRC)))
forall (m :: * -> *) h a.
(HasCallStack, MonadThrow m) =>
HasFS m h -> FsPath -> OpenMode -> (Handle h -> m a) -> m a
withFile HasFS m h
fs (DiskSnapshot -> FsPath
snapshotToTablesPath DiskSnapshot
ds) (AllowExisting -> OpenMode
WriteMode AllowExisting
MustBeNew) ((Handle h
  -> m (Either
          DeserialiseFailure
          (Stream (Of ByteString) m (Maybe CRC, Maybe CRC))))
 -> m (Either
         DeserialiseFailure
         (Stream (Of ByteString) m (Maybe CRC, Maybe CRC))))
-> (Handle h
    -> m (Either
            DeserialiseFailure
            (Stream (Of ByteString) m (Maybe CRC, Maybe CRC))))
-> m (Either
        DeserialiseFailure
        (Stream (Of ByteString) m (Maybe CRC, Maybe CRC)))
forall a b. (a -> b) -> a -> b
$ \Handle h
hdl -> do
    let bs :: ByteString
bs = Encoding -> ByteString
toStrictByteString (Word -> Encoding
encodeListLen Word
1 Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Encoding
encodeMapLenIndef)
    let !crc0 :: CRC
crc0 = ByteString -> CRC -> CRC
forall a. CRC32 a => a -> CRC -> CRC
updateCRC ByteString
bs CRC
initCRC
    m Word64 -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m Word64 -> m ()) -> m Word64 -> m ()
forall a b. (a -> b) -> a -> b
$ HasFS m h -> HasCallStack => Handle h -> ByteString -> m Word64
forall (m :: * -> *) h.
HasFS m h -> HasCallStack => Handle h -> ByteString -> m Word64
hPutSome HasFS m h
fs Handle h
hdl ByteString
bs
    e <- ExceptT
  DeserialiseFailure m (Stream (Of ByteString) m (Maybe CRC), CRC)
-> m (Either
        DeserialiseFailure (Stream (Of ByteString) m (Maybe CRC), CRC))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT
   DeserialiseFailure m (Stream (Of ByteString) m (Maybe CRC), CRC)
 -> m (Either
         DeserialiseFailure (Stream (Of ByteString) m (Maybe CRC), CRC)))
-> ExceptT
     DeserialiseFailure m (Stream (Of ByteString) m (Maybe CRC), CRC)
-> m (Either
        DeserialiseFailure (Stream (Of ByteString) m (Maybe CRC), CRC))
forall a b. (a -> b) -> a -> b
$ Handle h
-> CRC
-> 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), CRC)
go Handle h
hdl CRC
crc0 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))
s
    case e of
      Left DeserialiseFailure
err -> Either
  DeserialiseFailure
  (Stream (Of ByteString) m (Maybe CRC, Maybe CRC))
-> m (Either
        DeserialiseFailure
        (Stream (Of ByteString) m (Maybe CRC, Maybe CRC)))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either
   DeserialiseFailure
   (Stream (Of ByteString) m (Maybe CRC, Maybe CRC))
 -> m (Either
         DeserialiseFailure
         (Stream (Of ByteString) m (Maybe CRC, Maybe CRC))))
-> Either
     DeserialiseFailure
     (Stream (Of ByteString) m (Maybe CRC, Maybe CRC))
-> m (Either
        DeserialiseFailure
        (Stream (Of ByteString) m (Maybe CRC, Maybe CRC)))
forall a b. (a -> b) -> a -> b
$ DeserialiseFailure
-> Either
     DeserialiseFailure
     (Stream (Of ByteString) m (Maybe CRC, Maybe CRC))
forall a b. a -> Either a b
Left DeserialiseFailure
err
      Right (Stream (Of ByteString) m (Maybe CRC)
r, CRC
crc1) -> do
        let bs1 :: ByteString
bs1 = Encoding -> ByteString
toStrictByteString Encoding
encodeBreak
        m Word64 -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m Word64 -> m ()) -> m Word64 -> m ()
forall a b. (a -> b) -> a -> b
$ HasFS m h -> HasCallStack => Handle h -> ByteString -> m Word64
forall (m :: * -> *) h.
HasFS m h -> HasCallStack => Handle h -> ByteString -> m Word64
hPutSome HasFS m h
fs Handle h
hdl ByteString
bs1
        let !crc2 :: CRC
crc2 = ByteString -> CRC -> CRC
forall a. CRC32 a => a -> CRC -> CRC
updateCRC ByteString
bs1 CRC
crc1
        Either
  DeserialiseFailure
  (Stream (Of ByteString) m (Maybe CRC, Maybe CRC))
-> m (Either
        DeserialiseFailure
        (Stream (Of ByteString) m (Maybe CRC, Maybe CRC)))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either
   DeserialiseFailure
   (Stream (Of ByteString) m (Maybe CRC, Maybe CRC))
 -> m (Either
         DeserialiseFailure
         (Stream (Of ByteString) m (Maybe CRC, Maybe CRC))))
-> Either
     DeserialiseFailure
     (Stream (Of ByteString) m (Maybe CRC, Maybe CRC))
-> m (Either
        DeserialiseFailure
        (Stream (Of ByteString) m (Maybe CRC, Maybe CRC)))
forall a b. (a -> b) -> a -> b
$ Stream (Of ByteString) m (Maybe CRC, Maybe CRC)
-> Either
     DeserialiseFailure
     (Stream (Of ByteString) m (Maybe CRC, Maybe CRC))
forall a b. b -> Either a b
Right ((Maybe CRC -> (Maybe CRC, Maybe CRC))
-> Stream (Of ByteString) m (Maybe CRC)
-> Stream (Of ByteString) m (Maybe CRC, Maybe CRC)
forall a b.
(a -> b)
-> Stream (Of ByteString) m a -> Stream (Of ByteString) m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (,CRC -> Maybe CRC
forall a. a -> Maybe a
Just CRC
crc2) Stream (Of ByteString) m (Maybe CRC)
r)
 where
  go :: Handle h
-> CRC
-> 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), CRC)
go Handle h
tb !CRC
crc Int
0 [(TxIn blk, TxOut blk)]
m Stream
  (Of (TxIn blk, TxOut blk))
  (ExceptT DeserialiseFailure m)
  (Stream (Of ByteString) m (Maybe CRC))
s' = do
    let bs :: ByteString
bs = Encoding -> ByteString
toStrictByteString (Encoding -> ByteString) -> Encoding -> ByteString
forall a b. (a -> b) -> a -> b
$ [Encoding] -> Encoding
forall a. Monoid a => [a] -> a
mconcat [TxIn blk -> Encoding
encK TxIn blk
k Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> TxOut blk -> Encoding
encV TxOut blk
v | (TxIn blk
k, TxOut blk
v) <- [(TxIn blk, TxOut blk)] -> [(TxIn blk, TxOut blk)]
forall a. [a] -> [a]
reverse [(TxIn blk, TxOut blk)]
m]
    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
$ m Word64 -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m Word64 -> m ()) -> m Word64 -> m ()
forall a b. (a -> b) -> a -> b
$ HasFS m h -> HasCallStack => Handle h -> ByteString -> m Word64
forall (m :: * -> *) h.
HasFS m h -> HasCallStack => Handle h -> ByteString -> m Word64
hPutSome HasFS m h
fs Handle h
tb ByteString
bs
    let !crc1 :: CRC
crc1 = ByteString -> CRC -> CRC
forall a. CRC32 a => a -> CRC -> CRC
updateCRC ByteString
bs CRC
crc
    Handle h
-> CRC
-> 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), CRC)
go Handle h
tb CRC
crc1 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))
s'
  go Handle h
tb !CRC
crc Int
n [(TxIn blk, TxOut blk)]
m Stream
  (Of (TxIn blk, TxOut blk))
  (ExceptT DeserialiseFailure m)
  (Stream (Of ByteString) m (Maybe CRC))
s' = do
    mbs <- 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))
s'
    case mbs of
      Left Stream (Of ByteString) m (Maybe CRC)
r -> do
        let bs :: ByteString
bs = Encoding -> ByteString
toStrictByteString (Encoding -> ByteString) -> Encoding -> ByteString
forall a b. (a -> b) -> a -> b
$ [Encoding] -> Encoding
forall a. Monoid a => [a] -> a
mconcat [TxIn blk -> Encoding
encK TxIn blk
k Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> TxOut blk -> Encoding
encV TxOut blk
v | (TxIn blk
k, TxOut blk
v) <- [(TxIn blk, TxOut blk)] -> [(TxIn blk, TxOut blk)]
forall a. [a] -> [a]
reverse [(TxIn blk, TxOut blk)]
m]
        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
$ m Word64 -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m Word64 -> m ()) -> m Word64 -> m ()
forall a b. (a -> b) -> a -> b
$ HasFS m h -> HasCallStack => Handle h -> ByteString -> m Word64
forall (m :: * -> *) h.
HasFS m h -> HasCallStack => Handle h -> ByteString -> m Word64
hPutSome HasFS m h
fs Handle h
tb ByteString
bs
        let !crc1 :: CRC
crc1 = ByteString -> CRC -> CRC
forall a. CRC32 a => a -> CRC -> CRC
updateCRC ByteString
bs CRC
crc
        (Stream (Of ByteString) m (Maybe CRC), CRC)
-> ExceptT
     DeserialiseFailure m (Stream (Of ByteString) m (Maybe CRC), CRC)
forall a. a -> ExceptT DeserialiseFailure m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Stream (Of ByteString) m (Maybe CRC)
r, CRC
crc1)
      Right ((TxIn blk, TxOut blk)
item, Stream
  (Of (TxIn blk, TxOut blk))
  (ExceptT DeserialiseFailure m)
  (Stream (Of ByteString) m (Maybe CRC))
s'') -> Handle h
-> CRC
-> 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), CRC)
go Handle h
tb CRC
crc (Int
n 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)]
m) Stream
  (Of (TxIn blk, TxOut blk))
  (ExceptT DeserialiseFailure m)
  (Stream (Of ByteString) m (Maybe CRC))
s''