{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE UndecidableInstances #-}

-- | An implementation of a 'BackingStore' using a TVar. This is the
-- implementation known as \"InMemory\".
module Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore.Impl.InMemory
  ( -- * Constructor
    newInMemoryBackingStore

    -- * Errors
  , InMemoryBackingStoreExn (..)
  , InMemoryBackingStoreInitExn (..)
  ) where

import Cardano.Binary as CBOR
import Cardano.Slotting.Slot (SlotNo, WithOrigin (..))
import qualified Codec.CBOR.Read as CBOR
import qualified Codec.CBOR.Write as CBOR
import Control.Monad (join, unless, void, when)
import Control.Monad.Class.MonadThrow (catch)
import Control.Tracer (Tracer, traceWith)
import qualified Data.ByteString.Lazy as BSL
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import Data.String (fromString)
import GHC.Generics
import Ouroboros.Consensus.Ledger.Basics
import qualified Ouroboros.Consensus.Ledger.Tables.Diff as Diff
import Ouroboros.Consensus.Storage.LedgerDB.API
import Ouroboros.Consensus.Storage.LedgerDB.Snapshots
  ( SnapshotBackend (..)
  )
import Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore.API
import Ouroboros.Consensus.Util.IOLike
  ( Exception
  , IOLike
  , MonadSTM (STM, atomically)
  , MonadThrow (throwIO)
  , NoThunks
  , StrictTVar
  , newTVarIO
  , readTVar
  , throwSTM
  , writeTVar
  )
import System.FS.API
  ( HasFS (createDirectory, doesDirectoryExist, doesFileExist, mkFsErrorPath)
  , SomeHasFS (SomeHasFS)
  , withFile
  )
import System.FS.API.Lazy (hGetAll, hPutAll)
import System.FS.API.Types
  ( AllowExisting (MustBeNew)
  , FsErrorPath
  , FsPath (fsPathToList)
  , OpenMode (ReadMode, WriteMode)
  , fsPathFromList
  )
import Prelude hiding (lookup)

{-------------------------------------------------------------------------------
  An in-memory backing store
-------------------------------------------------------------------------------}

data BackingStoreContents m l
  = BackingStoreContentsClosed
  | BackingStoreContents
      !(WithOrigin SlotNo)
      !(LedgerTables l ValuesMK)
  deriving (forall x.
 BackingStoreContents m l -> Rep (BackingStoreContents m l) x)
-> (forall x.
    Rep (BackingStoreContents m l) x -> BackingStoreContents m l)
-> Generic (BackingStoreContents m l)
forall x.
Rep (BackingStoreContents m l) x -> BackingStoreContents m l
forall x.
BackingStoreContents m l -> Rep (BackingStoreContents m l) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall m (l :: LedgerStateKind) x.
Rep (BackingStoreContents m l) x -> BackingStoreContents m l
forall m (l :: LedgerStateKind) x.
BackingStoreContents m l -> Rep (BackingStoreContents m l) x
$cfrom :: forall m (l :: LedgerStateKind) x.
BackingStoreContents m l -> Rep (BackingStoreContents m l) x
from :: forall x.
BackingStoreContents m l -> Rep (BackingStoreContents m l) x
$cto :: forall m (l :: LedgerStateKind) x.
Rep (BackingStoreContents m l) x -> BackingStoreContents m l
to :: forall x.
Rep (BackingStoreContents m l) x -> BackingStoreContents m l
Generic

deriving instance
  ( NoThunks (TxIn l)
  , NoThunks (TxOut l)
  ) =>
  NoThunks (BackingStoreContents m l)

-- | Use a 'TVar' as a trivial backing store
newInMemoryBackingStore ::
  forall l m.
  ( IOLike m
  , HasLedgerTables l
  , CanUpgradeLedgerTables l
  , SerializeTablesWithHint l
  ) =>
  Tracer m BackingStoreTrace ->
  SnapshotsFS m ->
  InitFrom (LedgerTables l ValuesMK) ->
  m (LedgerBackingStore m l)
newInMemoryBackingStore :: forall (l :: LedgerStateKind) (m :: * -> *).
(IOLike m, HasLedgerTables l, CanUpgradeLedgerTables l,
 SerializeTablesWithHint l) =>
Tracer m BackingStoreTrace
-> SnapshotsFS m
-> InitFrom (LedgerTables l ValuesMK)
-> m (LedgerBackingStore m l)
newInMemoryBackingStore Tracer m BackingStoreTrace
tracer (SnapshotsFS (SomeHasFS HasFS m h
fs)) InitFrom (LedgerTables l ValuesMK)
initialization = do
  Tracer m BackingStoreTrace -> BackingStoreTrace -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m BackingStoreTrace
tracer BackingStoreTrace
BSOpening
  ref <- do
    (slot, values) <- case InitFrom (LedgerTables l ValuesMK)
initialization of
      InitFromCopy InitHint (LedgerTables l ValuesMK)
hint FsPath
path -> do
        Tracer m BackingStoreTrace -> BackingStoreTrace -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m BackingStoreTrace
tracer (BackingStoreTrace -> m ()) -> BackingStoreTrace -> m ()
forall a b. (a -> b) -> a -> b
$ FsPath -> BackingStoreTrace
BSInitialisingFromCopy FsPath
path
        tvarFileExists <- HasFS m h -> HasCallStack => FsPath -> m Bool
forall (m :: * -> *) h.
HasFS m h -> HasCallStack => FsPath -> m Bool
doesFileExist HasFS m h
fs (FsPath -> FsPath
extendPath FsPath
path)
        unless tvarFileExists $
          throwIO . StoreDirIsIncompatible $
            mkFsErrorPath fs path
        withFile fs (extendPath path) ReadMode $ \Handle h
h -> do
          bs <- HasFS m h -> Handle h -> m ByteString
forall (m :: * -> *) h.
Monad m =>
HasFS m h -> Handle h -> m ByteString
hGetAll HasFS m h
fs Handle h
h
          case CBOR.deserialiseFromBytes ((,) <$> CBOR.fromCBOR <*> valuesMKDecoder hint) bs of
            Left DeserialiseFailure
err -> InMemoryBackingStoreExn
-> m (WithOrigin SlotNo, LedgerTables l ValuesMK)
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (InMemoryBackingStoreExn
 -> m (WithOrigin SlotNo, LedgerTables l ValuesMK))
-> InMemoryBackingStoreExn
-> m (WithOrigin SlotNo, LedgerTables l ValuesMK)
forall a b. (a -> b) -> a -> b
$ DeserialiseFailure -> InMemoryBackingStoreExn
InMemoryBackingStoreDeserialiseExn DeserialiseFailure
err
            Right (ByteString
extra, (WithOrigin SlotNo, LedgerTables l ValuesMK)
x) -> do
              Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString -> Bool
BSL.null ByteString
extra) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ InMemoryBackingStoreExn -> m ()
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO InMemoryBackingStoreExn
InMemoryIncompleteDeserialiseExn
              Tracer m BackingStoreTrace -> BackingStoreTrace -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m BackingStoreTrace
