{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Ouroboros.Consensus.Storage.LeiosDB.Impl.InMemory
  ( InMemoryLeiosDb (..)
  , emptyInMemoryLeiosDb
  , newLeiosDBInMemory
  , newLeiosDBInMemoryWith
  ) where

import Cardano.Prelude (Generic, forM_, unless, when)
import Cardano.Slotting.Slot (SlotNo (..))
import Control.Applicative ((<|>))
import Control.Concurrent.Class.MonadSTM.Strict
  ( StrictTChan
  , StrictTVar
  , dupTChan
  , modifyTVar
  , newBroadcastTChan
  , newTVarIO
  , readTVar
  , writeTChan
  , writeTVar
  )
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import Data.IntMap.Strict (IntMap)
import qualified Data.IntMap.Strict as IntMap
import qualified Data.IntSet as IntSet
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Maybe (isNothing)
import Data.Set (Set)
import qualified Data.Set as Set
import GHC.Stack (HasCallStack)
import qualified GHC.Stack as GHC
import Ouroboros.Consensus.Leios.Types
  ( BytesSize
  , EndorserBlock
  , EndorserBlockHash
  , LeiosPoint (..)
  , TxHash
  , TxOffset
  , encodeEndorserBlockSize
  , endorserBlockReferences
  )
import Ouroboros.Consensus.Storage.LeiosDB.API
  ( CompletedEbs
  , LeiosDbHandle (..)
  , LeiosDbReader (..)
  , LeiosDbStats (..)
  , LeiosDbWriter (..)
  , LeiosEbNotification (..)
  , Promise (..)
  )
import Ouroboros.Consensus.Storage.LeiosDB.Exception
  ( LeiosDbException (LeiosDbWriteException)
  , LeiosDbWriteFailure (..)
  , throwLeiosDbException
  )
import Ouroboros.Consensus.Util.IOLike
  ( IOLike
  , NoThunks (..)
  , atomically
  , throwIO
  , toException
  , try
  )

-- | In-memory database state.
data InMemoryLeiosDb = InMemoryLeiosDb
  { InMemoryLeiosDb
-> Map (Hash HASH EraIndependentEbReferences) (IntMap ByteString)
imEbTxBytes :: !(Map EndorserBlockHash (IntMap {- txOffset -} ByteString))
  -- ^ Tx bytes owned by the referencing EB, keyed by offset -- mirrors the
  -- SQLite backend's @ebTxBytes@ table. A tx shared by two EBs is stored
  -- twice, deliberately.
  , InMemoryLeiosDb -> Map LeiosPoint BytesSize
imEbPoints :: !(Map LeiosPoint BytesSize)
  -- ^ Inserted EB points with their expected sizes. The same EB
  -- content can be inserted at multiple slots; each
  -- @(slot, hash)@ point has its own entry and completes
  -- independently.
  , InMemoryLeiosDb -> Set LeiosPoint
imEbBodiesDownloaded :: !(Set LeiosPoint)
  -- ^ Subset of 'imEbPoints' for which 'writeEbBody' has been
  -- called. Only these points are considered for completion.
  , InMemoryLeiosDb
-> Map (Hash HASH EraIndependentEbReferences) (IntMap EbTxEntry)
imEbBodies :: !(Map EndorserBlockHash (IntMap {- txOffset -} EbTxEntry))
  -- ^ EB tx-hash list, keyed by EB hash. Shared across every
  -- point that references the same EB.
  , InMemoryLeiosDb -> Set LeiosPoint
imCompletedEbs :: !(Set LeiosPoint)
  -- ^ Points for which 'AcquiredEbTxs' has already been broadcast.
  -- The completion predicate stays true once an EB is complete, so
  -- any later batch containing one of its txs would re-trigger it
  -- without this guard; downstream consumers (e.g. 'runLeiosVoting')
  -- treat the re-notification as fatal ('AlreadyKnown' from
  -- 'addVote'). Each point carries the EB's hash and its announcer slot,
  -- so this is also the source for
  -- 'scanCompleteEbClosuresNotOlderThanSlot'.
  , InMemoryLeiosDb
-> Map (Hash HASH EraIndependentEbReferences) (IntMap EbTxEntry)
imImmutableEbBodies :: !(Map EndorserBlockHash (IntMap EbTxEntry))
  -- ^ The bodies of the EBs 'leiosDbPromoteToImmutable' promoted. The garbage
  -- collection evicts such an EB from the other fields like any other, and the
  -- reads fall back to this and 'imImmutableEbTxBytes'.
  , InMemoryLeiosDb
-> Map (Hash HASH EraIndependentEbReferences) (IntMap ByteString)
imImmutableEbTxBytes :: !(Map EndorserBlockHash (IntMap {- txOffset -} ByteString))
  -- ^ The tx bytes of the bodies in 'imImmutableEbBodies', by offset.
  }
  deriving stock (forall x. InMemoryLeiosDb -> Rep InMemoryLeiosDb x)
-> (forall x. Rep InMemoryLeiosDb x -> InMemoryLeiosDb)
-> Generic InMemoryLeiosDb
forall x. Rep InMemoryLeiosDb x -> InMemoryLeiosDb
forall x. InMemoryLeiosDb -> Rep InMemoryLeiosDb x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. InMemoryLeiosDb -> Rep InMemoryLeiosDb x
from :: forall x. InMemoryLeiosDb -> Rep InMemoryLeiosDb x
$cto :: forall x. Rep InMemoryLeiosDb x -> InMemoryLeiosDb
to :: forall x. Rep InMemoryLeiosDb x -> InMemoryLeiosDb
Generic
  deriving anyclass Context -> InMemoryLeiosDb -> IO (Maybe ThunkInfo)
Proxy InMemoryLeiosDb -> String
(Context -> InMemoryLeiosDb -> IO (Maybe ThunkInfo))
-> (Context -> InMemoryLeiosDb -> IO (Maybe ThunkInfo))
-> (Proxy InMemoryLeiosDb -> String)
-> NoThunks InMemoryLeiosDb
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: Context -> InMemoryLeiosDb -> IO (Maybe ThunkInfo)
noThunks :: Context -> InMemoryLeiosDb -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> InMemoryLeiosDb -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> InMemoryLeiosDb -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy InMemoryLeiosDb -> String
showTypeOf :: Proxy InMemoryLeiosDb -> String
NoThunks

emptyInMemoryLeiosDb :: InMemoryLeiosDb
emptyInMemoryLeiosDb :: InMemoryLeiosDb
emptyInMemoryLeiosDb = Map (Hash HASH EraIndependentEbReferences) (IntMap ByteString)
-> Map LeiosPoint BytesSize
-> Set LeiosPoint
-> Map (Hash HASH EraIndependentEbReferences) (IntMap EbTxEntry)
-> Set LeiosPoint
-> Map (Hash HASH EraIndependentEbReferences) (IntMap EbTxEntry)
-> Map (Hash HASH EraIndependentEbReferences) (IntMap ByteString)
-> InMemoryLeiosDb
InMemoryLeiosDb Map (Hash HASH EraIndependentEbReferences) (IntMap ByteString)
forall a. Monoid a => a
mempty Map LeiosPoint BytesSize
forall a. Monoid a => a
mempty Set LeiosPoint
forall a. Monoid a => a
mempty Map (Hash HASH EraIndependentEbReferences) (IntMap EbTxEntry)
forall a. Monoid a => a
mempty Set LeiosPoint
forall a. Monoid a => a
mempty Map (Hash HASH EraIndependentEbReferences) (IntMap EbTxEntry)
forall a. Monoid a => a
mempty Map (Hash HASH EraIndependentEbReferences) (IntMap ByteString)
forall a. Monoid a => a
mempty

-- | EB transaction entry (no bytes stored here, see 'imEbTxBytes')
data EbTxEntry = EbTxEntry
  { EbTxEntry -> TxHash
eteTxHash :: !TxHash
  , EbTxEntry -> BytesSize
eteTxBytesSize :: !BytesSize
  }
  deriving stock (forall x. EbTxEntry -> Rep EbTxEntry x)
-> (forall x. Rep EbTxEntry x -> EbTxEntry) -> Generic EbTxEntry
forall x. Rep EbTxEntry x -> EbTxEntry
forall x. EbTxEntry -> Rep EbTxEntry x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. EbTxEntry -> Rep EbTxEntry x
from :: forall x. EbTxEntry -> Rep EbTxEntry x
$cto :: forall x. Rep EbTxEntry x -> EbTxEntry
to :: forall x. Rep EbTxEntry x -> EbTxEntry
Generic
  deriving anyclass Context -> EbTxEntry -> IO (Maybe ThunkInfo)
Proxy EbTxEntry -> String
(Context -> EbTxEntry -> IO (Maybe ThunkInfo))
-> (Context -> EbTxEntry -> IO (Maybe ThunkInfo))
-> (Proxy EbTxEntry -> String)
-> NoThunks EbTxEntry
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: Context -> EbTxEntry -> IO (Maybe ThunkInfo)
noThunks :: Context -> EbTxEntry -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> EbTxEntry -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> EbTxEntry -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy EbTxEntry -> String
showTypeOf :: Proxy EbTxEntry -> String
NoThunks

-- | Create a new in-memory Leios database handle.
-- This is suitable for testing in IOSim.
newLeiosDBInMemory :: IOLike m => m (LeiosDbHandle m)
newLeiosDBInMemory :: forall (m :: * -> *). IOLike m => m (LeiosDbHandle m)
newLeiosDBInMemory = do
  stateVar <- InMemoryLeiosDb -> m (StrictTVar m InMemoryLeiosDb)
forall (m :: * -> *) a. MonadSTM m => a -> m (StrictTVar m a)
newTVarIO InMemoryLeiosDb
emptyInMemoryLeiosDb
  newLeiosDBInMemoryWith stateVar

newLeiosDBInMemoryWith :: IOLike m => StrictTVar m InMemoryLeiosDb -> m (LeiosDbHandle m)
newLeiosDBInMemoryWith :: forall (m :: * -> *).
IOLike m =>
StrictTVar m InMemoryLeiosDb -> m (LeiosDbHandle m)
newLeiosDBInMemoryWith StrictTVar m InMemoryLeiosDb
stateVar = do
  notificationChan <- STM m (StrictTChan m LeiosEbNotification)
-> m (StrictTChan m LeiosEbNotification)
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically STM m (StrictTChan m LeiosEbNotification)
forall (m :: * -> *) a. MonadSTM m => STM m (StrictTChan m a)
newBroadcastTChan
  pure $
    LeiosDbHandle
      { -- Nothing to close: the state is a 'StrictTVar'.
        closeLeiosDbHandle = pure ()
      , subscribeEbNotifications =
          atomically (dupTChan notificationChan)
      , garbageCollect = imGarbageCollect stateVar
      , leiosDbPromoteToImmutable = imPromoteToImmutable stateVar
      , -- The in-memory implementation does not track stats.
        leiosDbSampleStats = pure (LeiosDbStats 0 0 0)
      , openReader = openInMemoryReader stateVar
      , openWriter = openInMemoryWriter stateVar notificationChan
      }

-- | Copy the closures of the given EBs to 'imImmutableEbBodies' and
-- 'imImmutableEbTxBytes', unless they are there already. The node pins only what
-- the immutable chain certifies, and only once it holds its closure, so a
-- closure that is incomplete is a caller's bug: this then fails, changing
-- nothing.
imPromoteToImmutable :: IOLike m => StrictTVar m InMemoryLeiosDb -> [LeiosPoint] -> m ()
imPromoteToImmutable :: forall (m :: * -> *).
IOLike m =>
StrictTVar m InMemoryLeiosDb -> [LeiosPoint] -> m ()
imPromoteToImmutable StrictTVar m InMemoryLeiosDb
stateVar [LeiosPoint]
points = do
  incomplete <- STM m [Hash HASH EraIndependentEbReferences]
-> m [Hash HASH EraIndependentEbReferences]
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m [Hash HASH EraIndependentEbReferences]
 -> m [Hash HASH EraIndependentEbReferences])
