{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE NamedFieldPuns      #-}
{-# LANGUAGE ScopedTypeVariables #-}

-- | Pure side of the Mempool implementation.
--
-- Operations are performed in a pure style returning data types that model
-- the control flow through the operation and can then be interpreted to perform
-- the actual STM/IO operations.

module Ouroboros.Consensus.Mempool.Impl.Pure (
    -- * Mempool
    implTryAddTxs
  , pureGetSnapshotFor
  , pureRemoveTxs
  , pureSyncWithLedger
  , runRemoveTxs
  , runSyncWithLedger
    -- * MempoolSnapshot
  , implSnapshotFromIS
  ) where

import           Control.Exception (assert)
import           Data.Maybe (isJust, isNothing)
import qualified Data.Set as Set

import           Control.Monad (join)
import           Control.Tracer
import           Ouroboros.Consensus.HeaderValidation
import           Ouroboros.Consensus.Ledger.Abstract
import           Ouroboros.Consensus.Ledger.SupportsMempool
import           Ouroboros.Consensus.Mempool.API
import           Ouroboros.Consensus.Mempool.Impl.Types
import           Ouroboros.Consensus.Mempool.TxSeq (TicketNo, TxTicket (..),
                     zeroTicketNo)
import qualified Ouroboros.Consensus.Mempool.TxSeq as TxSeq
import           Ouroboros.Consensus.Util (whenJust)
import           Ouroboros.Consensus.Util.IOLike

{-------------------------------------------------------------------------------
  Mempool Implementation
-------------------------------------------------------------------------------}

-- | Result of trying to add a transaction to the mempool.
data TryAddTxs blk =
    -- | No space is left in the mempool and no more transactions could be
    -- added.
    NoSpaceLeft
    -- | A transaction was processed.
  | TryAddTxs
      (Maybe (InternalState blk))
      -- ^ If the transaction was accepted, the new state that can be written to
      -- the TVar.
      (MempoolAddTxResult blk)
      -- ^ The result of trying to add the transaction to the mempool.
      (TraceEventMempool blk)
      -- ^ The event emitted by the operation.

-- | Add a list of transactions (oldest to newest) by interpreting a 'TryAddTxs'
-- from 'pureTryAddTxs'.
--
-- This function returns two lists: the transactions that were added or
-- rejected, and the transactions that could not yet be added, because the
-- Mempool capacity was reached. See 'addTxs' for a function that blocks in
-- case the Mempool capacity is reached.
--
-- Transactions are added one by one, updating the Mempool each time one was
-- added successfully.
--
-- See the necessary invariants on the Haddock for 'API.tryAddTxs'.
--
-- This function does not sync the Mempool contents with the ledger state in
-- case the latter changes, it relies on the background thread to do that.
--
-- INVARIANT: The code needs that read and writes on the state are coupled
-- together or inconsistencies will arise. To ensure that STM transactions are
-- short, each iteration of the helper function is a separate STM transaction.
implTryAddTxs
  :: forall m blk.
     ( MonadSTM m
     , LedgerSupportsMempool blk
     , HasTxId (GenTx blk)
     )
  => StrictTVar m (InternalState blk)
     -- ^ The InternalState TVar.
  -> LedgerConfig blk
     -- ^ The configuration of the ledger.
  -> (GenTx blk -> TxSizeInBytes)
     -- ^ The function to calculate the size of a
     -- transaction.
  -> Tracer m (TraceEventMempool blk)
     -- ^ The tracer.
  -> WhetherToIntervene
  -> [GenTx blk]
     -- ^ The list of transactions to add to the mempool.
  -> m ([MempoolAddTxResult blk], [GenTx blk])
implTryAddTxs :: StrictTVar m (InternalState blk)
-> LedgerConfig blk
-> (GenTx blk -> TxSizeInBytes)
-> Tracer m (TraceEventMempool blk)
-> WhetherToIntervene
-> [GenTx blk]
-> m ([MempoolAddTxResult blk], [GenTx blk])
implTryAddTxs StrictTVar m (InternalState blk)
istate LedgerConfig blk
cfg GenTx blk -> TxSizeInBytes
txSize Tracer m (TraceEventMempool blk)
trcr WhetherToIntervene
wti =
    [MempoolAddTxResult blk]
-> [GenTx blk] -> m ([MempoolAddTxResult blk], [GenTx blk])
go []
  where
    go :: [MempoolAddTxResult blk]
-> [GenTx blk] -> m ([MempoolAddTxResult blk], [GenTx blk])
go [MempoolAddTxResult blk]
acc = \case
      []     -> ([MempoolAddTxResult blk], [GenTx blk])
-> m ([MempoolAddTxResult blk], [GenTx blk])
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([MempoolAddTxResult blk] -> [MempoolAddTxResult blk]
forall a. [a] -> [a]
reverse [MempoolAddTxResult blk]
acc, [])
      GenTx blk
tx:[GenTx blk]
txs -> m (m ([MempoolAddTxResult blk], [GenTx blk]))
-> m ([MempoolAddTxResult blk], [GenTx blk])
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (m (m ([MempoolAddTxResult blk], [GenTx blk]))
 -> m ([MempoolAddTxResult blk], [GenTx blk]))
-> m (m ([MempoolAddTxResult blk], [GenTx blk]))
-> m ([MempoolAddTxResult blk], [GenTx blk])
forall a b. (a -> b) -> a -> b
$ STM m (m ([MempoolAddTxResult blk], [GenTx blk]))
-> m (m ([MempoolAddTxResult blk], [GenTx blk]))
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (m ([MempoolAddTxResult blk], [GenTx blk]))
 -> m (m ([MempoolAddTxResult blk], [GenTx blk])))
-> STM m (m ([MempoolAddTxResult blk], [GenTx blk]))
-> m (m ([MempoolAddTxResult blk], [GenTx blk]))
forall a b. (a -> b) -> a -> b
$ do
        InternalState blk
is <- StrictTVar m (InternalState blk) -> STM m (InternalState blk)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (InternalState blk)
istate
        case LedgerConfig blk
-> (GenTx blk -> TxSizeInBytes)
-> WhetherToIntervene
-> GenTx blk
-> InternalState blk
-> TryAddTxs blk
forall blk.
(LedgerSupportsMempool blk, HasTxId (GenTx blk)) =>
LedgerCfg (LedgerState blk)
-> (GenTx blk -> TxSizeInBytes)
-> WhetherToIntervene
-> GenTx blk
-> InternalState blk
-> TryAddTxs blk
pureTryAddTxs LedgerConfig blk
cfg GenTx blk -> TxSizeInBytes
txSize WhetherToIntervene
wti GenTx blk
tx InternalState blk
is of
          TryAddTxs blk
NoSpaceLeft             -> m ([MempoolAddTxResult blk], [GenTx blk])
-> STM m (m ([MempoolAddTxResult blk], [GenTx blk]))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (m ([MempoolAddTxResult blk], [GenTx blk])
 -> STM m (m ([MempoolAddTxResult blk], [GenTx blk])))
-> m ([MempoolAddTxResult blk], [GenTx blk])
-> STM m (m ([MempoolAddTxResult blk], [GenTx blk]))
forall a b. (a -> b) -> a -> b
$ ([MempoolAddTxResult blk], [GenTx blk])
-> m ([MempoolAddTxResult blk], [GenTx blk])
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([MempoolAddTxResult blk] -> [MempoolAddTxResult blk]
forall a. [a] -> [a]
reverse [MempoolAddTxResult blk]
acc, GenTx blk
txGenTx blk -> [GenTx blk] -> [GenTx blk]
forall a. a -> [a] -> [a]
:[GenTx blk]
txs)
          TryAddTxs Maybe (InternalState blk)
is' MempoolAddTxResult blk
result TraceEventMempool blk
ev -> do
            Maybe (InternalState blk)
-> (InternalState blk -> STM m ()) -> STM m ()
forall (f :: * -> *) a.
Applicative f =>
Maybe a -> (a -> f ()) -> f ()
whenJust Maybe (InternalState blk)
is' (StrictTVar m (InternalState blk) -> InternalState blk -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m (InternalState blk)
istate)
            m ([MempoolAddTxResult blk], [GenTx blk])