tracer (BackingStoreTrace -> m ()) -> BackingStoreTrace -> m ()
forall a b. (a -> b) -> a -> b
$ FsPath -> BackingStoreTrace
BSInitialisedFromCopy FsPath
path
              (WithOrigin SlotNo, LedgerTables l ValuesMK)
-> m (WithOrigin SlotNo, LedgerTables l ValuesMK)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (WithOrigin SlotNo, LedgerTables l ValuesMK)
x
      InitFromValues WithOrigin SlotNo
slot InitHint (LedgerTables l ValuesMK)
_ LedgerTables l ValuesMK
values -> do
        Tracer m BackingStoreTrace -> BackingStoreTrace -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m BackingStoreTrace
tracer (BackingStoreTrace -> m ()) -> BackingStoreTrace -> m ()
forall a b. (a -> b) -> a -> b
$ WithOrigin SlotNo -> BackingStoreTrace
BSInitialisingFromValues WithOrigin SlotNo
slot
        (WithOrigin SlotNo, LedgerTables l ValuesMK)
-> m (WithOrigin SlotNo, LedgerTables l ValuesMK)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (WithOrigin SlotNo
slot, LedgerTables l ValuesMK
values)
    newTVarIO $ BackingStoreContents slot values
  traceWith tracer $ BSOpened Nothing
  pure
    BackingStore
      { bsClose = do
          traceWith tracer BSClosing
          catch
            ( atomically $ do
                guardClosed ref
                writeTVar ref BackingStoreContentsClosed
            )
            ( \case
                InMemoryBackingStoreExn
InMemoryBackingStoreClosedExn -> Tracer m BackingStoreTrace -> BackingStoreTrace -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m BackingStoreTrace
tracer BackingStoreTrace
BSAlreadyClosed
                InMemoryBackingStoreExn
e -> InMemoryBackingStoreExn -> m ()
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO InMemoryBackingStoreExn
e
            )
          traceWith tracer BSClosed
      , bsCopy = \SerializeTablesHint (LedgerTables l ValuesMK)
hint FsPath
path -> do
          Tracer m BackingStoreTrace -> BackingStoreTrace -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m BackingStoreTrace
tracer (BackingStoreTrace -> m ()) -> BackingStoreTrace -> m ()
forall a b. (a -> b) -> a -> b
$ FsPath -> BackingStoreTrace
BSCopying FsPath
path
          m (m ()) -> m ()
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (m (m ()) -> m ()) -> m (m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ STM m (m ()) -> m (m ())
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (m ()) -> m (m ())) -> STM m (m ()) -> m (m ())
forall a b. (a -> b) -> a -> b
$ do
            StrictTVar m (BackingStoreContents Any l)
-> STM m (BackingStoreContents Any l)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (BackingStoreContents Any l)
ref STM m (BackingStoreContents Any l)
-> (BackingStoreContents Any l -> STM m (m ())) -> STM m (m ())
forall a b. STM m a -> (a -> STM m b) -> STM m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
              BackingStoreContents Any l
BackingStoreContentsClosed ->
                InMemoryBackingStoreExn -> STM m (m ())
forall (m :: * -> *) e a.
(MonadSTM m, MonadThrow (STM m), Exception e) =>
e -> STM m a
throwSTM InMemoryBackingStoreExn
InMemoryBackingStoreClosedExn
              BackingStoreContents WithOrigin SlotNo
slot LedgerTables l ValuesMK
values -> m () -> STM m (m ())
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (m () -> STM m (m ())) -> m () -> STM m (m ())
forall a b. (a -> b) -> a -> b
$ do
                exists <- HasFS m h -> HasCallStack => FsPath -> m Bool
forall (m :: * -> *) h.
HasFS m h -> HasCallStack => FsPath -> m Bool
doesDirectoryExist HasFS m h
fs FsPath
path
                when exists $ throwIO InMemoryBackingStoreDirectoryExists
                createDirectory fs path
                withFile fs (extendPath path) (WriteMode MustBeNew) $ \Handle h
h ->
                  m Word64 -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m Word64 -> m ()) -> m Word64 -> m ()