-> STM m [Hash HASH EraIndependentEbReferences]
-> m [Hash HASH EraIndependentEbReferences]
forall a b. (a -> b) -> a -> b
$ do
    s <- StrictTVar m InMemoryLeiosDb -> STM m InMemoryLeiosDb
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m InMemoryLeiosDb
stateVar
    let closures =
          (Hash HASH EraIndependentEbReferences
 -> Maybe (IntMap EbTxEntry, IntMap ByteString))
-> Set (Hash HASH EraIndependentEbReferences)
-> Map
     (Hash HASH EraIndependentEbReferences)
     (Maybe (IntMap EbTxEntry, IntMap ByteString))
forall k a. (k -> a) -> Set k -> Map k a
Map.fromSet
            ( \Hash HASH EraIndependentEbReferences
ebHash -> do
                entries <- Hash HASH EraIndependentEbReferences
-> Map (Hash HASH EraIndependentEbReferences) (IntMap EbTxEntry)
-> Maybe (IntMap EbTxEntry)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Hash HASH EraIndependentEbReferences
ebHash (InMemoryLeiosDb
-> Map (Hash HASH EraIndependentEbReferences) (IntMap EbTxEntry)
imEbBodies InMemoryLeiosDb
s)
                let txBytes = InMemoryLeiosDb
-> Hash HASH EraIndependentEbReferences -> IntMap ByteString
volatileTxBytes InMemoryLeiosDb
s Hash HASH EraIndependentEbReferences
ebHash
                _ <- closureWith txBytes entries
                pure (entries, txBytes)
            )
            ( [Hash HASH EraIndependentEbReferences]
-> Set (Hash HASH EraIndependentEbReferences)
forall a. Ord a => [a] -> Set a
Set.fromList ((LeiosPoint -> Hash HASH EraIndependentEbReferences)
-> [LeiosPoint] -> [Hash HASH EraIndependentEbReferences]
forall a b. (a -> b) -> [a] -> [b]
map LeiosPoint -> Hash HASH EraIndependentEbReferences
pointEbHash [LeiosPoint]
points)
                Set (Hash HASH EraIndependentEbReferences)
-> Set (Hash HASH EraIndependentEbReferences)
-> Set (Hash HASH EraIndependentEbReferences)
forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` Map (Hash HASH EraIndependentEbReferences) (IntMap EbTxEntry)
-> Set (Hash HASH EraIndependentEbReferences)
forall k a. Map k a -> Set k
Map.keysSet (InMemoryLeiosDb
-> Map (Hash HASH EraIndependentEbReferences) (IntMap EbTxEntry)
imImmutableEbBodies InMemoryLeiosDb
s)
            )
        copied = (Maybe (IntMap EbTxEntry, IntMap ByteString)
 -> Maybe (IntMap EbTxEntry, IntMap ByteString))
-> Map
     (Hash HASH EraIndependentEbReferences)
     (Maybe (IntMap EbTxEntry, IntMap ByteString))
-> Map
     (Hash HASH EraIndependentEbReferences)
     (IntMap EbTxEntry, IntMap ByteString)
forall a b k. (a -> Maybe b) -> Map k a -> Map k b
Map.mapMaybe Maybe (IntMap EbTxEntry, IntMap ByteString)
-> Maybe (IntMap EbTxEntry, IntMap ByteString)
forall a. a -> a
id Map
  (Hash HASH EraIndependentEbReferences)
  (Maybe (IntMap EbTxEntry, IntMap ByteString))
closures
        incomplete = Map
  (Hash HASH EraIndependentEbReferences)
  (Maybe (IntMap EbTxEntry, IntMap ByteString))
-> [Hash HASH EraIndependentEbReferences]
forall k a. Map k a -> [k]
Map.keys ((Maybe (IntMap EbTxEntry, IntMap ByteString) -> Bool)
-> Map
     (Hash HASH EraIndependentEbReferences)
     (Maybe (IntMap EbTxEntry, IntMap ByteString))
-> Map
     (Hash HASH EraIndependentEbReferences)
     (Maybe (IntMap EbTxEntry, IntMap ByteString))
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter Maybe (IntMap EbTxEntry, IntMap ByteString) -> Bool
forall a. Maybe a -> Bool
isNothing Map
  (Hash HASH EraIndependentEbReferences)
  (Maybe (IntMap EbTxEntry, IntMap ByteString))
closures)
    when (null incomplete) $
      writeTVar
        stateVar
        s
          { imImmutableEbBodies = imImmutableEbBodies s <> fmap fst copied
          , imImmutableEbTxBytes = imImmutableEbTxBytes s <> fmap snd copied
          }
    pure incomplete
  unless (null incomplete) $
    throwLeiosDbException $
      "leiosDbPromoteToImmutable: incomplete closure (programmer error): " <> show incomplete

-- | Evict every EB all of whose points are older than the slot, with its body
-- and tx bytes. A promoted EB keeps its copy in 'imImmutableEbBodies' and
-- 'imImmutableEbTxBytes'.
imGarbageCollect :: IOLike m => StrictTVar m InMemoryLeiosDb -> SlotNo -> m ()
imGarbageCollect :: forall (m :: * -> *).
IOLike m =>
StrictTVar m InMemoryLeiosDb -> SlotNo -> m ()
imGarbageCollect StrictTVar m InMemoryLeiosDb
stateVar SlotNo
slot = STM m () -> m ()
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m () -> m ()) -> STM m () -> m ()
forall a b. (a -> b) -> a -> b
$ StrictTVar m InMemoryLeiosDb
-> (InMemoryLeiosDb -> InMemoryLeiosDb) -> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> (a -> a) -> STM m ()
modifyTVar StrictTVar m InMemoryLeiosDb
stateVar ((InMemoryLeiosDb -> InMemoryLeiosDb) -> STM m ())
-> (InMemoryLeiosDb -> InMemoryLeiosDb) -> STM m ()
forall a b. (a -> b) -> a -> b
$ \InMemoryLeiosDb
s ->
  let newestPointSlots :: Map (Hash HASH EraIndependentEbReferences) SlotNo
newestPointSlots =
        (SlotNo -> SlotNo -> SlotNo)
-> [(Hash HASH EraIndependentEbReferences, SlotNo)]
-> Map (Hash HASH EraIndependentEbReferences) SlotNo
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith SlotNo -> SlotNo -> SlotNo
forall a. Ord a => a -> a -> a
max [(LeiosPoint -> Hash HASH EraIndependentEbReferences
pointEbHash LeiosPoint
p, LeiosPoint -> SlotNo
pointSlotNo LeiosPoint
p) | LeiosPoint
p <- Map LeiosPoint BytesSize -> [LeiosPoint]
forall k a. Map k a -> [k]
Map.keys (InMemoryLeiosDb -> Map LeiosPoint BytesSize
imEbPoints InMemoryLeiosDb
s)]
      evicted :: Set (Hash HASH EraIndependentEbReferences)
evicted = Map (Hash HASH EraIndependentEbReferences) SlotNo
-> Set (Hash HASH EraIndependentEbReferences)
forall k a. Map k a -> Set k
Map.keysSet ((SlotNo -> Bool)
-> Map (Hash HASH EraIndependentEbReferences) SlotNo
-> Map (Hash HASH EraIndependentEbReferences) SlotNo
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter (SlotNo -> SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
< SlotNo
slot) Map (Hash HASH EraIndependentEbReferences) SlotNo
newestPointSlots)
      kept :: LeiosPoint -> Bool
kept LeiosPoint
p = LeiosPoint -> Hash HASH EraIndependentEbReferences
pointEbHash LeiosPoint
p Hash HASH EraIndependentEbReferences
-> Set (Hash HASH EraIndependentEbReferences) -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set (Hash HASH EraIndependentEbReferences)
evicted
   in InMemoryLeiosDb
s
        { imEbPoints = Map.filterWithKey (\LeiosPoint
p BytesSize
_ -> LeiosPoint -> Bool
kept LeiosPoint
p) (imEbPoints s)
        , imEbBodiesDownloaded = Set.filter kept (imEbBodiesDownloaded s)
        , imEbBodies = Map.withoutKeys (imEbBodies s) evicted
        , imEbTxBytes = Map.withoutKeys (imEbTxBytes s) evicted
        , imCompletedEbs = Set.filter kept (imCompletedEbs s)
        }

-- | Reads off the 'StrictTVar'. Nothing to open or close.
openInMemoryReader :: IOLike m => StrictTVar m InMemoryLeiosDb -> m (LeiosDbReader m)
openInMemoryReader :: forall (m :: * -> *).
IOLike m =>
StrictTVar m InMemoryLeiosDb -> m (LeiosDbReader m)
openInMemoryReader StrictTVar m InMemoryLeiosDb
stateVar =
  LeiosDbReader m -> m (LeiosDbReader m)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    LeiosDbReader
      { closeReader :: m ()
closeReader = () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      , lookupEbBody :: HasCallStack =>
Hash HASH EraIndependentEbReferences -> m [(TxHash, BytesSize)]
lookupEbBody = StrictTVar m InMemoryLeiosDb
-> Hash HASH EraIndependentEbReferences -> m [(TxHash, BytesSize)]
forall (m :: * -> *).
IOLike m =>
StrictTVar m InMemoryLeiosDb
-> Hash HASH EraIndependentEbReferences -> m [(TxHash, BytesSize)]
imLookupEbBody StrictTVar m InMemoryLeiosDb
stateVar
      , lookupEbClosure :: HasCallStack =>
Hash HASH EraIndependentEbReferences
-> m (Maybe [(TxHash, ByteString)])
lookupEbClosure = StrictTVar m InMemoryLeiosDb
-> Hash HASH EraIndependentEbReferences
-> m (Maybe [(TxHash, ByteString)])
forall (m :: * -> *).
IOLike m =>
StrictTVar m InMemoryLeiosDb
-> Hash HASH EraIndependentEbReferences
-> m (Maybe [(TxHash, ByteString)])
imLookupEbClosure StrictTVar m InMemoryLeiosDb
stateVar
      , batchRetrieveTxs :: HasCallStack =>
Hash HASH EraIndependentEbReferences
-> [Int] -> m [(Int, TxHash, Maybe ByteString)]
batchRetrieveTxs = StrictTVar m InMemoryLeiosDb
-> Hash HASH EraIndependentEbReferences
-> [Int]
-> m [(Int, TxHash, Maybe ByteString)]
forall (m :: * -> *).
IOLike m =>
StrictTVar m InMemoryLeiosDb
-> Hash HASH EraIndependentEbReferences
-> [Int]
-> m [(Int, TxHash, Maybe ByteString)]
imBatchRetrieveTxs StrictTVar m InMemoryLeiosDb
stateVar
      , testScanEbPoints :: HasCallStack => m [(SlotNo, Hash HASH EraIndependentEbReferences)]
testScanEbPoints = StrictTVar m InMemoryLeiosDb
-> m [(SlotNo, Hash HASH EraIndependentEbReferences)]
forall (m :: * -> *).
IOLike m =>
StrictTVar m InMemoryLeiosDb
-> m [(SlotNo, Hash HASH EraIndependentEbReferences)]
imScanEbPoints StrictTVar m InMemoryLeiosDb
stateVar
      , -- ThreadNet persists 'stateVar' across simulated restarts, so on
        -- restart this seeds the restored acquired-EB-closures set.
        scanCompleteEbClosuresNotOlderThanSlot :: HasCallStack => SlotNo -> m [LeiosPoint]
scanCompleteEbClosuresNotOlderThanSlot = StrictTVar m InMemoryLeiosDb -> SlotNo -> m [LeiosPoint]
forall (m :: * -> *).
IOLike m =>
StrictTVar m InMemoryLeiosDb -> SlotNo -> m [LeiosPoint]
imScanCompleteEbClosuresSince StrictTVar m InMemoryLeiosDb
stateVar
      }

-- | No worker and no queue: the state is a 'StrictTVar', so each write runs
-- at submission and its 'Promise' comes back already resolved. A failure is
-- captured rather than thrown here, so it surfaces at 'await' exactly like
-- the SQLite backend's.
openInMemoryWriter ::
  forall m.
  IOLike m =>
  StrictTVar m InMemoryLeiosDb ->
  StrictTChan m LeiosEbNotification ->
  m (LeiosDbWriter m)
openInMemoryWriter :: forall (m :: * -> *).
IOLike m =>
StrictTVar m InMemoryLeiosDb
-> StrictTChan m LeiosEbNotification -> m (LeiosDbWriter m)
openInMemoryWriter StrictTVar m InMemoryLeiosDb
stateVar StrictTChan m LeiosEbNotification
notificationChan =
  LeiosDbWriter m -> m (LeiosDbWriter m)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    LeiosDbWriter
      { closeWriter :: m ()
closeWriter = () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      , writeEbPoint :: HasCallStack => LeiosPoint -> BytesSize -> m (Promise m ())
writeEbPoint = \LeiosPoint
point BytesSize
ebBytesSize ->
          String -> m () -> m (Promise m ())
forall a. HasCallStack => String -> m a -> m (Promise m a)
resolved (String
"WriteEbPoint " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> LeiosPoint -> String
forall a. Show a => a -> String
show LeiosPoint
point) (StrictTVar m InMemoryLeiosDb -> LeiosPoint -> BytesSize -> m ()
forall (m :: * -> *).
IOLike m =>
StrictTVar m InMemoryLeiosDb -> LeiosPoint -> BytesSize -> m ()
imInsertEbPoint StrictTVar m InMemoryLeiosDb
stateVar LeiosPoint
point BytesSize
ebBytesSize)
      , writeEbBody :: HasCallStack =>
LeiosPoint -> EndorserBlock -> m (Promise m [LeiosPoint])
writeEbBody = \LeiosPoint
point EndorserBlock
eb ->
          String -> m [LeiosPoint] -> m (Promise m [LeiosPoint])
forall a. HasCallStack => String -> m a -> m (Promise m a)
resolved (String
"WriteEbBody " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> LeiosPoint -> String
forall a. Show a => a -> String
show LeiosPoint
point) (StrictTVar m InMemoryLeiosDb
-> StrictTChan m LeiosEbNotification
-> LeiosPoint
-> EndorserBlock
-> m [LeiosPoint]
forall (m :: * -> *).
IOLike m =>
StrictTVar m InMemoryLeiosDb
-> StrictTChan m LeiosEbNotification
-> LeiosPoint
-> EndorserBlock
-> m [LeiosPoint]
imInsertEbBody StrictTVar m InMemoryLeiosDb
stateVar StrictTChan m LeiosEbNotification
notificationChan LeiosPoint
point EndorserBlock
eb)
      , writeTxs :: HasCallStack =>
LeiosPoint -> [(Int, ByteString)] -> m (Promise m [LeiosPoint])
writeTxs = \LeiosPoint
point [(Int, ByteString)]
txs ->
          String -> m [LeiosPoint] -> m (Promise m [LeiosPoint])
forall a. HasCallStack => String -> m a -> m (Promise m a)
resolved
            (String
"WriteTxs " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> LeiosPoint -> String
forall a. Show a => a -> String
show LeiosPoint
point String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" (" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show ([(Int, ByteString)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Int, ByteString)]
txs) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" txs)")
            (StrictTVar m InMemoryLeiosDb
-> StrictTChan m LeiosEbNotification
-> LeiosPoint
-> [(Int, ByteString)]
-> m [LeiosPoint]
forall (m :: * -> *).
IOLike m =>
StrictTVar m InMemoryLeiosDb
-> StrictTChan m LeiosEbNotification
-> LeiosPoint
-> [(Int, ByteString)]
-> m [LeiosPoint]
imInsertTxs StrictTVar m InMemoryLeiosDb
stateVar StrictTChan m LeiosEbNotification
notificationChan LeiosPoint
point [(Int, ByteString)]
txs)
      }
 where
  resolved :: HasCallStack => String -> m a -> m (Promise m a)
  resolved :: forall a. HasCallStack => String -> m a -> m (Promise m a)
resolved String
job m a
action = do
    result <- m a -> m (Either LeiosDbException a)
forall e a. Exception e => m a -> m (Either e a)
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
try m a
action
    pure $ Promise $ case result of
      Right a
x -> a -> m a
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
      Left LeiosDbException
cause ->
        LeiosDbException -> m a
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (LeiosDbException -> m a) -> LeiosDbException -> m a
forall a b. (a -> b) -> a -> b
$
          LeiosDbWriteFailure -> LeiosDbException
LeiosDbWriteException
            LeiosDbWriteFailure
              { ldwfWriteJob :: String
ldwfWriteJob = String
job
              , ldwfSubmittedFrom :: String
ldwfSubmittedFrom = CallStack -> String
GHC.prettyCallStack CallStack
HasCallStack => CallStack
GHC.callStack
              , ldwfWriteFailure :: SomeException
ldwfWriteFailure = LeiosDbException -> SomeException
forall e. Exception e => e -> SomeException
toException (LeiosDbException
cause :: LeiosDbException)
              }

-- * Top-level implementations

imScanEbPoints :: IOLike m => StrictTVar m InMemoryLeiosDb -> m [(SlotNo, EndorserBlockHash)]
imScanEbPoints :: forall (m :: * -> *).
IOLike m =>
StrictTVar m InMemoryLeiosDb
-> m [(SlotNo, Hash HASH EraIndependentEbReferences)]
imScanEbPoints StrictTVar m InMemoryLeiosDb
stateVar = STM m [(SlotNo, Hash HASH EraIndependentEbReferences)]
-> m [(SlotNo, Hash HASH EraIndependentEbReferences)]
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m [(SlotNo, Hash HASH EraIndependentEbReferences)]
 -> m [(SlotNo, Hash HASH EraIndependentEbReferences)])
-> STM m [(SlotNo, Hash HASH EraIndependentEbReferences)]
-> m [(SlotNo, Hash HASH EraIndependentEbReferences)]
forall a b. (a -> b) -> a -> b
$ do
  state <- StrictTVar m InMemoryLeiosDb -> STM m InMemoryLeiosDb
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m InMemoryLeiosDb
stateVar
  pure
    [ (pointSlotNo p, pointEbHash p)
    | p <- Map.keys (imEbPoints state)
    ]

-- | Insert an announced EB point. Idempotent: a second insert at the
-- same point keeps the first-seen size.
imInsertEbPoint :: IOLike m => StrictTVar m InMemoryLeiosDb -> LeiosPoint -> BytesSize -> m ()
imInsertEbPoint :: forall (m :: * -> *).
IOLike m =>
StrictTVar m InMemoryLeiosDb -> LeiosPoint -> BytesSize -> m ()
imInsertEbPoint StrictTVar m InMemoryLeiosDb
stateVar LeiosPoint
point BytesSize
ebBytesSize = STM m () -> m ()
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m () -> m ()) -> STM m () -> m ()
forall a b. (a -> b) -> a -> b
$
  StrictTVar m InMemoryLeiosDb
-> (InMemoryLeiosDb -> InMemoryLeiosDb) -> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> (a -> a) -> STM m ()
modifyTVar StrictTVar m InMemoryLeiosDb
stateVar ((InMemoryLeiosDb -> InMemoryLeiosDb) -> STM m ())
-> (InMemoryLeiosDb -> InMemoryLeiosDb) -> STM m ()
forall a b. (a -> b) -> a -> b
$ \InMemoryLeiosDb
s ->
    InMemoryLeiosDb
s{imEbPoints = Map.insertWith (\BytesSize
_ BytesSize
old -> BytesSize
old) point ebBytesSize (imEbPoints s)}

imLookupEbBody ::
  IOLike m => StrictTVar m InMemoryLeiosDb -> EndorserBlockHash -> m [(TxHash, BytesSize)]
imLookupEbBody :: forall (m :: * -> *).
IOLike m =>
StrictTVar m InMemoryLeiosDb
-> Hash HASH EraIndependentEbReferences -> m [(TxHash, BytesSize)]
imLookupEbBody StrictTVar m InMemoryLeiosDb
stateVar Hash HASH EraIndependentEbReferences
ebHash = STM m [(TxHash, BytesSize)] -> m [(TxHash, BytesSize)]
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m [(TxHash, BytesSize)] -> m [(TxHash, BytesSize)])
-> STM m [(TxHash, BytesSize)] -> m [(TxHash, BytesSize)]
forall a b. (a -> b) -> a -> b
$ do
  state <- StrictTVar m InMemoryLeiosDb -> STM m InMemoryLeiosDb
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m InMemoryLeiosDb
stateVar
  case Map.lookup ebHash (imEbBodies state) <|> Map.lookup ebHash (imImmutableEbBodies state) of
    Maybe (IntMap EbTxEntry)
Nothing -> [(TxHash, BytesSize)] -> STM m [(TxHash, BytesSize)]
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
    Just IntMap EbTxEntry
offsetMap ->
      [(TxHash, BytesSize)] -> STM m [(TxHash, BytesSize)]
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        [ (EbTxEntry -> TxHash
eteTxHash EbTxEntry
e, EbTxEntry -> BytesSize
eteTxBytesSize EbTxEntry
e)
        | EbTxEntry
e <- IntMap EbTxEntry -> [EbTxEntry]
forall a. IntMap a -> [a]
IntMap.elems IntMap EbTxEntry
offsetMap
        ]

imInsertEbBody ::
  IOLike m =>
  StrictTVar m InMemoryLeiosDb ->
  StrictTChan m LeiosEbNotification ->
  LeiosPoint ->
  EndorserBlock ->
  m CompletedEbs
imInsertEbBody :: forall (m :: * -> *).
IOLike m =>
StrictTVar m InMemoryLeiosDb
-> StrictTChan m LeiosEbNotification
-> LeiosPoint
-> EndorserBlock
-> m [LeiosPoint]
imInsertEbBody StrictTVar m InMemoryLeiosDb
stateVar StrictTChan m LeiosEbNotification
notificationChan LeiosPoint
point EndorserBlock
eb = do
  let items :: [(Int, (TxHash, BytesSize))]
items = [Int] -> [(TxHash, BytesSize)] -> [(Int, (TxHash, BytesSize))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 :: Int ..] (EndorserBlock -> [(TxHash, BytesSize)]
endorserBlockReferences EndorserBlock
eb)
      ebBytesSize :: BytesSize
ebBytesSize = EndorserBlock -> BytesSize
encodeEndorserBlockSize EndorserBlock
eb
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([(Int, (TxHash, BytesSize))] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Int, (TxHash, BytesSize))]
items) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
    String -> m ()
forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
throwLeiosDbException String
"writeEbBody: empty EB body (programmer error)"
  known <- LeiosPoint -> Map LeiosPoint BytesSize -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member LeiosPoint
point (Map LeiosPoint BytesSize -> Bool)
-> (InMemoryLeiosDb -> Map LeiosPoint BytesSize)
-> InMemoryLeiosDb
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InMemoryLeiosDb -> Map LeiosPoint BytesSize
imEbPoints (InMemoryLeiosDb -> Bool) -> m InMemoryLeiosDb -> m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STM m InMemoryLeiosDb -> m InMemoryLeiosDb
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (StrictTVar m InMemoryLeiosDb -> STM m InMemoryLeiosDb
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m InMemoryLeiosDb
stateVar)
  unless known $
    throwLeiosDbException "writeEbBody: point not registered (programmer error)"
  atomically $ do
    let entries =
          [(Int, EbTxEntry)] -> IntMap EbTxEntry
forall a. [(Int, a)] -> IntMap a
IntMap.fromList
            [ ( Int
offset
              , EbTxEntry
                  { eteTxHash :: TxHash
eteTxHash = TxHash
txHash
                  , eteTxBytesSize :: BytesSize
eteTxBytesSize = BytesSize
size
                  }
              )
            | (Int
offset, (TxHash
txHash, BytesSize
size)) <- [(Int, (TxHash, BytesSize))]
items
            ]
    modifyTVar stateVar $ \InMemoryLeiosDb
s ->
      InMemoryLeiosDb
s
        { -- The tx-hash list is fully determined by the EB content
          -- hash, so a second insertion at the same hash is a no-op.
          imEbBodies =
            Map.insertWith (\IntMap EbTxEntry
_ IntMap EbTxEntry
old -> IntMap EbTxEntry
old) (pointEbHash point) entries (imEbBodies s)
        , -- Mark this point as downloaded. Other points referencing
          -- the same EB hash are unaffected; each needs its own
          -- 'writeEbBody' to be considered complete.
          imEbBodiesDownloaded =
            Set.insert point (imEbBodiesDownloaded s)
        }
    writeTChan notificationChan $ AcquiredEb point ebBytesSize
    -- If every tx referenced by this body is already present, the closure
    -- is complete the moment the body lands — no subsequent
    -- 'writeTxs' will fire for this point, so we must notify here.
    -- Only trigger for a novel point ('imCompletedEbs' is our idempotency
    -- guard). This mirrors what 'imInsertTxs' does when the last missing
    -- tx of an already-downloaded body arrives.
    state <- readTVar stateVar
    let allTxsPresent = InMemoryLeiosDb -> Hash HASH EraIndependentEbReferences -> Bool
hashCompleteIn InMemoryLeiosDb
state (LeiosPoint -> Hash HASH EraIndependentEbReferences
pointEbHash LeiosPoint
point)
        alreadyNotified = LeiosPoint -> Set LeiosPoint -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member LeiosPoint
point (InMemoryLeiosDb -> Set LeiosPoint
imCompletedEbs InMemoryLeiosDb
state)
    if allTxsPresent && not alreadyNotified
      then do
        modifyTVar stateVar $ \InMemoryLeiosDb
s ->
          InMemoryLeiosDb
s{imCompletedEbs = Set.insert point (imCompletedEbs s)}
        writeTChan notificationChan (AcquiredEbTxs point)
        pure [point]
      else pure []

-- | Whether every offset of this EB body has its bytes.
hashCompleteIn :: InMemoryLeiosDb -> EndorserBlockHash -> Bool
hashCompleteIn :: InMemoryLeiosDb -> Hash HASH EraIndependentEbReferences -> Bool
hashCompleteIn InMemoryLeiosDb
state Hash HASH EraIndependentEbReferences
h = case Hash HASH EraIndependentEbReferences
-> Map (Hash HASH EraIndependentEbReferences) (IntMap EbTxEntry)
-> Maybe (IntMap EbTxEntry)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Hash HASH EraIndependentEbReferences
h (InMemoryLeiosDb
-> Map (Hash HASH EraIndependentEbReferences) (IntMap EbTxEntry)
imEbBodies InMemoryLeiosDb
state) of
  Maybe (IntMap EbTxEntry)
Nothing -> Bool
False
  Just IntMap EbTxEntry
entries ->
    let txBytesByOffset :: IntMap ByteString
txBytesByOffset = IntMap ByteString
-> Hash HASH EraIndependentEbReferences
-> Map (Hash HASH EraIndependentEbReferences) (IntMap ByteString)
-> IntMap ByteString
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault IntMap ByteString
forall a. IntMap a
IntMap.empty Hash HASH EraIndependentEbReferences
h (InMemoryLeiosDb
-> Map (Hash HASH EraIndependentEbReferences) (IntMap ByteString)
imEbTxBytes InMemoryLeiosDb
state)
     in IntMap EbTxEntry -> IntSet
forall a. IntMap a -> IntSet
IntMap.keysSet IntMap EbTxEntry
entries IntSet -> IntSet -> Bool
`IntSet.isSubsetOf` IntMap ByteString -> IntSet
forall a. IntMap a -> IntSet
IntMap.keysSet IntMap ByteString
txBytesByOffset

imInsertTxs ::
  IOLike m =>
  StrictTVar m InMemoryLeiosDb ->
  StrictTChan m LeiosEbNotification ->
  LeiosPoint ->
  [(TxOffset, ByteString)] ->
  m CompletedEbs
imInsertTxs :: forall (m :: * -> *).
IOLike m =>
StrictTVar m InMemoryLeiosDb
-> StrictTChan m LeiosEbNotification
-> LeiosPoint
-> [(Int, ByteString)]
-> m [LeiosPoint]
imInsertTxs StrictTVar m InMemoryLeiosDb
stateVar StrictTChan m LeiosEbNotification
notificationChan LeiosPoint
point [(Int, ByteString)]
offBytes = STM m [LeiosPoint] -> m [LeiosPoint]
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m [LeiosPoint] -> m [LeiosPoint])
-> STM m [LeiosPoint] -> m [LeiosPoint]
forall a b. (a -> b) -> a -> b
$ do
  let ebHash :: Hash HASH EraIndependentEbReferences
ebHash = LeiosPoint -> Hash HASH EraIndependentEbReferences
pointEbHash LeiosPoint
point
  -- Mirrors the SQLite backend's guarded in-place fill: a fill only lands on a
  -- pre-allocated row, i.e. an offset the body declared, once, at the declared
  -- size. Anything else changes nothing.
  StrictTVar m InMemoryLeiosDb
-> (InMemoryLeiosDb -> InMemoryLeiosDb) -> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> (a -> a) -> STM m ()
modifyTVar StrictTVar m InMemoryLeiosDb
stateVar ((InMemoryLeiosDb -> InMemoryLeiosDb) -> STM m ())
-> (InMemoryLeiosDb -> InMemoryLeiosDb) -> STM m ()
forall a b. (a -> b) -> a -> b
$ \InMemoryLeiosDb
s ->
    let declared :: IntMap EbTxEntry
declared = IntMap EbTxEntry
-> Hash HASH EraIndependentEbReferences
-> Map (Hash HASH EraIndependentEbReferences) (IntMap EbTxEntry)
-> IntMap EbTxEntry
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault IntMap EbTxEntry
forall a. IntMap a
IntMap.empty Hash HASH EraIndependentEbReferences
ebHash (InMemoryLeiosDb
-> Map (Hash HASH EraIndependentEbReferences) (IntMap EbTxEntry)
imEbBodies InMemoryLeiosDb
s)
        held :: IntMap ByteString
held = IntMap ByteString
-> Hash HASH EraIndependentEbReferences
-> Map (Hash HASH EraIndependentEbReferences) (IntMap ByteString)
-> IntMap ByteString
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault IntMap ByteString
forall a. IntMap a
IntMap.empty Hash HASH EraIndependentEbReferences
ebHash (InMemoryLeiosDb
-> Map (Hash HASH EraIndependentEbReferences) (IntMap ByteString)
imEbTxBytes InMemoryLeiosDb
s)
        accepted :: IntMap ByteString
accepted =
          [(Int, ByteString)] -> IntMap ByteString
forall a. [(Int, a)] -> IntMap a
IntMap.fromList
            [ (Int
off, ByteString
bytes)
            | (Int
off, ByteString
bytes) <- [(Int, ByteString)]
offBytes
            , Just EbTxEntry
e <- [Int -> IntMap EbTxEntry -> Maybe EbTxEntry
forall a. Int -> IntMap a -> Maybe a
IntMap.lookup Int
off IntMap EbTxEntry
declared]
            , Int -> BytesSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int
BS.length ByteString
bytes) BytesSize -> BytesSize -> Bool
forall a. Eq a => a -> a -> Bool
== EbTxEntry -> BytesSize
eteTxBytesSize EbTxEntry
e
            , Bool -> Bool
not (Int -> IntMap ByteString -> Bool
forall a. Int -> IntMap a -> Bool
IntMap.member Int
off IntMap ByteString
held)
            ]
     in if IntMap ByteString -> Bool
forall a. IntMap a -> Bool
IntMap.null IntMap ByteString
accepted
          then InMemoryLeiosDb
s
          else InMemoryLeiosDb
s{imEbTxBytes = Map.insertWith IntMap.union ebHash accepted (imEbTxBytes s)}
  state <- StrictTVar m InMemoryLeiosDb -> STM m InMemoryLeiosDb
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m InMemoryLeiosDb
stateVar
  -- Candidates: every point of THIS EB whose body has been downloaded and
  -- whose closure is now complete. Tx bytes are not shared among overlapping
  -- EBs, so no other hash can have been affected.
  --
  -- 'hashCompleteIn' does not depend on the point, so judge the closure once
  -- rather than once per downloaded point. A batch that does not complete the
  -- closure -- the common case while a multi-batch fetch is in flight -- then
  -- scans nothing, which keeps the growth of the 'imEbBodiesDownloaded' set
  -- from increasing the per-write cost.
  let candidates
        | InMemoryLeiosDb -> Hash HASH EraIndependentEbReferences -> Bool
hashCompleteIn InMemoryLeiosDb
state Hash HASH EraIndependentEbReferences
ebHash =
            [ LeiosPoint
p
            | LeiosPoint
p <- Set LeiosPoint -> [LeiosPoint]
forall a. Set a -> [a]
Set.toList (InMemoryLeiosDb -> Set LeiosPoint
imEbBodiesDownloaded InMemoryLeiosDb
state)
            , LeiosPoint -> Hash HASH EraIndependentEbReferences
pointEbHash LeiosPoint
p Hash HASH EraIndependentEbReferences
-> Hash HASH EraIndependentEbReferences -> Bool
forall a. Eq a => a -> a -> Bool
== Hash HASH EraIndependentEbReferences
ebHash
            ]
        | Bool
otherwise = []
      completed =
        (LeiosPoint -> Bool) -> [LeiosPoint] -> [LeiosPoint]
forall a. (a -> Bool) -> [a] -> [a]
filter
          (\LeiosPoint
p -> Bool -> Bool
not (LeiosPoint -> Set LeiosPoint -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member LeiosPoint
p (InMemoryLeiosDb -> Set LeiosPoint
imCompletedEbs InMemoryLeiosDb
state)))
          [LeiosPoint]
candidates
  modifyTVar stateVar $ \InMemoryLeiosDb
s ->
    InMemoryLeiosDb
s
      { imCompletedEbs =
          foldr Set.insert (imCompletedEbs s) completed
      }
  -- Emit a closure-completion notification for each newly-complete EB. The
  -- ChainDB subscribes to these to grow the acquired-EB-closures set it owns.
  forM_ completed $ \LeiosPoint
p ->
    StrictTChan m LeiosEbNotification
-> LeiosEbNotification -> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTChan m a -> a -> STM m ()
writeTChan StrictTChan m LeiosEbNotification
notificationChan (LeiosPoint -> LeiosEbNotification
AcquiredEbTxs LeiosPoint
p)
  pure completed

-- | Implements 'scanCompleteEbClosuresNotOlderThanSlot': the already-completed EBs
-- announced no older than the given slot.
--
-- Derived from 'imCompletedEbs': an EB's greatest announcer slot is no older
-- than @sinceSlot@ exactly when at least one of its completed points has a slot
-- @>= sinceSlot@, so we collect (and dedupe) the hashes of those points. This
-- is precise across all of an EB's announcer slots, as in the SQLite backend.
imScanCompleteEbClosuresSince ::
  IOLike m => StrictTVar m InMemoryLeiosDb -> SlotNo -> m [LeiosPoint]
imScanCompleteEbClosuresSince :: forall (m :: * -> *).
IOLike m =>
StrictTVar m InMemoryLeiosDb -> SlotNo -> m [LeiosPoint]
imScanCompleteEbClosuresSince StrictTVar m InMemoryLeiosDb
stateVar SlotNo
sinceSlot = STM m [LeiosPoint] -> m [LeiosPoint]
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m [LeiosPoint] -> m [LeiosPoint])
-> STM m [LeiosPoint] -> m [LeiosPoint]
forall a b. (a -> b) -> a -> b
$ do
  s <- StrictTVar m InMemoryLeiosDb -> STM m InMemoryLeiosDb
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m InMemoryLeiosDb
stateVar
  pure
    [ p
    | p <- Set.toList (imCompletedEbs s)
    , pointSlotNo p >= sinceSlot
    ]

-- | This falls back to the immutable copy only when 'imEbBodies' lacks the
-- body, even if that body's closure is incomplete. The SQLite implementation
-- has the same shortcoming (see the TODO on @sqlBatchRetrieveTxs@).
imBatchRetrieveTxs ::
  IOLike m =>
  StrictTVar m InMemoryLeiosDb ->
  EndorserBlockHash ->
  [Int] ->
  m [(Int, TxHash, Maybe ByteString)]
imBatchRetrieveTxs :: forall (m :: * -> *).
IOLike m =>
StrictTVar m InMemoryLeiosDb
-> Hash HASH EraIndependentEbReferences
-> [Int]
-> m [(Int, TxHash, Maybe ByteString)]
imBatchRetrieveTxs StrictTVar m InMemoryLeiosDb
stateVar Hash HASH EraIndependentEbReferences
ebHash [Int]
offsets = STM m [(Int, TxHash, Maybe ByteString)]
-> m [(Int, TxHash, Maybe ByteString)]
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m [(Int, TxHash, Maybe ByteString)]
 -> m [(Int, TxHash, Maybe ByteString)])
-> STM m [(Int, TxHash, Maybe ByteString)]
-> m [(Int, TxHash, Maybe ByteString)]
forall a b. (a -> b) -> a -> b
$ do
  state <- StrictTVar m InMemoryLeiosDb -> STM m InMemoryLeiosDb
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m InMemoryLeiosDb
stateVar
  pure $ case Map.lookup ebHash (imEbBodies state) of
    Just IntMap EbTxEntry
offsetMap -> IntMap EbTxEntry
-> IntMap ByteString -> [(Int, TxHash, Maybe ByteString)]
forall {a}.
IntMap EbTxEntry -> IntMap a -> [(Int, TxHash, Maybe a)]
retrieve IntMap EbTxEntry
offsetMap (IntMap ByteString
-> Hash HASH EraIndependentEbReferences
-> Map (Hash HASH EraIndependentEbReferences) (IntMap ByteString)
-> IntMap ByteString
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault IntMap ByteString
forall a. IntMap a
IntMap.empty Hash HASH EraIndependentEbReferences
ebHash (InMemoryLeiosDb
-> Map (Hash HASH EraIndependentEbReferences) (IntMap ByteString)
imEbTxBytes InMemoryLeiosDb
state))
    Maybe (IntMap EbTxEntry)
Nothing -> case Hash HASH EraIndependentEbReferences
-> Map (Hash HASH EraIndependentEbReferences) (IntMap EbTxEntry)
-> Maybe (IntMap EbTxEntry)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Hash HASH EraIndependentEbReferences
ebHash (InMemoryLeiosDb
-> Map (Hash HASH EraIndependentEbReferences) (IntMap EbTxEntry)
imImmutableEbBodies InMemoryLeiosDb
state) of
      Just IntMap EbTxEntry
offsetMap -> IntMap EbTxEntry
-> IntMap ByteString -> [(Int, TxHash, Maybe ByteString)]
forall {a}.
IntMap EbTxEntry -> IntMap a -> [(Int, TxHash, Maybe a)]
retrieve IntMap EbTxEntry
offsetMap (IntMap ByteString
-> Hash HASH EraIndependentEbReferences
-> Map (Hash HASH EraIndependentEbReferences) (IntMap ByteString)
-> IntMap ByteString
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault IntMap ByteString
forall a. IntMap a
IntMap.empty Hash HASH EraIndependentEbReferences
ebHash (InMemoryLeiosDb
-> Map (Hash HASH EraIndependentEbReferences) (IntMap ByteString)
imImmutableEbTxBytes InMemoryLeiosDb
state))
      Maybe (IntMap EbTxEntry)
Nothing -> []
 where
  retrieve :: IntMap EbTxEntry -> IntMap a -> [(Int, TxHash, Maybe a)]
retrieve IntMap EbTxEntry
offsetMap IntMap a
txBytesByOffset =
    [ (Int
offset, EbTxEntry -> TxHash
eteTxHash EbTxEntry
entry, Int -> IntMap a -> Maybe a
forall a. Int -> IntMap a -> Maybe a
IntMap.lookup Int
offset IntMap a
txBytesByOffset)
    | Int
offset <- [Int]
offsets
    , Just EbTxEntry
entry <- [Int -> IntMap EbTxEntry -> Maybe EbTxEntry
forall a. Int -> IntMap a -> Maybe a
IntMap.lookup Int
offset IntMap EbTxEntry
offsetMap]
    ]

imLookupEbClosure ::
  IOLike m =>
  StrictTVar m InMemoryLeiosDb -> EndorserBlockHash -> m (Maybe [(TxHash, ByteString)])
imLookupEbClosure :: forall (m :: * -> *).
IOLike m =>
StrictTVar m InMemoryLeiosDb
-> Hash HASH EraIndependentEbReferences
-> m (Maybe [(TxHash, ByteString)])
imLookupEbClosure StrictTVar m InMemoryLeiosDb
stateVar Hash HASH EraIndependentEbReferences
ebHash = STM m (Maybe [(TxHash, ByteString)])
-> m (Maybe [(TxHash, ByteString)])
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (Maybe [(TxHash, ByteString)])
 -> m (Maybe [(TxHash, ByteString)]))
-> STM m (Maybe [(TxHash, ByteString)])
-> m (Maybe [(TxHash, ByteString)])
forall a b. (a -> b) -> a -> b
$ do
  state <- StrictTVar m InMemoryLeiosDb -> STM m InMemoryLeiosDb
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m InMemoryLeiosDb
stateVar
  pure $ case Map.lookup ebHash (imEbBodies state) >>= closureWith (volatileTxBytes state ebHash) of
    Just [(TxHash, ByteString)]
closure -> [(TxHash, ByteString)] -> Maybe [(TxHash, ByteString)]
forall a. a -> Maybe a
Just [(TxHash, ByteString)]
closure
    Maybe [(TxHash, ByteString)]
Nothing ->
      Hash HASH EraIndependentEbReferences
-> Map (Hash HASH EraIndependentEbReferences) (IntMap EbTxEntry)
-> Maybe (IntMap EbTxEntry)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Hash HASH EraIndependentEbReferences
ebHash (InMemoryLeiosDb
-> Map (Hash HASH EraIndependentEbReferences) (IntMap EbTxEntry)
imImmutableEbBodies InMemoryLeiosDb
state)
        Maybe (IntMap EbTxEntry)
-> (IntMap EbTxEntry -> Maybe [(TxHash, ByteString)])
-> Maybe [(TxHash, ByteString)]
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IntMap ByteString
-> IntMap EbTxEntry -> Maybe [(TxHash, ByteString)]
closureWith (IntMap ByteString
-> Hash HASH EraIndependentEbReferences
-> Map (Hash HASH EraIndependentEbReferences) (IntMap ByteString)
-> IntMap ByteString
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault IntMap ByteString
forall a. IntMap a
IntMap.empty Hash HASH EraIndependentEbReferences
ebHash (InMemoryLeiosDb
-> Map (Hash HASH EraIndependentEbReferences) (IntMap ByteString)
imImmutableEbTxBytes InMemoryLeiosDb
state))

-- | The EB's tx bytes by offset, from 'imEbTxBytes'.
volatileTxBytes :: InMemoryLeiosDb -> EndorserBlockHash -> IntMap ByteString
volatileTxBytes :: InMemoryLeiosDb
-> Hash HASH EraIndependentEbReferences -> IntMap ByteString
volatileTxBytes InMemoryLeiosDb
s Hash HASH EraIndependentEbReferences
ebHash = IntMap ByteString
-> Hash HASH EraIndependentEbReferences
-> Map (Hash HASH EraIndependentEbReferences) (IntMap ByteString)
-> IntMap ByteString
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault IntMap ByteString
forall a. IntMap a
IntMap.empty Hash HASH EraIndependentEbReferences
ebHash (InMemoryLeiosDb
-> Map (Hash HASH EraIndependentEbReferences) (IntMap ByteString)
imEbTxBytes InMemoryLeiosDb
s)

-- | The body's closure, if the tx bytes hold each of its transactions.
closureWith :: IntMap ByteString -> IntMap EbTxEntry -> Maybe [(TxHash, ByteString)]
closureWith :: IntMap ByteString
-> IntMap EbTxEntry -> Maybe [(TxHash, ByteString)]
closureWith IntMap ByteString
txBytesByOffset IntMap EbTxEntry
entries =
  ((Int, EbTxEntry) -> Maybe (TxHash, ByteString))
-> [(Int, EbTxEntry)] -> Maybe [(TxHash, ByteString)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse
    (\(Int
offset, EbTxEntry
e) -> (,) (EbTxEntry -> TxHash
eteTxHash EbTxEntry
e) (ByteString -> (TxHash, ByteString))
-> Maybe ByteString -> Maybe (TxHash, ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> IntMap ByteString -> Maybe ByteString
forall a. Int -> IntMap a -> Maybe a
IntMap.lookup Int
offset IntMap ByteString
txBytesByOffset)
    (IntMap EbTxEntry -> [(Int, EbTxEntry)]
forall a. IntMap a -> [(Int, a)]
IntMap.toAscList IntMap EbTxEntry
entries)