-> STM m (m ([MempoolAddTxResult blk], [GenTx blk]))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (m ([MempoolAddTxResult blk], [GenTx blk])
 -> STM m (m ([MempoolAddTxResult blk], [GenTx blk])))
-> m ([MempoolAddTxResult blk], [GenTx blk])
-> STM m (m ([MempoolAddTxResult blk], [GenTx blk]))
forall a b. (a -> b) -> a -> b
$ do
              Tracer m (TraceEventMempool blk) -> TraceEventMempool blk -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (TraceEventMempool blk)
trcr TraceEventMempool blk
ev
              [MempoolAddTxResult blk]
-> [GenTx blk] -> m ([MempoolAddTxResult blk], [GenTx blk])
go (MempoolAddTxResult blk
resultMempoolAddTxResult blk
-> [MempoolAddTxResult blk] -> [MempoolAddTxResult blk]
forall a. a -> [a] -> [a]
:[MempoolAddTxResult blk]
acc) [GenTx blk]
txs

-- | Craft a 'TryAddTxs' value containing the resulting state if applicable, the
-- tracing event and the result of adding this transaction. See the
-- documentation of 'implTryAddTxs' for some more context.
pureTryAddTxs
  :: ( LedgerSupportsMempool blk
     , HasTxId (GenTx blk)
     )
  => LedgerCfg (LedgerState blk)
     -- ^ The ledger configuration.
  -> (GenTx blk -> TxSizeInBytes)
     -- ^ The function to claculate the size of a transaction.
  -> WhetherToIntervene
  -> GenTx blk
     -- ^ The transaction to add to the mempool.
  -> InternalState blk
     -- ^ The current internal state of the mempool.
  -> TryAddTxs blk
pureTryAddTxs :: LedgerCfg (LedgerState blk)
-> (GenTx blk -> TxSizeInBytes)
-> WhetherToIntervene
-> GenTx blk
-> InternalState blk
-> TryAddTxs blk
pureTryAddTxs LedgerCfg (LedgerState blk)
cfg GenTx blk -> TxSizeInBytes
txSize WhetherToIntervene
wti GenTx blk
tx InternalState blk
is
  | let size :: TxSizeInBytes
size    = GenTx blk -> TxSizeInBytes
txSize GenTx blk
tx
        curSize :: TxSizeInBytes