forall a b. (a -> b) -> a -> b
$
                    HasFS m h -> Handle h -> ByteString -> m Word64
forall (m :: * -> *) h.
(HasCallStack, Monad m) =>
HasFS m h -> Handle h -> ByteString -> m Word64
hPutAll HasFS m h
fs Handle h
h (ByteString -> m Word64) -> ByteString -> m Word64
forall a b. (a -> b) -> a -> b
$
                      Encoding -> ByteString
CBOR.toLazyByteString (Encoding -> ByteString) -> Encoding -> ByteString
forall a b. (a -> b) -> a -> b
$
                        WithOrigin SlotNo -> Encoding
forall a. ToCBOR a => a -> Encoding
CBOR.toCBOR WithOrigin SlotNo
slot Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> l EmptyMK -> LedgerTables l ValuesMK -> Encoding
forall (l :: LedgerStateKind).
SerializeTablesWithHint l =>
l EmptyMK -> LedgerTables l ValuesMK -> Encoding
valuesMKEncoder l EmptyMK
SerializeTablesHint (LedgerTables l ValuesMK)
hint LedgerTables l ValuesMK
values
          Tracer m BackingStoreTrace -> BackingStoreTrace -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m BackingStoreTrace
tracer (BackingStoreTrace -> m ()) -> BackingStoreTrace -> m ()
forall a b. (a -> b) -> a -> b
$ FsPath -> BackingStoreTrace
BSCopied FsPath
path
      , bsValueHandle = do
          traceWith tracer BSCreatingValueHandle
          vh <- join $ atomically $ do
            readTVar ref >>= \case
              BackingStoreContents Any l
BackingStoreContentsClosed ->
                InMemoryBackingStoreExn
-> STM
     m
     (m (BackingStoreValueHandle
           m (LedgerTables l KeysMK) (LedgerTables l ValuesMK)))
forall (m :: * -> *) e a.
(MonadSTM m, MonadThrow (STM m), Exception e) =>
e -> STM m a
throwSTM InMemoryBackingStoreExn
InMemoryBackingStoreClosedExn
              BackingStoreContents WithOrigin SlotNo
slot LedgerTables l ValuesMK
values -> m (BackingStoreValueHandle
     m (LedgerTables l KeysMK) (LedgerTables l ValuesMK))
-> STM
     m
     (m (BackingStoreValueHandle
           m (LedgerTables l KeysMK) (LedgerTables l ValuesMK)))
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (m (BackingStoreValueHandle
      m (LedgerTables l KeysMK) (LedgerTables l ValuesMK))
 -> STM
      m
      (m (BackingStoreValueHandle
            m (LedgerTables l KeysMK) (LedgerTables l ValuesMK))))
-> m (BackingStoreValueHandle
        m (LedgerTables l KeysMK) (LedgerTables l ValuesMK))
-> STM
     m
     (m (BackingStoreValueHandle
           m (LedgerTables l KeysMK) (LedgerTables l ValuesMK)))
forall a b. (a -> b) -> a -> b
$ do
                refHandleClosed <- Bool -> m (StrictTVar m Bool)
forall (m :: * -> *) a.
(HasCallStack, MonadSTM m, NoThunks a) =>
a -> m (StrictTVar m a)
newTVarIO Bool
False
                pure $
                  BackingStoreValueHandle
                    { bsvhAtSlot = slot
                    , bsvhClose = do
                        traceWith tracer $ BSValueHandleTrace Nothing BSVHClosing
                        catch
                          ( atomically $ do
                              guardClosed ref
                              guardHandleClosed refHandleClosed
                              writeTVar refHandleClosed True
                          )
                          ( \case
                              InMemoryBackingStoreExn
InMemoryBackingStoreClosedExn ->
                                Tracer m BackingStoreTrace -> BackingStoreTrace -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m BackingStoreTrace
tracer BackingStoreTrace
BSAlreadyClosed
                              InMemoryBackingStoreExn
InMemoryBackingStoreValueHandleClosedExn ->
                                Tracer m BackingStoreTrace -> BackingStoreTrace -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m BackingStoreTrace
tracer (Maybe Int -> BackingStoreValueHandleTrace -> BackingStoreTrace
BSValueHandleTrace Maybe Int
forall a. Maybe a
Nothing BackingStoreValueHandleTrace
BSVHAlreadyClosed)
                              InMemoryBackingStoreExn
e ->
                                InMemoryBackingStoreExn -> m ()
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO InMemoryBackingStoreExn
e
                          )
                        traceWith tracer $ BSValueHandleTrace Nothing BSVHClosed
                    , bsvhRangeRead = \ReadHint (LedgerTables l ValuesMK)
_ RangeQuery (LedgerTables l KeysMK)
rq -> do
                        Tracer m BackingStoreTrace -> BackingStoreTrace -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m BackingStoreTrace
tracer (BackingStoreTrace -> m ()) -> BackingStoreTrace -> m ()
forall a b. (a -> b) -> a -> b
$ Maybe Int -> BackingStoreValueHandleTrace -> BackingStoreTrace
BSValueHandleTrace Maybe Int
forall a. Maybe a
Nothing BackingStoreValueHandleTrace
BSVHRangeReading
                        r <- STM m (LedgerTables l ValuesMK) -> m (LedgerTables l ValuesMK)
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (LedgerTables l ValuesMK) -> m (LedgerTables l ValuesMK))
-> STM m (LedgerTables l ValuesMK) -> m (LedgerTables l ValuesMK)
forall a b. (a -> b) -> a -> b
$ do
                          StrictTVar m (BackingStoreContents Any l) -> STM m ()
forall (m :: * -> *) ks (vs :: LedgerStateKind).
IOLike m =>
StrictTVar m (BackingStoreContents ks vs) -> STM m ()
guardClosed StrictTVar m (BackingStoreContents Any l)
ref
                          StrictTVar m Bool -> STM m ()
forall (m :: * -> *). IOLike m => StrictTVar m Bool -> STM m ()
guardHandleClosed StrictTVar m Bool
refHandleClosed
                          LedgerTables l ValuesMK -> STM m (LedgerTables l ValuesMK)
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LedgerTables l ValuesMK -> STM m (LedgerTables l ValuesMK))
-> LedgerTables l ValuesMK -> STM m (LedgerTables l ValuesMK)
forall a b. (a -> b) -> a -> b
$ RangeQuery (LedgerTables l KeysMK)
-> LedgerTables l ValuesMK -> LedgerTables l ValuesMK
rangeRead RangeQuery (LedgerTables l KeysMK)
rq LedgerTables l ValuesMK
values
                        traceWith tracer $ BSValueHandleTrace Nothing BSVHRangeRead
                        pure r
                    , bsvhReadAll = \ReadHint (LedgerTables l ValuesMK)
_ ->
                        STM m (LedgerTables l ValuesMK) -> m (LedgerTables l ValuesMK)
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (LedgerTables l ValuesMK) -> m (LedgerTables l ValuesMK))
-> STM m (LedgerTables l ValuesMK) -> m (LedgerTables l ValuesMK)
forall a b. (a -> b) -> a -> b
$ do
                          StrictTVar m (BackingStoreContents Any l) -> STM m ()
forall (m :: * -> *) ks (vs :: LedgerStateKind).
IOLike m =>
StrictTVar m (BackingStoreContents ks vs) -> STM m ()
guardClosed StrictTVar m (BackingStoreContents Any l)
ref
                          StrictTVar m Bool -> STM m ()
forall (m :: * -> *). IOLike m => StrictTVar m Bool -> STM m ()
guardHandleClosed StrictTVar m Bool
refHandleClosed
                          LedgerTables l ValuesMK -> STM m (LedgerTables l ValuesMK)
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure LedgerTables l ValuesMK
values
                    , bsvhRead = \ReadHint (LedgerTables l ValuesMK)
_ LedgerTables l KeysMK
keys -> do
                        Tracer m BackingStoreTrace -> BackingStoreTrace -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m BackingStoreTrace
tracer (BackingStoreTrace -> m ()) -> BackingStoreTrace -> m ()
forall a b. (a -> b) -> a -> b
$ Maybe Int -> BackingStoreValueHandleTrace -> BackingStoreTrace
BSValueHandleTrace Maybe Int
forall a. Maybe a
Nothing BackingStoreValueHandleTrace
BSVHReading
                        r <- STM m (LedgerTables l ValuesMK) -> m (LedgerTables l ValuesMK)
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (LedgerTables l ValuesMK) -> m (LedgerTables l ValuesMK))
-> STM m (LedgerTables l ValuesMK) -> m (LedgerTables l ValuesMK)
forall a b. (a -> b) -> a -> b
$ do
                          StrictTVar m (BackingStoreContents Any l) -> STM m ()
forall (m :: * -> *) ks (vs :: LedgerStateKind).
IOLike m =>
StrictTVar m (BackingStoreContents ks vs) -> STM m ()
guardClosed StrictTVar m (BackingStoreContents Any l)
ref
                          StrictTVar m Bool -> STM m ()
forall (m :: * -> *). IOLike m => StrictTVar m Bool -> STM m ()
guardHandleClosed StrictTVar m Bool
refHandleClosed
                          LedgerTables l ValuesMK -> STM m (LedgerTables l ValuesMK)
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LedgerTables l ValuesMK -> STM m (LedgerTables l ValuesMK))
-> LedgerTables l ValuesMK -> STM m (LedgerTables l ValuesMK)
forall a b. (a -> b) -> a -> b
$ LedgerTables l KeysMK
-> LedgerTables l ValuesMK -> LedgerTables l ValuesMK
lookup LedgerTables l KeysMK
keys LedgerTables l ValuesMK
values
                        traceWith tracer $ BSValueHandleTrace Nothing BSVHRead
                        pure r
                    , bsvhStat = do
                        traceWith tracer $ BSValueHandleTrace Nothing BSVHStatting
                        r <- atomically $ do
                          guardClosed ref
                          guardHandleClosed refHandleClosed
                          pure $ Statistics slot (count values)
                        traceWith tracer $ BSValueHandleTrace Nothing BSVHStatted
                        pure r
                    }
          traceWith tracer BSCreatedValueHandle
          pure vh
      , bsWrite = \SlotNo