curSize = MempoolSize -> TxSizeInBytes
msNumBytes  (MempoolSize -> TxSizeInBytes) -> MempoolSize -> TxSizeInBytes
forall a b. (a -> b) -> a -> b
$ InternalState blk -> MempoolSize
forall blk. InternalState blk -> MempoolSize
isMempoolSize InternalState blk
is
  , TxSizeInBytes
curSize TxSizeInBytes -> TxSizeInBytes -> TxSizeInBytes
forall a. Num a => a -> a -> a
+ TxSizeInBytes
size TxSizeInBytes -> TxSizeInBytes -> Bool
forall a. Ord a => a -> a -> Bool
> MempoolCapacityBytes -> TxSizeInBytes
getMempoolCapacityBytes (InternalState blk -> MempoolCapacityBytes
forall blk. InternalState blk -> MempoolCapacityBytes
isCapacity InternalState blk
is)
  = TryAddTxs blk
forall blk. TryAddTxs blk
NoSpaceLeft
  | Bool
otherwise
  = case Either (ApplyTxErr blk) (Validated (GenTx blk))
eVtx of
      -- We only extended the ValidationResult with a single transaction
      -- ('tx'). So if it's not in 'vrInvalid', it must be in 'vrNewValid'.
      Right Validated (GenTx blk)
vtx ->
        Bool -> TryAddTxs blk -> TryAddTxs blk
forall a. HasCallStack => Bool -> a -> a
assert (Maybe (Validated (GenTx blk)) -> Bool
forall a. Maybe a -> Bool
isJust (ValidationResult (GenTx blk) blk -> Maybe (Validated (GenTx blk))
forall invalidTx blk.
ValidationResult invalidTx blk -> Maybe (Validated (GenTx blk))
vrNewValid ValidationResult (GenTx blk) blk
vr)) (TryAddTxs blk -> TryAddTxs blk) -> TryAddTxs blk -> TryAddTxs blk
forall a b. (a -> b) -> a -> b
$
          Maybe (InternalState blk)