slot2 (l EmptyMK
st, l EmptyMK
st') LedgerTables l DiffMK
diff -> do
          Tracer m BackingStoreTrace -> BackingStoreTrace -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m BackingStoreTrace
tracer (BackingStoreTrace -> m ()) -> BackingStoreTrace -> m ()
forall a b. (a -> b) -> a -> b
$ SlotNo -> BackingStoreTrace
BSWriting SlotNo
slot2
          slot1 <- STM m (WithOrigin SlotNo) -> m (WithOrigin SlotNo)
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (WithOrigin SlotNo) -> m (WithOrigin SlotNo))
-> STM m (WithOrigin SlotNo) -> m (WithOrigin SlotNo)
forall a b. (a -> b) -> a -> b
$ do
            StrictTVar m (BackingStoreContents Any l)
-> STM m (BackingStoreContents Any l)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (BackingStoreContents Any l)
ref STM m (BackingStoreContents Any l)
-> (BackingStoreContents Any l -> STM m (WithOrigin SlotNo))
-> STM m (WithOrigin SlotNo)
forall a b. STM m a -> (a -> STM m b) -> STM m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
              BackingStoreContents Any l
BackingStoreContentsClosed ->
                InMemoryBackingStoreExn -> STM m (WithOrigin SlotNo)
forall (m :: * -> *) e a.
(MonadSTM m, MonadThrow (STM m), Exception e) =>
e -> STM m a
throwSTM InMemoryBackingStoreExn
InMemoryBackingStoreClosedExn
              BackingStoreContents WithOrigin SlotNo
slot1 LedgerTables l ValuesMK
values -> do
                Bool -> STM m () -> STM m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (WithOrigin SlotNo
slot1 WithOrigin SlotNo -> WithOrigin SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
<= SlotNo -> WithOrigin SlotNo
forall t. t -> WithOrigin t
At SlotNo
slot2) (STM m () -> STM m ()) -> STM m () -> STM m ()
forall a b. (a -> b) -> a -> b
$
                  InMemoryBackingStoreExn -> STM m ()
forall (m :: * -> *) e a.
(MonadSTM m, MonadThrow (STM m), Exception e) =>
e -> STM m a
throwSTM (InMemoryBackingStoreExn -> STM m ())
-> InMemoryBackingStoreExn -> STM m ()
forall a b. (a -> b) -> a -> b
$
                    WithOrigin SlotNo -> WithOrigin SlotNo -> InMemoryBackingStoreExn
InMemoryBackingStoreNonMonotonicSeq (SlotNo -> WithOrigin SlotNo
forall t. t -> WithOrigin t
At SlotNo
slot2) WithOrigin SlotNo
slot1
                StrictTVar m (BackingStoreContents Any l)
-> BackingStoreContents Any l -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m (BackingStoreContents Any l)
ref (BackingStoreContents Any l -> STM m ())
-> BackingStoreContents Any l -> STM m ()
forall a b. (a -> b) -> a -> b
$
                  WithOrigin SlotNo
-> LedgerTables l ValuesMK -> BackingStoreContents Any l
forall m (l :: LedgerStateKind).
WithOrigin SlotNo
-> LedgerTables l ValuesMK -> BackingStoreContents m l
BackingStoreContents
                    (SlotNo -> WithOrigin SlotNo
forall t. t -> WithOrigin t
At SlotNo
slot2)
                    (l EmptyMK
-> l EmptyMK -> LedgerTables l ValuesMK -> LedgerTables l ValuesMK
forall (mk1 :: * -> * -> *) (mk2 :: * -> * -> *).
l mk1
-> l mk2 -> LedgerTables l ValuesMK -> LedgerTables l ValuesMK
forall (l :: LedgerStateKind) (mk1 :: * -> * -> *)
       (mk2 :: * -> * -> *).
CanUpgradeLedgerTables l =>
l mk1
-> l mk2 -> LedgerTables l ValuesMK -> LedgerTables l ValuesMK
upgradeTables l EmptyMK
st l EmptyMK
st' (LedgerTables l ValuesMK
-> LedgerTables l DiffMK -> LedgerTables l ValuesMK
appDiffs LedgerTables l ValuesMK
values LedgerTables l DiffMK
diff))
                WithOrigin SlotNo -> STM m (WithOrigin SlotNo)
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure WithOrigin SlotNo
slot1
          traceWith tracer $ BSWritten slot1 slot2
      , bsSnapshotBackend = UTxOHDMemSnapshot
      }
 where
  extendPath :: FsPath -> FsPath
extendPath FsPath
path =
    [Text] -> FsPath
fsPathFromList ([Text] -> FsPath) -> [Text] -> FsPath
forall a b. (a -> b) -> a -> b
$ FsPath -> [Text]
fsPathToList FsPath
path [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [String -> Text
forall a. IsString a => String -> a
fromString String
"tvar"]

  lookup ::
    LedgerTables l KeysMK ->
    LedgerTables l ValuesMK ->
    LedgerTables l ValuesMK
  lookup :: LedgerTables l KeysMK
-> LedgerTables l ValuesMK -> LedgerTables l ValuesMK
lookup = (forall k v.
 LedgerTableConstraints' l k v =>
 KeysMK k v -> ValuesMK k v -> ValuesMK k v)
-> LedgerTables l KeysMK
-> LedgerTables l ValuesMK
-> LedgerTables l ValuesMK
forall (l :: LedgerStateKind) (mk1 :: * -> * -> *)
       (mk2 :: * -> * -> *) (mk3 :: * -> * -> *).
LedgerTableConstraints l =>
(forall k v.
 LedgerTableConstraints' l k v =>
 mk1 k v -> mk2 k v -> mk3 k v)
-> LedgerTables l mk1 -> LedgerTables l mk2 -> LedgerTables l mk3
ltliftA2 KeysMK k v -> ValuesMK k v -> ValuesMK k v
forall k v. Ord k => KeysMK k v -> ValuesMK k v -> ValuesMK k v
forall k v.
LedgerTableConstraints' l k v =>
KeysMK k v -> ValuesMK k v -> ValuesMK k v
lookup'

  lookup' ::
    Ord k =>
    KeysMK k v ->
    ValuesMK k v ->
    ValuesMK k v
  lookup' :: forall k v. Ord k => KeysMK k v -> ValuesMK k v -> ValuesMK k v
lookup' (KeysMK Set k
ks) (ValuesMK Map k v
vs) =
    Map k v -> ValuesMK k v
forall k v. Map k v -> ValuesMK k v
ValuesMK (Map k v -> Set k -> Map k v
forall k a. Ord k => Map k a -> Set k -> Map k a
Map.restrictKeys Map k v
vs Set k
ks)

  rangeRead ::
    RangeQuery (LedgerTables l KeysMK) ->
    LedgerTables l ValuesMK ->
    LedgerTables l ValuesMK
  rangeRead :: RangeQuery (LedgerTables l KeysMK)
-> LedgerTables l ValuesMK -> LedgerTables l ValuesMK
rangeRead RangeQuery (LedgerTables l KeysMK)
rq LedgerTables l ValuesMK
values = case RangeQuery (LedgerTables l KeysMK) -> Maybe (LedgerTables l KeysMK)
forall keys. RangeQuery keys -> Maybe keys
rqPrev RangeQuery (LedgerTables l KeysMK)
rq of
    Maybe (LedgerTables l KeysMK)
Nothing ->
      (forall k v.
 LedgerTableConstraints' l k v =>
 ValuesMK k v -> ValuesMK k v)
-> LedgerTables l ValuesMK -> LedgerTables l ValuesMK
forall (l :: LedgerStateKind) (mk1 :: * -> * -> *)
       (mk2 :: * -> * -> *).
LedgerTableConstraints l =>
(forall k v. LedgerTableConstraints' l k v => mk1 k v -> mk2 k v)
-> LedgerTables l mk1 -> LedgerTables l mk2
ltmap (Int -> ValuesMK k v -> ValuesMK k v
forall k v. Int -> ValuesMK k v -> ValuesMK k v
rangeRead0' (RangeQuery (LedgerTables l KeysMK) -> Int
forall keys. RangeQuery keys -> Int
rqCount RangeQuery (LedgerTables l KeysMK)
rq)) LedgerTables l ValuesMK
values
    Just LedgerTables l KeysMK
keys ->
      (forall k v.
 LedgerTableConstraints' l k v =>
 KeysMK k v -> ValuesMK k v -> ValuesMK k v)
-> LedgerTables l KeysMK
-> LedgerTables l ValuesMK
-> LedgerTables l ValuesMK
forall (l :: LedgerStateKind) (mk1 :: * -> * -> *)
       (mk2 :: * -> * -> *) (mk3 :: * -> * -> *).
LedgerTableConstraints l =>
(forall k v.
 LedgerTableConstraints' l k v =>
 mk1 k v -> mk2 k v -> mk3 k v)
-> LedgerTables l mk1 -> LedgerTables l mk2 -> LedgerTables l mk3
ltliftA2 (Int -> KeysMK k v -> ValuesMK k v -> ValuesMK k v
forall k v.
Ord k =>
Int -> KeysMK k v -> ValuesMK k v -> ValuesMK k v
rangeRead' (RangeQuery (LedgerTables l KeysMK) -> Int
forall keys. RangeQuery keys -> Int
rqCount RangeQuery (LedgerTables l KeysMK)
rq)) LedgerTables l KeysMK
keys LedgerTables l ValuesMK
values

  rangeRead0' ::
    Int ->
    ValuesMK k v ->
    ValuesMK k v
  rangeRead0' :: forall k v. Int -> ValuesMK k v -> ValuesMK k v
rangeRead0' Int
n (ValuesMK Map k v
vs) =
    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
$ Int -> Map k v -> Map k v
forall k a. Int -> Map k a -> Map k a
Map.take Int
n Map k v
vs

  rangeRead' ::
    Ord k =>
    Int ->
    KeysMK k v ->
    ValuesMK k v ->
    ValuesMK k v
  rangeRead' :: forall k v.
Ord k =>
Int -> KeysMK k v -> ValuesMK k v -> ValuesMK k v
rangeRead' Int
n (KeysMK Set k
ks) (ValuesMK Map k v
vs) =
    case Set k -> Maybe k
forall a. Set a -> Maybe a
Set.lookupMax Set k
ks of
      Maybe k
Nothing -> Map k v -> ValuesMK k v
forall k v. Map k v -> ValuesMK k v
ValuesMK Map k v
forall k a. Map k a
Map.empty
      Just 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