-> MempoolAddTxResult blk -> TraceEventMempool blk -> TryAddTxs blk
forall blk.
Maybe (InternalState blk)
-> MempoolAddTxResult blk -> TraceEventMempool blk -> TryAddTxs blk
TryAddTxs
            (InternalState blk -> Maybe (InternalState blk)
forall a. a -> Maybe a
Just InternalState blk
is')
            (Validated (GenTx blk) -> MempoolAddTxResult blk
forall blk. Validated (GenTx blk) -> MempoolAddTxResult blk
MempoolTxAdded Validated (GenTx blk)
vtx)
            (Validated (GenTx blk)
-> MempoolSize -> MempoolSize -> TraceEventMempool blk
forall blk.
Validated (GenTx blk)
-> MempoolSize -> MempoolSize -> TraceEventMempool blk
TraceMempoolAddedTx
              Validated (GenTx blk)
vtx
              (InternalState blk -> MempoolSize
forall blk. InternalState blk -> MempoolSize
isMempoolSize InternalState blk
is)
              (InternalState blk -> MempoolSize
forall blk. InternalState blk -> MempoolSize
isMempoolSize InternalState blk
is')
            )
      Left ApplyTxErr blk
err ->
        Bool -> TryAddTxs blk -> TryAddTxs blk
forall a. HasCallStack => Bool -> a -> a
assert (Maybe (Validated (GenTx blk)) -> Bool
forall a. Maybe a -> Bool
isNothing (ValidationResult (GenTx blk) blk -> Maybe (Validated (GenTx blk))
forall invalidTx blk.
ValidationResult invalidTx blk -> Maybe (Validated (GenTx blk))
vrNewValid ValidationResult (GenTx blk) blk
vr))  (TryAddTxs blk -> TryAddTxs blk) -> TryAddTxs blk -> TryAddTxs blk
forall a b. (a -> b) -> a -> b
$
          Bool -> TryAddTxs blk -> TryAddTxs blk
forall a. HasCallStack => Bool -> a -> a
assert ([(GenTx blk, ApplyTxErr blk)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (ValidationResult (GenTx blk) blk -> [(GenTx blk, ApplyTxErr blk)]
forall invalidTx blk.
ValidationResult invalidTx blk -> [(invalidTx, ApplyTxErr blk)]
vrInvalid ValidationResult (GenTx blk) blk
vr) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1) (TryAddTxs blk -> TryAddTxs blk) -> TryAddTxs blk -> TryAddTxs blk
forall a b. (a -> b) -> a -> b
$
            Maybe (InternalState blk)
-> MempoolAddTxResult blk -> TraceEventMempool blk -> TryAddTxs blk
forall blk.
Maybe (InternalState blk)
-> MempoolAddTxResult blk -> TraceEventMempool blk -> TryAddTxs blk
TryAddTxs
              Maybe (InternalState blk)
forall a. Maybe a
Nothing
              (GenTx blk -> ApplyTxErr blk -> MempoolAddTxResult blk
forall blk. GenTx blk -> ApplyTxErr blk -> MempoolAddTxResult blk
MempoolTxRejected GenTx blk
tx ApplyTxErr blk
err)
              (GenTx blk -> ApplyTxErr blk -> MempoolSize -> TraceEventMempool blk
forall blk.
GenTx blk -> ApplyTxErr blk -> MempoolSize -> TraceEventMempool blk
TraceMempoolRejectedTx
               GenTx blk
tx
               ApplyTxErr blk
err
               (InternalState blk -> MempoolSize
forall blk. InternalState blk -> MempoolSize
isMempoolSize InternalState blk
is)
              )
    where
      (Either (ApplyTxErr blk) (Validated (GenTx blk))
eVtx, ValidationResult (GenTx blk) blk
vr) = LedgerCfg (LedgerState blk)
-> (GenTx blk -> TxSizeInBytes)
-> WhetherToIntervene
-> GenTx blk
-> ValidationResult (GenTx blk) blk
-> (Either (ApplyTxErr blk) (Validated (GenTx blk)),
    ValidationResult (GenTx blk) blk)
forall blk.
(LedgerSupportsMempool blk, HasTxId (GenTx blk)) =>
LedgerConfig blk
-> (GenTx blk -> TxSizeInBytes)
-> WhetherToIntervene
-> GenTx blk
-> ValidationResult (GenTx blk) blk
-> (Either (ApplyTxErr blk) (Validated (GenTx blk)),
    ValidationResult (GenTx blk) blk)
extendVRNew LedgerCfg (LedgerState blk)
cfg GenTx blk -> TxSizeInBytes
txSize WhetherToIntervene
wti GenTx blk
tx (ValidationResult (GenTx blk) blk
 -> (Either (ApplyTxErr blk) (Validated (GenTx blk)),
     ValidationResult (GenTx blk) blk))
-> ValidationResult (GenTx blk) blk
-> (Either (ApplyTxErr blk) (Validated (GenTx blk)),
    ValidationResult (GenTx blk) blk)
forall a b. (a -> b) -> a -> b
$ InternalState blk -> ValidationResult (GenTx blk) blk
forall blk invalidTx.
InternalState blk -> ValidationResult invalidTx blk
validationResultFromIS InternalState blk
is
      is' :: InternalState blk
is'        = ValidationResult (GenTx blk) blk -> InternalState blk
forall invalidTx blk.
ValidationResult invalidTx blk -> InternalState blk
internalStateFromVR ValidationResult (GenTx blk) blk
vr

-- | A datatype containing the state resulting after removing the requested
-- transactions from the mempool and maybe a message to be traced while removing
-- them.
data RemoveTxs blk =
    WriteRemoveTxs (InternalState blk) (Maybe (TraceEventMempool blk))

-- | Intepret a 'RemoveTxs' with the resulting values produced by manually
-- removing the transactions given to 'pureRemoveTxs' from the mempool.
runRemoveTxs
  :: forall m blk. IOLike m
  => StrictTVar m (InternalState blk)
  -> RemoveTxs blk
  -> STM m (Maybe (TraceEventMempool blk))
runRemoveTxs :: StrictTVar m (InternalState blk)
-> RemoveTxs blk -> STM m (Maybe (TraceEventMempool blk))
runRemoveTxs StrictTVar m (InternalState blk)
stateVar (WriteRemoveTxs InternalState blk
is Maybe (TraceEventMempool blk)
t) = do
    StrictTVar m (InternalState blk) -> InternalState blk -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m (InternalState blk)
stateVar InternalState blk
is
    Maybe (TraceEventMempool blk)
-> STM m (Maybe (TraceEventMempool blk))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (TraceEventMempool blk)
t

-- | Craft a 'RemoveTxs' that manually removes the given transactions from the
-- mempool, returning inside it an updated InternalState.
pureRemoveTxs
  :: ( LedgerSupportsMempool blk
     , HasTxId (GenTx blk)
     , ValidateEnvelope blk
     )
  => LedgerConfig blk
  -> MempoolCapacityBytesOverride
  -> [GenTxId blk]
  -> InternalState blk
  -> LedgerState blk
  -> RemoveTxs blk
pureRemoveTxs :: LedgerConfig blk
-> MempoolCapacityBytesOverride
-> [GenTxId blk]
-> InternalState blk
-> LedgerState blk
-> RemoveTxs blk
pureRemoveTxs LedgerConfig blk
cfg MempoolCapacityBytesOverride
capacityOverride [GenTxId blk]
txIds IS { TxSeq (Validated (GenTx blk))
isTxs :: forall blk. InternalState blk -> TxSeq (Validated (GenTx blk))
isTxs :: TxSeq (Validated (GenTx blk))
isTxs, TicketNo
isLastTicketNo :: forall blk. InternalState blk -> TicketNo
isLastTicketNo :: TicketNo
isLastTicketNo } LedgerState blk
lstate =
    -- Filtering is O(n), but this function will rarely be used, as it is an
    -- escape hatch when there's an inconsistency between the ledger and the
    -- mempool.
    let toRemove :: Set (GenTxId blk)
toRemove       = [GenTxId blk] -> Set (GenTxId blk)
forall a. Ord a => [a] -> Set a
Set.fromList [GenTxId blk]
txIds
        txTickets' :: [TxTicket (Validated (GenTx blk))]
txTickets'     = (TxTicket (Validated (GenTx blk)) -> Bool)
-> [TxTicket (Validated (GenTx blk))]
-> [TxTicket (Validated (GenTx blk))]
forall a. (a -> Bool) -> [a] -> [a]
filter
                           (   (GenTxId blk -> Set (GenTxId blk) -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` Set (GenTxId blk)
toRemove)
                             (GenTxId blk -> Bool)
-> (TxTicket (Validated (GenTx blk)) -> GenTxId blk)
-> TxTicket (Validated (GenTx blk))
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenTx blk -> GenTxId blk
forall tx. HasTxId tx => tx -> TxId tx
txId
                             (GenTx blk -> GenTxId blk)
-> (TxTicket (Validated (GenTx blk)) -> GenTx blk)
-> TxTicket (Validated (GenTx blk))
-> GenTxId blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Validated (GenTx blk) -> GenTx blk
forall blk.
LedgerSupportsMempool blk =>
Validated (GenTx blk) -> GenTx blk
txForgetValidated
                             (Validated (GenTx blk) -> GenTx blk)
-> (TxTicket (Validated (GenTx blk)) -> Validated (GenTx blk))
-> TxTicket (Validated (GenTx blk))
-> GenTx blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxTicket (Validated (GenTx blk)) -> Validated (GenTx blk)
forall tx. TxTicket tx -> tx
txTicketTx
                           )
                           (TxSeq (Validated (GenTx blk)) -> [TxTicket (Validated (GenTx blk))]
forall tx. TxSeq tx -> [TxTicket tx]
TxSeq.toList TxSeq (Validated (GenTx blk))
isTxs)
        (SlotNo
slot, TickedLedgerState blk
ticked) = LedgerConfig blk
-> ForgeLedgerState blk -> (SlotNo, TickedLedgerState blk)
forall blk.
(UpdateLedger blk, ValidateEnvelope blk) =>
LedgerConfig blk
-> ForgeLedgerState blk -> (SlotNo, TickedLedgerState blk)
tickLedgerState LedgerConfig blk
cfg (LedgerState blk -> ForgeLedgerState blk
forall blk. LedgerState blk -> ForgeLedgerState blk
ForgeInUnknownSlot LedgerState blk
lstate)
        vr :: ValidationResult (Validated (GenTx blk)) blk
vr             = MempoolCapacityBytesOverride
-> LedgerConfig blk
-> SlotNo
-> TickedLedgerState blk
-> TicketNo
-> [TxTicket (Validated (GenTx blk))]
-> ValidationResult (Validated (GenTx blk)) blk
forall blk.
(LedgerSupportsMempool blk, HasTxId (GenTx blk)) =>
MempoolCapacityBytesOverride
-> LedgerConfig blk
-> SlotNo
-> TickedLedgerState blk
-> TicketNo
-> [TxTicket (Validated (GenTx blk))]
-> ValidationResult (Validated (GenTx blk)) blk
revalidateTxsFor
                           MempoolCapacityBytesOverride
capacityOverride
                           LedgerConfig blk
cfg
                           SlotNo
slot
                           TickedLedgerState blk
ticked
                           TicketNo
isLastTicketNo
                           [TxTicket (Validated (GenTx blk))]
txTickets'
        is' :: InternalState blk
is'            = ValidationResult (Validated (GenTx blk)) blk -> InternalState blk
forall invalidTx blk.
ValidationResult invalidTx blk -> InternalState blk
internalStateFromVR ValidationResult (Validated (GenTx blk)) blk
vr
        needsTrace :: Maybe (TraceEventMempool blk)
needsTrace     = if [GenTxId blk] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GenTxId blk]
txIds
                         then
                           Maybe (TraceEventMempool blk)
forall a. Maybe a
Nothing
                         else
                           TraceEventMempool blk -> Maybe (TraceEventMempool blk)
forall a. a -> Maybe a
Just (TraceEventMempool blk -> Maybe (TraceEventMempool blk))
-> TraceEventMempool blk -> Maybe (TraceEventMempool blk)
forall a b. (a -> b) -> a -> b
$ [GenTxId blk]
-> [Validated (GenTx blk)] -> MempoolSize -> TraceEventMempool blk
forall blk.
[GenTxId blk]
-> [Validated (GenTx blk)] -> MempoolSize -> TraceEventMempool blk
TraceMempoolManuallyRemovedTxs
                             [GenTxId blk]
txIds
                             (((Validated (GenTx blk), ApplyTxErr blk) -> Validated (GenTx blk))
-> [(Validated (GenTx blk), ApplyTxErr blk)]
-> [Validated (GenTx blk)]
forall a b. (a -> b) -> [a] -> [b]
map (Validated (GenTx blk), ApplyTxErr blk) -> Validated (GenTx blk)
forall a b. (a, b) -> a
fst (ValidationResult (Validated (GenTx blk)) blk
-> [(Validated (GenTx blk), ApplyTxErr blk)]
forall invalidTx blk.
ValidationResult invalidTx blk -> [(invalidTx, ApplyTxErr blk)]
vrInvalid ValidationResult (Validated (GenTx blk)) blk
vr))
                             (InternalState blk -> MempoolSize
forall blk. InternalState blk -> MempoolSize
isMempoolSize InternalState blk
is')
    in InternalState blk -> Maybe (TraceEventMempool blk) -> RemoveTxs blk
forall blk.
InternalState blk -> Maybe (TraceEventMempool blk) -> RemoveTxs blk
WriteRemoveTxs InternalState blk
is' Maybe (TraceEventMempool blk)
needsTrace

-- | A datatype containing the new state produced by syncing with the Ledger, a
-- snapshot of that mempool state and, if needed, a tracing message.
data SyncWithLedger blk =
    NewSyncedState (InternalState blk)
                   (MempoolSnapshot blk TicketNo)
                   (Maybe (TraceEventMempool blk))

-- | Intepret a 'SyncWithLedger' value produced by syncing the transactions in
--  the mempool with the current ledger state of the 'ChainDB'.
--
-- The transactions that exist within the mempool will be revalidated
-- against the current ledger state. Transactions which are found to be
-- invalid with respect to the current ledger state, will be dropped
-- from the mempool, whereas valid transactions will remain.
--
-- n.b. in our current implementation, when one opens a mempool, we
-- spawn a thread which performs this action whenever the 'ChainDB' tip
-- point changes.
runSyncWithLedger
  :: forall m blk. IOLike m
  => StrictTVar m (InternalState blk)
  -> SyncWithLedger blk
  -> STM m (Maybe (TraceEventMempool blk), MempoolSnapshot blk TicketNo)
runSyncWithLedger :: StrictTVar m (InternalState blk)
-> SyncWithLedger blk
-> STM
     m (Maybe (TraceEventMempool blk), MempoolSnapshot blk TicketNo)
runSyncWithLedger StrictTVar m (InternalState blk)
stateVar (NewSyncedState InternalState blk
is MempoolSnapshot blk TicketNo
msp Maybe (TraceEventMempool blk)
mTrace) = do
    StrictTVar m (InternalState blk) -> InternalState blk -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m (InternalState blk)
stateVar InternalState blk
is
    (Maybe (TraceEventMempool blk), MempoolSnapshot blk TicketNo)
-> STM
     m (Maybe (TraceEventMempool blk), MempoolSnapshot blk TicketNo)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (TraceEventMempool blk)
mTrace, MempoolSnapshot blk TicketNo
msp)

-- | Create a 'SyncWithLedger' value representing the values that will need to
-- be stored for committing this synchronization with the Ledger.
--
-- See the documentation of 'runSyncWithLedger' for more context.
pureSyncWithLedger
  :: (LedgerSupportsMempool blk, HasTxId (GenTx blk), ValidateEnvelope blk)
  => InternalState blk
  -> LedgerState blk
  -> LedgerConfig blk
  -> MempoolCapacityBytesOverride
  -> SyncWithLedger blk
pureSyncWithLedger :: InternalState blk
-> LedgerState blk
-> LedgerConfig blk
-> MempoolCapacityBytesOverride
-> SyncWithLedger blk
pureSyncWithLedger InternalState blk
istate LedgerState blk
lstate LedgerConfig blk
lcfg MempoolCapacityBytesOverride
capacityOverride =
    let vr :: ValidationResult (Validated (GenTx blk)) blk
vr          = InternalState blk
-> LedgerState blk
-> LedgerConfig blk
-> MempoolCapacityBytesOverride
-> ValidationResult (Validated (GenTx blk)) blk
forall blk.
(LedgerSupportsMempool blk, HasTxId (GenTx blk),
 ValidateEnvelope blk) =>
InternalState blk
-> LedgerState blk
-> LedgerConfig blk
-> MempoolCapacityBytesOverride
-> ValidationResult (Validated (GenTx blk)) blk
validateIS InternalState blk
istate LedgerState blk
lstate LedgerConfig blk
lcfg MempoolCapacityBytesOverride
capacityOverride
        removed :: [Validated (GenTx blk)]
removed     = ((Validated (GenTx blk), ApplyTxErr blk) -> Validated (GenTx blk))
-> [(Validated (GenTx blk), ApplyTxErr blk)]
-> [Validated (GenTx blk)]
forall a b. (a -> b) -> [a] -> [b]
map (Validated (GenTx blk), ApplyTxErr blk) -> Validated (GenTx blk)
forall a b. (a, b) -> a
fst (ValidationResult (Validated (GenTx blk)) blk
-> [(Validated (GenTx blk), ApplyTxErr blk)]
forall invalidTx blk.
ValidationResult invalidTx blk -> [(invalidTx, ApplyTxErr blk)]
vrInvalid ValidationResult (Validated (GenTx blk)) blk
vr)
        istate' :: InternalState blk
istate'     = ValidationResult (Validated (GenTx blk)) blk -> InternalState blk
forall invalidTx blk.
ValidationResult invalidTx blk -> InternalState blk
internalStateFromVR ValidationResult (Validated (GenTx blk)) blk
vr
        mTrace :: Maybe (TraceEventMempool blk)
mTrace      = if [Validated (GenTx blk)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Validated (GenTx blk)]
removed
                      then
                        Maybe (TraceEventMempool blk)
forall a. Maybe a
Nothing
                      else
                        TraceEventMempool blk -> Maybe (TraceEventMempool blk)
forall a. a -> Maybe a
Just (TraceEventMempool blk -> Maybe (TraceEventMempool blk))
-> TraceEventMempool blk -> Maybe (TraceEventMempool blk)
forall a b. (a -> b) -> a -> b
$ [Validated (GenTx blk)] -> MempoolSize -> TraceEventMempool blk
forall blk.
[Validated (GenTx blk)] -> MempoolSize -> TraceEventMempool blk
TraceMempoolRemoveTxs [Validated (GenTx blk)]
removed (InternalState blk -> MempoolSize
forall blk. InternalState blk -> MempoolSize
isMempoolSize InternalState blk
istate')
        snapshot :: MempoolSnapshot blk TicketNo
snapshot    = InternalState blk -> MempoolSnapshot blk TicketNo
forall blk.
HasTxId (GenTx blk) =>
InternalState blk -> MempoolSnapshot blk TicketNo
implSnapshotFromIS InternalState blk
istate'
    in
      InternalState blk
-> MempoolSnapshot blk TicketNo
-> Maybe (TraceEventMempool blk)
-> SyncWithLedger blk
forall blk.
InternalState blk
-> MempoolSnapshot blk TicketNo
-> Maybe (TraceEventMempool blk)
-> SyncWithLedger blk
NewSyncedState InternalState blk
istate' MempoolSnapshot blk TicketNo
snapshot Maybe (TraceEventMempool blk)
mTrace

-- | Get a snapshot of the mempool state that is valid with respect to
-- the given ledger state
pureGetSnapshotFor
  :: forall blk.
     ( LedgerSupportsMempool blk
     , HasTxId (GenTx blk)
     , ValidateEnvelope blk
     )
  => LedgerConfig blk
  -> ForgeLedgerState blk
  -> MempoolCapacityBytesOverride
  -> InternalState blk
  -> MempoolSnapshot blk TicketNo
pureGetSnapshotFor :: LedgerConfig blk
-> ForgeLedgerState blk
-> MempoolCapacityBytesOverride
-> InternalState blk
-> MempoolSnapshot blk TicketNo
pureGetSnapshotFor LedgerConfig blk
cfg ForgeLedgerState blk
blockLedgerState MempoolCapacityBytesOverride
capacityOverride =
      InternalState blk -> MempoolSnapshot blk TicketNo
forall blk.
HasTxId (GenTx blk) =>
InternalState blk -> MempoolSnapshot blk TicketNo
implSnapshotFromIS
    (InternalState blk -> MempoolSnapshot blk TicketNo)
-> (InternalState blk -> InternalState blk)
-> InternalState blk
-> MempoolSnapshot blk TicketNo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ValidationResult (Validated (GenTx blk)) blk -> InternalState blk
forall invalidTx blk.
ValidationResult invalidTx blk -> InternalState blk
internalStateFromVR
    (ValidationResult (Validated (GenTx blk)) blk -> InternalState blk)
-> (InternalState blk
    -> ValidationResult (Validated (GenTx blk)) blk)
-> InternalState blk
-> InternalState blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MempoolCapacityBytesOverride
-> LedgerConfig blk
-> ForgeLedgerState blk
-> InternalState blk
-> ValidationResult (Validated (GenTx blk)) blk
forall blk.
(LedgerSupportsMempool blk, HasTxId (GenTx blk),
 ValidateEnvelope blk) =>
MempoolCapacityBytesOverride
-> LedgerConfig blk
-> ForgeLedgerState blk
-> InternalState blk
-> ValidationResult (Validated (GenTx blk)) blk
validateStateFor MempoolCapacityBytesOverride
capacityOverride LedgerConfig blk
cfg ForgeLedgerState blk
blockLedgerState

{-------------------------------------------------------------------------------
  MempoolSnapshot Implementation
-------------------------------------------------------------------------------}

-- | Create a Mempool Snapshot from a given Internal State of the mempool.
implSnapshotFromIS
  :: HasTxId (GenTx blk)
  => InternalState blk
  -> MempoolSnapshot blk TicketNo
implSnapshotFromIS :: InternalState blk -> MempoolSnapshot blk TicketNo
implSnapshotFromIS InternalState blk
is = MempoolSnapshot :: forall blk idx.
[(Validated (GenTx blk), idx)]
-> (idx -> [(Validated (GenTx blk), idx)])
-> (idx -> Maybe (Validated (GenTx blk)))
-> (GenTxId blk -> Bool)
-> MempoolSize
-> SlotNo
-> TickedLedgerState blk
-> MempoolSnapshot blk idx
MempoolSnapshot {
      snapshotTxs :: [(Validated (GenTx blk), TicketNo)]
snapshotTxs         = InternalState blk -> [(Validated (GenTx blk), TicketNo)]
forall blk.
InternalState blk -> [(Validated (GenTx blk), TicketNo)]
implSnapshotGetTxs         InternalState blk
is
    , snapshotTxsAfter :: TicketNo -> [(Validated (GenTx blk), TicketNo)]
snapshotTxsAfter    = InternalState blk
-> TicketNo -> [(Validated (GenTx blk), TicketNo)]
forall blk.
InternalState blk
-> TicketNo -> [(Validated (GenTx blk), TicketNo)]
implSnapshotGetTxsAfter    InternalState blk
is
    , snapshotLookupTx :: TicketNo -> Maybe (Validated (GenTx blk))
snapshotLookupTx    = InternalState blk -> TicketNo -> Maybe (Validated (GenTx blk))
forall blk.
InternalState blk -> TicketNo -> Maybe (Validated (GenTx blk))
implSnapshotGetTx          InternalState blk
is
    , snapshotHasTx :: GenTxId blk -> Bool
snapshotHasTx       = InternalState blk -> GenTxId blk -> Bool
forall blk.
Ord (GenTxId blk) =>
InternalState blk -> GenTxId blk -> Bool
implSnapshotHasTx          InternalState blk
is
    , snapshotMempoolSize :: MempoolSize
snapshotMempoolSize = InternalState blk -> MempoolSize
forall blk. InternalState blk -> MempoolSize
implSnapshotGetMempoolSize InternalState blk
is
    , snapshotSlotNo :: SlotNo
snapshotSlotNo      = InternalState blk -> SlotNo
forall blk. InternalState blk -> SlotNo
isSlotNo                   InternalState blk
is
    , snapshotLedgerState :: TickedLedgerState blk
snapshotLedgerState = InternalState blk -> TickedLedgerState blk
forall blk. InternalState blk -> TickedLedgerState blk
isLedgerState              InternalState blk
is
    }
 where
  implSnapshotGetTxs :: InternalState blk
                     -> [(Validated (GenTx blk), TicketNo)]
  implSnapshotGetTxs :: InternalState blk -> [(Validated (GenTx blk), TicketNo)]
implSnapshotGetTxs = (InternalState blk
 -> TicketNo -> [(Validated (GenTx blk), TicketNo)])
-> TicketNo
-> InternalState blk
-> [(Validated (GenTx blk), TicketNo)]
forall a b c. (a -> b -> c) -> b -> a -> c
flip InternalState blk
-> TicketNo -> [(Validated (GenTx blk), TicketNo)]
forall blk.
InternalState blk
-> TicketNo -> [(Validated (GenTx blk), TicketNo)]
implSnapshotGetTxsAfter TicketNo
zeroTicketNo

  implSnapshotGetTxsAfter :: InternalState blk
                          -> TicketNo
                          -> [(Validated (GenTx blk), TicketNo)]
  implSnapshotGetTxsAfter :: InternalState blk
-> TicketNo -> [(Validated (GenTx blk), TicketNo)]
implSnapshotGetTxsAfter IS{TxSeq (Validated (GenTx blk))
isTxs :: TxSeq (Validated (GenTx blk))
isTxs :: forall blk. InternalState blk -> TxSeq (Validated (GenTx blk))
isTxs} =
    TxSeq (Validated (GenTx blk))
-> [(Validated (GenTx blk), TicketNo)]
forall tx. TxSeq tx -> [(tx, TicketNo)]
TxSeq.toTuples (TxSeq (Validated (GenTx blk))
 -> [(Validated (GenTx blk), TicketNo)])
-> (TicketNo -> TxSeq (Validated (GenTx blk)))
-> TicketNo
-> [(Validated (GenTx blk), TicketNo)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TxSeq (Validated (GenTx blk)), TxSeq (Validated (GenTx blk)))
-> TxSeq (Validated (GenTx blk))
forall a b. (a, b) -> b
snd ((TxSeq (Validated (GenTx blk)), TxSeq (Validated (GenTx blk)))
 -> TxSeq (Validated (GenTx blk)))
-> (TicketNo
    -> (TxSeq (Validated (GenTx blk)), TxSeq (Validated (GenTx blk))))
-> TicketNo
-> TxSeq (Validated (GenTx blk))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxSeq (Validated (GenTx blk))
-> TicketNo
-> (TxSeq (Validated (GenTx blk)), TxSeq (Validated (GenTx blk)))
forall tx. TxSeq tx -> TicketNo -> (TxSeq tx, TxSeq tx)
TxSeq.splitAfterTicketNo TxSeq (Validated (GenTx blk))
isTxs

  implSnapshotGetTx :: InternalState blk
                    -> TicketNo
                    -> Maybe (Validated (GenTx blk))
  implSnapshotGetTx :: InternalState blk -> TicketNo -> Maybe (Validated (GenTx blk))
implSnapshotGetTx IS{TxSeq (Validated (GenTx blk))
isTxs :: TxSeq (Validated (GenTx blk))
isTxs :: forall blk. InternalState blk -> TxSeq (Validated (GenTx blk))
isTxs} = (TxSeq (Validated (GenTx blk))
isTxs TxSeq (Validated (GenTx blk))
-> TicketNo -> Maybe (Validated (GenTx blk))
forall tx. TxSeq tx -> TicketNo -> Maybe tx
`TxSeq.lookupByTicketNo`)

  implSnapshotHasTx :: Ord (GenTxId blk)
                    => InternalState blk
                    -> GenTxId blk
                    -> Bool
  implSnapshotHasTx :: InternalState blk -> GenTxId blk -> Bool
implSnapshotHasTx IS{Set (GenTxId blk)
isTxIds :: forall blk. InternalState blk -> Set (GenTxId blk)
isTxIds :: Set (GenTxId blk)
isTxIds} = (GenTxId blk -> Set (GenTxId blk) -> Bool)
-> Set (GenTxId blk) -> GenTxId blk -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip GenTxId blk -> Set (GenTxId blk) -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member Set (GenTxId blk)
isTxIds

  implSnapshotGetMempoolSize :: InternalState blk
                             -> MempoolSize
  implSnapshotGetMempoolSize :: InternalState blk -> MempoolSize
implSnapshotGetMempoolSize = TxSeq (Validated (GenTx blk)) -> MempoolSize
forall tx. TxSeq tx -> MempoolSize
TxSeq.toMempoolSize (TxSeq (Validated (GenTx blk)) -> MempoolSize)
-> (InternalState blk -> TxSeq (Validated (GenTx blk)))
-> InternalState blk
-> MempoolSize
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InternalState blk -> TxSeq (Validated (GenTx blk))
forall blk. InternalState blk -> TxSeq (Validated (GenTx blk))
isTxs