$ Int -> Map k v -> Map k v
forall k a. Int -> Map k a -> Map k a
Map.take Int
n (Map k v -> Map k v) -> Map k v -> Map k v
forall a b. (a -> b) -> a -> b
$ (Map k v, Map k v) -> Map k v
forall a b. (a, b) -> b
snd ((Map k v, Map k v) -> Map k v) -> (Map k v, Map k v) -> Map k v
forall a b. (a -> b) -> a -> b
$ k -> Map k v -> (Map k v, Map k v)
forall k a. Ord k => k -> Map k a -> (Map k a, Map k a)
Map.split k
k Map k v
vs

  appDiffs ::
    LedgerTables l ValuesMK ->
    LedgerTables l DiffMK ->
    LedgerTables l ValuesMK
  appDiffs :: LedgerTables l ValuesMK
-> LedgerTables l DiffMK -> LedgerTables l ValuesMK
appDiffs = (forall k v.
 LedgerTableConstraints' l k v =>
 ValuesMK k v -> DiffMK k v -> ValuesMK k v)
-> LedgerTables l ValuesMK
-> LedgerTables l DiffMK
-> LedgerTables l ValuesMK
forall (l :: LedgerStateKind) (mk1 :: * -> * -> *)
       (mk2 :: * -> * -> *) (mk3 :: * -> * -> *).
LedgerTableConstraints l =>
(forall k v.
 LedgerTableConstraints' l k v =>
 mk1 k v -> mk2 k v -> mk3 k v)
-> LedgerTables l mk1 -> LedgerTables l mk2 -> LedgerTables l mk3
ltliftA2 ValuesMK k v -> DiffMK k v -> ValuesMK k v
forall k v. Ord k => ValuesMK k v -> DiffMK k v -> ValuesMK k v
forall k v.
LedgerTableConstraints' l k v =>
ValuesMK k v -> DiffMK k v -> ValuesMK k v
applyDiff_

  applyDiff_ ::
    Ord k =>
    ValuesMK k v ->
    DiffMK k v ->
    ValuesMK k v
  applyDiff_ :: forall k v. Ord k => ValuesMK k v -> DiffMK k v -> ValuesMK k v
applyDiff_ (ValuesMK Map k v
values) (DiffMK Diff k v
diff) =
    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
values Diff k v
diff)

  count :: LedgerTables l ValuesMK -> Int
  count :: LedgerTables l ValuesMK -> Int
count = LedgerTables l (K2 Int) -> Int
forall (l :: LedgerStateKind) a. LedgerTables l (K2 a) -> a
ltcollapse (LedgerTables l (K2 Int) -> Int)
-> (LedgerTables l ValuesMK -> LedgerTables l (K2 Int))
-> LedgerTables l ValuesMK
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall k v.
 LedgerTableConstraints' l k v =>
 ValuesMK k v -> K2 Int k v)
-> LedgerTables l ValuesMK -> LedgerTables l (K2 Int)
forall (l :: LedgerStateKind) (mk1 :: * -> * -> *)
       (mk2 :: * -> * -> *).
LedgerTableConstraints l =>
(forall k v. LedgerTableConstraints' l k v => mk1 k v -> mk2 k v)
-> LedgerTables l mk1 -> LedgerTables l mk2
ltmap (Int -> K2 Int k v
forall k1 k2 a (b :: k1) (c :: k2). a -> K2 a b c
K2 (Int -> K2 Int k v)
-> (ValuesMK k v -> Int) -> ValuesMK k v -> K2 Int k v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ValuesMK k v -> Int
forall k v. ValuesMK k v -> Int
count')

  count' :: ValuesMK k v -> Int
  count' :: forall k v. ValuesMK k v -> Int
count' (ValuesMK Map k v
values) = Map k v -> Int
forall k a. Map k a -> Int
Map.size Map k v
values

guardClosed ::
  IOLike m =>
  StrictTVar m (BackingStoreContents ks vs) ->
  STM m ()
guardClosed :: forall (m :: * -> *) ks (vs :: LedgerStateKind).
IOLike m =>
StrictTVar m (BackingStoreContents ks vs) -> STM m ()
guardClosed StrictTVar m (BackingStoreContents ks vs)
ref =
  StrictTVar m (BackingStoreContents ks vs)
-> STM m (BackingStoreContents ks vs)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (BackingStoreContents ks vs)
ref STM m (BackingStoreContents ks vs)
-> (BackingStoreContents ks vs -> STM m ()) -> STM m ()
forall a b. STM m a -> (a -> STM m b) -> STM m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    BackingStoreContents ks vs
BackingStoreContentsClosed -> InMemoryBackingStoreExn -> STM m ()
forall (m :: * -> *) e a.
(MonadSTM m, MonadThrow (STM m), Exception e) =>
e -> STM m a
throwSTM InMemoryBackingStoreExn
InMemoryBackingStoreClosedExn
    BackingStoreContents WithOrigin SlotNo
_ LedgerTables vs ValuesMK
_ -> () -> STM m ()
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

guardHandleClosed ::
  IOLike m =>
  StrictTVar m Bool ->
  STM m ()
guardHandleClosed :: forall (m :: * -> *). IOLike m => StrictTVar m Bool -> STM m ()
guardHandleClosed StrictTVar m Bool
refHandleClosed = do
  isClosed <- StrictTVar m Bool -> STM m Bool
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m Bool
refHandleClosed
  when isClosed $ throwSTM InMemoryBackingStoreValueHandleClosedExn

{-------------------------------------------------------------------------------
  Errors
-------------------------------------------------------------------------------}

-- | Errors that the InMemory backing store can throw on runtime.
--
-- __WARNING__: these errors will be thrown in IO as having a corrupt database
-- is critical for the functioning of Consensus.
data InMemoryBackingStoreExn
  = InMemoryBackingStoreClosedExn
  | InMemoryBackingStoreValueHandleClosedExn
  | InMemoryBackingStoreDirectoryExists
  | InMemoryBackingStoreNonMonotonicSeq !(WithOrigin SlotNo) !(WithOrigin SlotNo)
  | InMemoryBackingStoreDeserialiseExn CBOR.DeserialiseFailure
  | InMemoryIncompleteDeserialiseExn
  deriving anyclass Show InMemoryBackingStoreExn
Typeable InMemoryBackingStoreExn
(Typeable InMemoryBackingStoreExn, Show InMemoryBackingStoreExn) =>
(InMemoryBackingStoreExn -> SomeException)
-> (SomeException -> Maybe InMemoryBackingStoreExn)
-> (InMemoryBackingStoreExn -> String)
-> (InMemoryBackingStoreExn -> Bool)
-> Exception InMemoryBackingStoreExn
SomeException -> Maybe InMemoryBackingStoreExn
InMemoryBackingStoreExn -> Bool
InMemoryBackingStoreExn -> String
InMemoryBackingStoreExn -> SomeException
forall e.
(Typeable e, Show e) =>
(e -> SomeException)
-> (SomeException -> Maybe e)
-> (e -> String)
-> (e -> Bool)
-> Exception e
$ctoException :: InMemoryBackingStoreExn -> SomeException
toException :: InMemoryBackingStoreExn -> SomeException
$cfromException :: SomeException -> Maybe InMemoryBackingStoreExn
fromException :: SomeException -> Maybe InMemoryBackingStoreExn
$cdisplayException :: InMemoryBackingStoreExn -> String
displayException :: InMemoryBackingStoreExn -> String
$cbacktraceDesired :: InMemoryBackingStoreExn -> Bool
backtraceDesired :: InMemoryBackingStoreExn -> Bool
Exception
  deriving stock Int -> InMemoryBackingStoreExn -> ShowS
[InMemoryBackingStoreExn] -> ShowS
InMemoryBackingStoreExn -> String
(Int -> InMemoryBackingStoreExn -> ShowS)
-> (InMemoryBackingStoreExn -> String)
-> ([InMemoryBackingStoreExn] -> ShowS)
-> Show InMemoryBackingStoreExn
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> InMemoryBackingStoreExn -> ShowS
showsPrec :: Int -> InMemoryBackingStoreExn -> ShowS
$cshow :: InMemoryBackingStoreExn -> String
show :: InMemoryBackingStoreExn -> String
$cshowList :: [InMemoryBackingStoreExn] -> ShowS
showList :: [InMemoryBackingStoreExn] -> ShowS
Show

-- | Errors that the InMemory backing store can throw on initialization.
--
-- __WARNING__: these errors will be thrown in IO as having a corrupt database
-- is critical for the functioning of Consensus.
newtype InMemoryBackingStoreInitExn
  = StoreDirIsIncompatible FsErrorPath
  deriving anyclass Show InMemoryBackingStoreInitExn
Typeable InMemoryBackingStoreInitExn
(Typeable InMemoryBackingStoreInitExn,
 Show InMemoryBackingStoreInitExn) =>
(InMemoryBackingStoreInitExn -> SomeException)
-> (SomeException -> Maybe InMemoryBackingStoreInitExn)
-> (InMemoryBackingStoreInitExn -> String)
-> (InMemoryBackingStoreInitExn -> Bool)
-> Exception InMemoryBackingStoreInitExn
SomeException -> Maybe InMemoryBackingStoreInitExn
InMemoryBackingStoreInitExn -> Bool
InMemoryBackingStoreInitExn -> String
InMemoryBackingStoreInitExn -> SomeException
forall e.
(Typeable e, Show e) =>
(e -> SomeException)
-> (SomeException -> Maybe e)
-> (e -> String)
-> (e -> Bool)
-> Exception e
$ctoException :: InMemoryBackingStoreInitExn -> SomeException
toException :: InMemoryBackingStoreInitExn -> SomeException
$cfromException :: SomeException -> Maybe InMemoryBackingStoreInitExn
fromException :: SomeException -> Maybe InMemoryBackingStoreInitExn
$cdisplayException :: InMemoryBackingStoreInitExn -> String
displayException :: InMemoryBackingStoreInitExn -> String
$cbacktraceDesired :: InMemoryBackingStoreInitExn -> Bool
backtraceDesired :: InMemoryBackingStoreInitExn -> Bool
Exception

instance Show InMemoryBackingStoreInitExn where
  show :: InMemoryBackingStoreInitExn -> String
show (StoreDirIsIncompatible FsErrorPath
p) =
    String
"In-Memory database not found in the database directory: "
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> FsErrorPath -> String
forall a. Show a => a -> String
show FsErrorPath
p
      String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
".\nPre-UTxO-HD and LMDB implementations are incompatible with the In-Memory \
         \ implementation. Please delete your ledger database directory."