{-# LANGUAGE DeriveAnyClass       #-}
{-# LANGUAGE DeriveGeneric        #-}
{-# LANGUAGE FlexibleContexts     #-}
{-# LANGUAGE LambdaCase           #-}
{-# LANGUAGE NamedFieldPuns       #-}
{-# LANGUAGE ScopedTypeVariables  #-}
{-# LANGUAGE StandaloneDeriving   #-}
{-# LANGUAGE TypeApplications     #-}
{-# LANGUAGE UndecidableInstances #-}

module Ouroboros.Consensus.Mempool.Impl (
    openMempool
  , MempoolCapacityBytesOverride (..)
  , LedgerInterface (..)
  , chainDBLedgerInterface
  , TicketNo
    -- * For testing purposes
  , openMempoolWithoutSyncThread
  ) where

import           Control.Exception (assert)
import           Control.Monad.Except
import           Data.Maybe (isJust, isNothing, listToMaybe)
import           Data.Set (Set)
import qualified Data.Set as Set
import           Data.Typeable
import           Data.Word (Word32)
import           GHC.Generics (Generic)

import           Control.Tracer

import           Ouroboros.Consensus.Storage.ChainDB (ChainDB)
import qualified Ouroboros.Consensus.Storage.ChainDB.API as ChainDB

import           Ouroboros.Consensus.Block
import           Ouroboros.Consensus.HeaderValidation
import           Ouroboros.Consensus.Ledger.Abstract
import           Ouroboros.Consensus.Ledger.Extended
import           Ouroboros.Consensus.Ledger.SupportsMempool
import           Ouroboros.Consensus.Mempool.API
import           Ouroboros.Consensus.Mempool.TxSeq (TicketNo, TxSeq (..),
                     TxTicket (..), zeroTicketNo)
import qualified Ouroboros.Consensus.Mempool.TxSeq as TxSeq
import           Ouroboros.Consensus.Util (repeatedly)
import           Ouroboros.Consensus.Util.IOLike
import           Ouroboros.Consensus.Util.ResourceRegistry
import           Ouroboros.Consensus.Util.STM (onEachChange)

{-------------------------------------------------------------------------------
  Top-level API
-------------------------------------------------------------------------------}

-- | An override for the default 'MempoolCapacityBytes' which is 2x the
-- maximum transaction capacity (see 'MaxTxCapacityOverride')
data MempoolCapacityBytesOverride
  = NoMempoolCapacityBytesOverride
    -- ^ Use 2x the maximum transaction capacity of a block. This will change
    -- dynamically with the protocol parameters adopted in the current ledger.
  | MempoolCapacityBytesOverride !MempoolCapacityBytes
    -- ^ Use the following 'MempoolCapacityBytes'.
  deriving (MempoolCapacityBytesOverride
-> MempoolCapacityBytesOverride -> Bool
(MempoolCapacityBytesOverride
 -> MempoolCapacityBytesOverride -> Bool)
-> (MempoolCapacityBytesOverride
    -> MempoolCapacityBytesOverride -> Bool)
-> Eq MempoolCapacityBytesOverride
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MempoolCapacityBytesOverride
-> MempoolCapacityBytesOverride -> Bool
$c/= :: MempoolCapacityBytesOverride
-> MempoolCapacityBytesOverride -> Bool
== :: MempoolCapacityBytesOverride
-> MempoolCapacityBytesOverride -> Bool
$c== :: MempoolCapacityBytesOverride
-> MempoolCapacityBytesOverride -> Bool
Eq, Int -> MempoolCapacityBytesOverride -> ShowS
[MempoolCapacityBytesOverride] -> ShowS
MempoolCapacityBytesOverride -> String
(Int -> MempoolCapacityBytesOverride -> ShowS)
-> (MempoolCapacityBytesOverride -> String)
-> ([MempoolCapacityBytesOverride] -> ShowS)
-> Show MempoolCapacityBytesOverride
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MempoolCapacityBytesOverride] -> ShowS
$cshowList :: [MempoolCapacityBytesOverride] -> ShowS
show :: MempoolCapacityBytesOverride -> String
$cshow :: MempoolCapacityBytesOverride -> String
showsPrec :: Int -> MempoolCapacityBytesOverride -> ShowS
$cshowsPrec :: Int -> MempoolCapacityBytesOverride -> ShowS
Show)

openMempool
  :: ( IOLike m
     , LedgerSupportsMempool blk
     , HasTxId (GenTx blk)
     , ValidateEnvelope blk
     )
  => ResourceRegistry m
  -> LedgerInterface m blk
  -> LedgerConfig blk
  -> MempoolCapacityBytesOverride
  -> Tracer m (TraceEventMempool blk)
  -> (GenTx blk -> TxSizeInBytes)
  -> m (Mempool m blk TicketNo)
openMempool :: ResourceRegistry m
-> LedgerInterface m blk
-> LedgerConfig blk
-> MempoolCapacityBytesOverride
-> Tracer m (TraceEventMempool blk)
-> (GenTx blk -> TxSizeInBytes)
-> m (Mempool m blk TicketNo)
openMempool ResourceRegistry m
registry LedgerInterface m blk
ledger LedgerConfig blk
cfg MempoolCapacityBytesOverride
capacityOverride Tracer m (TraceEventMempool blk)
tracer GenTx blk -> TxSizeInBytes
txSize = do
    MempoolEnv m blk
env <- LedgerInterface m blk
-> LedgerConfig blk
-> MempoolCapacityBytesOverride
-> Tracer m (TraceEventMempool blk)
-> (GenTx blk -> TxSizeInBytes)
-> m (MempoolEnv m blk)
forall (m :: * -> *) blk.
(IOLike m, NoThunks (GenTxId blk), LedgerSupportsMempool blk,
 ValidateEnvelope blk) =>
LedgerInterface m blk
-> LedgerConfig blk
-> MempoolCapacityBytesOverride
-> Tracer m (TraceEventMempool blk)
-> (GenTx blk -> TxSizeInBytes)
-> m (MempoolEnv m blk)
initMempoolEnv LedgerInterface m blk
ledger LedgerConfig blk
cfg MempoolCapacityBytesOverride
capacityOverride Tracer m (TraceEventMempool blk)
tracer GenTx blk -> TxSizeInBytes
txSize
    ResourceRegistry m -> MempoolEnv m blk -> m ()
forall (m :: * -> *) blk.
(IOLike m, LedgerSupportsMempool blk, HasTxId (GenTx blk),
 ValidateEnvelope blk) =>
ResourceRegistry m -> MempoolEnv m blk -> m ()
forkSyncStateOnTipPointChange ResourceRegistry m
registry MempoolEnv m blk
env
    Mempool m blk TicketNo -> m (Mempool m blk TicketNo)
forall (m :: * -> *) a. Monad m => a -> m a
return (Mempool m blk TicketNo -> m (Mempool m blk TicketNo))
-> Mempool m blk TicketNo -> m (Mempool m blk TicketNo)
forall a b. (a -> b) -> a -> b
$ MempoolEnv m blk -> Mempool m blk TicketNo
forall (m :: * -> *) blk.
(IOLike m, LedgerSupportsMempool blk, HasTxId (GenTx blk),
 ValidateEnvelope blk) =>
MempoolEnv m blk -> Mempool m blk TicketNo
mkMempool MempoolEnv m blk
env

-- | Unlike 'openMempool', this function does not fork a background thread
-- that synchronises with the ledger state whenever the later changes.
--
-- Intended for testing purposes.
openMempoolWithoutSyncThread
  :: ( IOLike m
     , LedgerSupportsMempool blk
     , HasTxId (GenTx blk)
     , ValidateEnvelope blk
     )
  => LedgerInterface m blk
  -> LedgerConfig blk
  -> MempoolCapacityBytesOverride
  -> Tracer m (TraceEventMempool blk)
  -> (GenTx blk -> TxSizeInBytes)
  -> m (Mempool m blk TicketNo)
openMempoolWithoutSyncThread :: LedgerInterface m blk
-> LedgerConfig blk
-> MempoolCapacityBytesOverride
-> Tracer m (TraceEventMempool blk)
-> (GenTx blk -> TxSizeInBytes)
-> m (Mempool m blk TicketNo)
openMempoolWithoutSyncThread LedgerInterface m blk
ledger LedgerConfig blk
cfg MempoolCapacityBytesOverride
capacityOverride Tracer m (TraceEventMempool blk)
tracer GenTx blk -> TxSizeInBytes
txSize =
    MempoolEnv m blk -> Mempool m blk TicketNo
forall (m :: * -> *) blk.
(IOLike m, LedgerSupportsMempool blk, HasTxId (GenTx blk),
 ValidateEnvelope blk) =>
MempoolEnv m blk -> Mempool m blk TicketNo
mkMempool (MempoolEnv m blk -> Mempool m blk TicketNo)
-> m (MempoolEnv m blk) -> m (Mempool m blk TicketNo)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LedgerInterface m blk
-> LedgerConfig blk
-> MempoolCapacityBytesOverride
-> Tracer m (TraceEventMempool blk)
-> (GenTx blk -> TxSizeInBytes)
-> m (MempoolEnv m blk)
forall (m :: * -> *) blk.
(IOLike m, NoThunks (GenTxId blk), LedgerSupportsMempool blk,
 ValidateEnvelope blk) =>
LedgerInterface m blk
-> LedgerConfig blk
-> MempoolCapacityBytesOverride
-> Tracer m (TraceEventMempool blk)
-> (GenTx blk -> TxSizeInBytes)
-> m (MempoolEnv m blk)
initMempoolEnv LedgerInterface m blk
ledger LedgerConfig blk
cfg MempoolCapacityBytesOverride
capacityOverride Tracer m (TraceEventMempool blk)
tracer GenTx blk -> TxSizeInBytes
txSize

mkMempool
  :: ( IOLike m
     , LedgerSupportsMempool blk
     , HasTxId (GenTx blk)
     , ValidateEnvelope blk
     )
  => MempoolEnv m blk -> Mempool m blk TicketNo
mkMempool :: MempoolEnv m blk -> Mempool m blk TicketNo
mkMempool MempoolEnv m blk
env = Mempool :: forall (m :: * -> *) blk idx.
([GenTx blk]
 -> m ([(GenTx blk, MempoolAddTxResult blk)], [GenTx blk]))
-> ([GenTxId blk] -> m ())
-> m (MempoolSnapshot blk idx)
-> STM m (MempoolSnapshot blk idx)
-> (ForgeLedgerState blk -> STM m (MempoolSnapshot blk idx))
-> STM m MempoolCapacityBytes
-> (GenTx blk -> TxSizeInBytes)
-> idx
-> Mempool m blk idx
Mempool
    { tryAddTxs :: [GenTx blk]
-> m ([(GenTx blk, MempoolAddTxResult blk)], [GenTx blk])
tryAddTxs      = MempoolEnv m blk
-> [GenTx blk]
-> m ([(GenTx blk, MempoolAddTxResult blk)], [GenTx blk])
forall (m :: * -> *) blk.
(IOLike m, LedgerSupportsMempool blk, HasTxId (GenTx blk)) =>
MempoolEnv m blk
-> [GenTx blk]
-> m ([(GenTx blk, MempoolAddTxResult blk)], [GenTx blk])
implTryAddTxs      MempoolEnv m blk
env
    , removeTxs :: [GenTxId blk] -> m ()
removeTxs      = MempoolEnv m blk -> [GenTxId blk] -> m ()
forall (m :: * -> *) blk.
(IOLike m, LedgerSupportsMempool blk, HasTxId (GenTx blk),
 ValidateEnvelope blk) =>
MempoolEnv m blk -> [GenTxId blk] -> m ()
implRemoveTxs      MempoolEnv m blk
env
    , syncWithLedger :: m (MempoolSnapshot blk TicketNo)
syncWithLedger = MempoolEnv m blk -> m (MempoolSnapshot blk TicketNo)
forall (m :: * -> *) blk.
(IOLike m, LedgerSupportsMempool blk, HasTxId (GenTx blk),
 ValidateEnvelope blk) =>
MempoolEnv m blk -> m (MempoolSnapshot blk TicketNo)
implSyncWithLedger MempoolEnv m blk
env
    , getSnapshot :: STM m (MempoolSnapshot blk TicketNo)
getSnapshot    = MempoolEnv m blk -> STM m (MempoolSnapshot blk TicketNo)
forall (m :: * -> *) blk.
(IOLike m, HasTxId (GenTx blk)) =>
MempoolEnv m blk -> STM m (MempoolSnapshot blk TicketNo)
implGetSnapshot    MempoolEnv m blk
env
    , getSnapshotFor :: ForgeLedgerState blk -> STM m (MempoolSnapshot blk TicketNo)
getSnapshotFor = MempoolEnv m blk
-> ForgeLedgerState blk -> STM m (MempoolSnapshot blk TicketNo)
forall (m :: * -> *) blk.
(IOLike m, LedgerSupportsMempool blk, HasTxId (GenTx blk),
 ValidateEnvelope blk) =>
MempoolEnv m blk
-> ForgeLedgerState blk -> STM m (MempoolSnapshot blk TicketNo)
implGetSnapshotFor MempoolEnv m blk
env
    , getCapacity :: STM m MempoolCapacityBytes
getCapacity    = MempoolEnv m blk -> STM m MempoolCapacityBytes
forall (m :: * -> *) blk.
IOLike m =>
MempoolEnv m blk -> STM m MempoolCapacityBytes
implGetCapacity    MempoolEnv m blk
env
    , getTxSize :: GenTx blk -> TxSizeInBytes
getTxSize      = MempoolEnv m blk -> GenTx blk -> TxSizeInBytes
forall (m :: * -> *) blk.
MempoolEnv m blk -> GenTx blk -> TxSizeInBytes
mpEnvTxSize        MempoolEnv m blk
env
    , zeroIdx :: TicketNo
zeroIdx        = TicketNo
zeroTicketNo
    }

-- | Abstract interface needed to run a Mempool.
data LedgerInterface m blk = LedgerInterface
  { LedgerInterface m blk -> STM m (LedgerState blk)
getCurrentLedgerState :: STM m (LedgerState blk)
  }

-- | Create a 'LedgerInterface' from a 'ChainDB'.
chainDBLedgerInterface :: IOLike m => ChainDB m blk -> LedgerInterface m blk
chainDBLedgerInterface :: ChainDB m blk -> LedgerInterface m blk
chainDBLedgerInterface ChainDB m blk
chainDB = LedgerInterface :: forall (m :: * -> *) blk.
STM m (LedgerState blk) -> LedgerInterface m blk
LedgerInterface
    { getCurrentLedgerState :: STM m (LedgerState blk)
getCurrentLedgerState = ExtLedgerState blk -> LedgerState blk
forall blk. ExtLedgerState blk -> LedgerState blk
ledgerState (ExtLedgerState blk -> LedgerState blk)
-> STM m (ExtLedgerState blk) -> STM m (LedgerState blk)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ChainDB m blk -> STM m (ExtLedgerState blk)
forall (m :: * -> *) blk.
ChainDB m blk -> STM m (ExtLedgerState blk)
ChainDB.getCurrentLedger ChainDB m blk
chainDB
    }

{-------------------------------------------------------------------------------
  Internal state
-------------------------------------------------------------------------------}

-- | Internal state in the mempool
data InternalState blk = IS {
      -- | Transactions currently in the mempool
      --
      -- NOTE: the total size of the transactions in 'isTxs' may exceed the
      -- current capacity ('isCapacity'). When the capacity computed from the
      -- ledger has shrunk, we don't remove transactions from the Mempool to
      -- satisfy the new lower limit. We let the transactions get removed in
      -- the normal way: by becoming invalid w.r.t. the updated ledger state.
      -- We treat a Mempool /over/ capacity in the same way as a Mempool /at/
      -- capacity.
      InternalState blk -> TxSeq (GenTx blk)
isTxs          :: !(TxSeq (GenTx blk))

      -- | The cached IDs of transactions currently in the mempool.
      --
      -- This allows one to more quickly lookup transactions by ID from a
      -- 'MempoolSnapshot' (see 'snapshotHasTx').
      --
      -- This should always be in-sync with the transactions in 'isTxs'.
    , InternalState blk -> Set (GenTxId blk)
isTxIds        :: !(Set (GenTxId blk))

      -- | The cached ledger state after applying the transactions in the
      -- Mempool against the chain's ledger state. New transactions will be
      -- validated against this ledger.
      --
      -- INVARIANT: 'isLedgerState' is the ledger resulting from applying the
      -- transactions in 'isTxs' against the ledger identified 'isTip' as tip.
    , InternalState blk -> TickedLedgerState blk
isLedgerState  :: !(TickedLedgerState blk)

      -- | The tip of the chain that 'isTxs' was validated against
      --
      -- This comes from the underlying ledger state ('tickedLedgerState')
    , InternalState blk -> ChainHash blk
isTip          :: !(ChainHash blk)

      -- | The most recent 'SlotNo' that 'isTxs' was validated against
      --
      -- This comes from 'applyChainTick' ('tickedSlotNo').
    , InternalState blk -> SlotNo
isSlotNo       :: !SlotNo

      -- | The mempool 'TicketNo' counter.
      --
      -- See 'vrLastTicketNo' for more information.
    , InternalState blk -> TicketNo
isLastTicketNo :: !TicketNo

      -- | Current maximum capacity of the Mempool. Result of
      -- 'computeMempoolCapacity' using the current chain's
      -- 'TickedLedgerState'.
      --
      -- NOTE: this does not correspond to 'isLedgerState', which is the
      -- 'TickedLedgerState' /after/ applying the transactions in the Mempool.
      -- There might be a transaction in the Mempool triggering a change in
      -- the maximum transaction capacity of a block, which would change the
      -- Mempool's capacity (unless overridden). We don't want the Mempool's
      -- capacity to depend on its contents. The mempool is assuming /all/ its
      -- transactions will be in the next block. So any changes caused by that
      -- block will take effect after applying it and will only affect the
      -- next block.
    , InternalState blk -> MempoolCapacityBytes
isCapacity     :: !MempoolCapacityBytes
    }
  deriving ((forall x. InternalState blk -> Rep (InternalState blk) x)
-> (forall x. Rep (InternalState blk) x -> InternalState blk)
-> Generic (InternalState blk)
forall x. Rep (InternalState blk) x -> InternalState blk
forall x. InternalState blk -> Rep (InternalState blk) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall blk x. Rep (InternalState blk) x -> InternalState blk
forall blk x. InternalState blk -> Rep (InternalState blk) x
$cto :: forall blk x. Rep (InternalState blk) x -> InternalState blk
$cfrom :: forall blk x. InternalState blk -> Rep (InternalState blk) x
Generic)

deriving instance ( NoThunks (GenTx blk)
                  , NoThunks (GenTxId blk)
                  , NoThunks (Ticked (LedgerState blk))
                  , StandardHash blk
                  , Typeable blk
                  ) => NoThunks (InternalState blk)

-- | \( O(1) \). Return the number of transactions in the internal state of
-- the Mempool paired with their total size in bytes.
isMempoolSize :: InternalState blk -> MempoolSize
isMempoolSize :: InternalState blk -> MempoolSize
isMempoolSize = TxSeq (GenTx blk) -> MempoolSize
forall tx. TxSeq tx -> MempoolSize
TxSeq.toMempoolSize (TxSeq (GenTx blk) -> MempoolSize)
-> (InternalState blk -> TxSeq (GenTx blk))
-> InternalState blk
-> MempoolSize
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InternalState blk -> TxSeq (GenTx blk)
forall blk. InternalState blk -> TxSeq (GenTx blk)
isTxs

data MempoolEnv m blk = MempoolEnv {
      MempoolEnv m blk -> LedgerInterface m blk
mpEnvLedger           :: LedgerInterface m blk
    , MempoolEnv m blk -> LedgerConfig blk
mpEnvLedgerCfg        :: LedgerConfig blk
    , MempoolEnv m blk -> StrictTVar m (InternalState blk)
mpEnvStateVar         :: StrictTVar m (InternalState blk)
    , MempoolEnv m blk -> Tracer m (TraceEventMempool blk)
mpEnvTracer           :: Tracer m (TraceEventMempool blk)
    , MempoolEnv m blk -> GenTx blk -> TxSizeInBytes
mpEnvTxSize           :: GenTx blk -> TxSizeInBytes
    , MempoolEnv m blk -> MempoolCapacityBytesOverride
mpEnvCapacityOverride :: MempoolCapacityBytesOverride
    }

initInternalState
  :: LedgerSupportsMempool blk
  => MempoolCapacityBytesOverride
  -> TicketNo  -- ^ Used for 'isLastTicketNo'
  -> SlotNo
  -> TickedLedgerState blk
  -> InternalState blk
initInternalState :: MempoolCapacityBytesOverride
-> TicketNo -> SlotNo -> TickedLedgerState blk -> InternalState blk
initInternalState MempoolCapacityBytesOverride
capacityOverride TicketNo
lastTicketNo SlotNo
slot TickedLedgerState blk
st = IS :: forall blk.
TxSeq (GenTx blk)
-> Set (GenTxId blk)
-> TickedLedgerState blk
-> ChainHash blk
-> SlotNo
-> TicketNo
-> MempoolCapacityBytes
-> InternalState blk
IS {
      isTxs :: TxSeq (GenTx blk)
isTxs          = TxSeq (GenTx blk)
forall tx. TxSeq tx
TxSeq.Empty
    , isTxIds :: Set (GenTxId blk)
isTxIds        = Set (GenTxId blk)
forall a. Set a
Set.empty
    , isLedgerState :: TickedLedgerState blk
isLedgerState  = TickedLedgerState blk
st
    , isTip :: ChainHash blk
isTip          = ChainHash (TickedLedgerState blk) -> ChainHash blk
forall b b'.
Coercible (HeaderHash b) (HeaderHash b') =>
ChainHash b -> ChainHash b'
castHash (TickedLedgerState blk -> ChainHash (TickedLedgerState blk)
forall l. GetTip l => l -> ChainHash l
getTipHash TickedLedgerState blk
st)
    , isSlotNo :: SlotNo
isSlotNo       = SlotNo
slot
    , isLastTicketNo :: TicketNo
isLastTicketNo = TicketNo
lastTicketNo
    , isCapacity :: MempoolCapacityBytes
isCapacity     = TickedLedgerState blk
-> MempoolCapacityBytesOverride -> MempoolCapacityBytes
forall blk.
LedgerSupportsMempool blk =>
TickedLedgerState blk
-> MempoolCapacityBytesOverride -> MempoolCapacityBytes
computeMempoolCapacity TickedLedgerState blk
st MempoolCapacityBytesOverride
capacityOverride
    }

initMempoolEnv :: ( IOLike m
                  , NoThunks (GenTxId blk)
                  , LedgerSupportsMempool blk
                  , ValidateEnvelope blk
                  )
               => LedgerInterface m blk
               -> LedgerConfig blk
               -> MempoolCapacityBytesOverride
               -> Tracer m (TraceEventMempool blk)
               -> (GenTx blk -> TxSizeInBytes)
               -> m (MempoolEnv m blk)
initMempoolEnv :: LedgerInterface m blk
-> LedgerConfig blk
-> MempoolCapacityBytesOverride
-> Tracer m (TraceEventMempool blk)
-> (GenTx blk -> TxSizeInBytes)
-> m (MempoolEnv m blk)
initMempoolEnv LedgerInterface m blk
ledgerInterface LedgerConfig blk
cfg MempoolCapacityBytesOverride
capacityOverride Tracer m (TraceEventMempool blk)
tracer GenTx blk -> TxSizeInBytes
txSize = do
    LedgerState blk
st <- STM m (LedgerState blk) -> m (LedgerState blk)
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (LedgerState blk) -> m (LedgerState blk))
-> STM m (LedgerState blk) -> m (LedgerState blk)
forall a b. (a -> b) -> a -> b
$ LedgerInterface m blk -> STM m (LedgerState blk)
forall (m :: * -> *) blk.
LedgerInterface m blk -> STM m (LedgerState blk)
getCurrentLedgerState LedgerInterface m blk
ledgerInterface
    let (SlotNo
slot, TickedLedgerState blk
st') = 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
st)
    StrictTVar m (InternalState blk)
isVar <- InternalState blk -> m (StrictTVar m (InternalState blk))
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack, NoThunks a) =>
a -> m (StrictTVar m a)
newTVarIO (InternalState blk -> m (StrictTVar m (InternalState blk)))
-> InternalState blk -> m (StrictTVar m (InternalState blk))
forall a b. (a -> b) -> a -> b
$ MempoolCapacityBytesOverride
-> TicketNo -> SlotNo -> TickedLedgerState blk -> InternalState blk
forall blk.
LedgerSupportsMempool blk =>
MempoolCapacityBytesOverride
-> TicketNo -> SlotNo -> TickedLedgerState blk -> InternalState blk
initInternalState MempoolCapacityBytesOverride
capacityOverride TicketNo
zeroTicketNo SlotNo
slot TickedLedgerState blk
st'
    MempoolEnv m blk -> m (MempoolEnv m blk)
forall (m :: * -> *) a. Monad m => a -> m a
return MempoolEnv :: forall (m :: * -> *) blk.
LedgerInterface m blk
-> LedgerConfig blk
-> StrictTVar m (InternalState blk)
-> Tracer m (TraceEventMempool blk)
-> (GenTx blk -> TxSizeInBytes)
-> MempoolCapacityBytesOverride
-> MempoolEnv m blk
MempoolEnv
      { mpEnvLedger :: LedgerInterface m blk
mpEnvLedger           = LedgerInterface m blk
ledgerInterface
      , mpEnvLedgerCfg :: LedgerConfig blk
mpEnvLedgerCfg        = LedgerConfig blk
cfg
      , mpEnvStateVar :: StrictTVar m (InternalState blk)
mpEnvStateVar         = StrictTVar m (InternalState blk)
isVar
      , mpEnvTracer :: Tracer m (TraceEventMempool blk)
mpEnvTracer           = Tracer m (TraceEventMempool blk)
tracer
      , mpEnvTxSize :: GenTx blk -> TxSizeInBytes
mpEnvTxSize           = GenTx blk -> TxSizeInBytes
txSize
      , mpEnvCapacityOverride :: MempoolCapacityBytesOverride
mpEnvCapacityOverride = MempoolCapacityBytesOverride
capacityOverride
      }

-- | If no override is provided, calculate the default mempool capacity as 2x
-- the current ledger's maximum transaction capacity of a block.
computeMempoolCapacity
  :: LedgerSupportsMempool blk
  => TickedLedgerState blk
  -> MempoolCapacityBytesOverride
  -> MempoolCapacityBytes
computeMempoolCapacity :: TickedLedgerState blk
-> MempoolCapacityBytesOverride -> MempoolCapacityBytes
computeMempoolCapacity TickedLedgerState blk
st = \case
    MempoolCapacityBytesOverride
NoMempoolCapacityBytesOverride        -> MempoolCapacityBytes
noOverride
    MempoolCapacityBytesOverride MempoolCapacityBytes
override -> MempoolCapacityBytes
override
  where
    noOverride :: MempoolCapacityBytes
noOverride = TxSizeInBytes -> MempoolCapacityBytes
MempoolCapacityBytes (TickedLedgerState blk -> TxSizeInBytes
forall blk.
LedgerSupportsMempool blk =>
TickedLedgerState blk -> TxSizeInBytes
maxTxCapacity TickedLedgerState blk
st TxSizeInBytes -> TxSizeInBytes -> TxSizeInBytes
forall a. Num a => a -> a -> a
* TxSizeInBytes
2)

-- | Spawn a thread which syncs the 'Mempool' state whenever the 'LedgerState'
-- changes.
forkSyncStateOnTipPointChange :: forall m blk. (
                                   IOLike m
                                 , LedgerSupportsMempool blk
                                 , HasTxId (GenTx blk)
                                 , ValidateEnvelope blk
                                 )
                              => ResourceRegistry m
                              -> MempoolEnv m blk
                              -> m ()
forkSyncStateOnTipPointChange :: ResourceRegistry m -> MempoolEnv m blk -> m ()
forkSyncStateOnTipPointChange ResourceRegistry m
registry MempoolEnv m blk
menv =
    m (Thread m Void) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m (Thread m Void) -> m ()) -> m (Thread m Void) -> m ()
forall a b. (a -> b) -> a -> b
$ ResourceRegistry m
-> String
-> (Point blk -> Point blk)
-> Maybe (Point blk)
-> STM m (Point blk)
-> (Point blk -> m ())
-> m (Thread m Void)
forall (m :: * -> *) a b.
(IOLike m, Eq b, HasCallStack) =>
ResourceRegistry m
-> String
-> (a -> b)
-> Maybe b
-> STM m a
-> (a -> m ())
-> m (Thread m Void)
onEachChange
      ResourceRegistry m
registry
      String
"Mempool.syncStateOnTipPointChange"
      Point blk -> Point blk
forall a. a -> a
id
      Maybe (Point blk)
forall a. Maybe a
Nothing
      STM m (Point blk)
getCurrentTip
      Point blk -> m ()
action
  where
    action :: Point blk -> m ()
    action :: Point blk -> m ()
action Point blk
_tipPoint = m (MempoolSnapshot blk TicketNo) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m (MempoolSnapshot blk TicketNo) -> m ())
-> m (MempoolSnapshot blk TicketNo) -> m ()
forall a b. (a -> b) -> a -> b
$ MempoolEnv m blk -> m (MempoolSnapshot blk TicketNo)
forall (m :: * -> *) blk.
(IOLike m, LedgerSupportsMempool blk, HasTxId (GenTx blk),
 ValidateEnvelope blk) =>
MempoolEnv m blk -> m (MempoolSnapshot blk TicketNo)
implSyncWithLedger MempoolEnv m blk
menv

    -- Using the tip ('Point') allows for quicker equality checks
    getCurrentTip :: STM m (Point blk)
    getCurrentTip :: STM m (Point blk)
getCurrentTip =
          Proxy blk -> LedgerState blk -> Point blk
forall blk.
UpdateLedger blk =>
Proxy blk -> LedgerState blk -> Point blk
ledgerTipPoint (Proxy blk
forall k (t :: k). Proxy t
Proxy @blk)
      (LedgerState blk -> Point blk)
-> STM m (LedgerState blk) -> STM m (Point blk)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LedgerInterface m blk -> STM m (LedgerState blk)
forall (m :: * -> *) blk.
LedgerInterface m blk -> STM m (LedgerState blk)
getCurrentLedgerState (MempoolEnv m blk -> LedgerInterface m blk
forall (m :: * -> *) blk. MempoolEnv m blk -> LedgerInterface m blk
mpEnvLedger MempoolEnv m blk
menv)

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

-- | Add a bunch of transactions (oldest to newest)
--
-- 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.
--
-- 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.
--
-- POSTCONDITON:
-- > (processed, toProcess) <- implTryAddTxs mpEnv txs
-- > map fst processed ++ toProcess == txs
implTryAddTxs
  :: forall m blk. (IOLike m, LedgerSupportsMempool blk, HasTxId (GenTx blk))
  => MempoolEnv m blk
  -> [GenTx blk]
  -> m ( [(GenTx blk, MempoolAddTxResult blk)]
         -- Transactions that were added or rejected. A prefix of the input
         -- list.
       , [GenTx blk]
         -- Transactions that have not yet been added because the capacity
         -- of the Mempool has been reached. A suffix of the input list.
       )
implTryAddTxs :: MempoolEnv m blk
-> [GenTx blk]
-> m ([(GenTx blk, MempoolAddTxResult blk)], [GenTx blk])
implTryAddTxs MempoolEnv m blk
mpEnv = [(GenTx blk, MempoolAddTxResult blk)]
-> [GenTx blk]
-> m ([(GenTx blk, MempoolAddTxResult blk)], [GenTx blk])
go []
  where
    MempoolEnv
      { StrictTVar m (InternalState blk)
mpEnvStateVar :: StrictTVar m (InternalState blk)
mpEnvStateVar :: forall (m :: * -> *) blk.
MempoolEnv m blk -> StrictTVar m (InternalState blk)
mpEnvStateVar
      , mpEnvLedgerCfg :: forall (m :: * -> *) blk. MempoolEnv m blk -> LedgerConfig blk
mpEnvLedgerCfg = LedgerConfig blk
cfg
      , Tracer m (TraceEventMempool blk)
mpEnvTracer :: Tracer m (TraceEventMempool blk)
mpEnvTracer :: forall (m :: * -> *) blk.
MempoolEnv m blk -> Tracer m (TraceEventMempool blk)
mpEnvTracer
      , GenTx blk -> TxSizeInBytes
mpEnvTxSize :: GenTx blk -> TxSizeInBytes
mpEnvTxSize :: forall (m :: * -> *) blk.
MempoolEnv m blk -> GenTx blk -> TxSizeInBytes
mpEnvTxSize
      } = MempoolEnv m blk
mpEnv

    done :: [a] -> b -> m ([a], b)
done [a]
acc b
toAdd = ([a], b) -> m ([a], b)
forall (m :: * -> *) a. Monad m => a -> m a
return ([a] -> [a]
forall a. [a] -> [a]
reverse [a]
acc, b
toAdd)

    go :: [(GenTx blk, MempoolAddTxResult blk)]
-> [GenTx blk]
-> m ([(GenTx blk, MempoolAddTxResult blk)], [GenTx blk])
go [(GenTx blk, MempoolAddTxResult blk)]
acc []                     = [(GenTx blk, MempoolAddTxResult blk)]
-> [GenTx blk]
-> m ([(GenTx blk, MempoolAddTxResult blk)], [GenTx blk])
forall (m :: * -> *) a b. Monad m => [a] -> b -> m ([a], b)
done [(GenTx blk, MempoolAddTxResult blk)]
acc []
    go [(GenTx blk, MempoolAddTxResult blk)]
acc toAdd :: [GenTx blk]
toAdd@(GenTx blk
firstTx:[GenTx blk]
toAdd') =
        -- Note: we execute the continuation returned by 'atomically'
        m (m ([(GenTx blk, MempoolAddTxResult blk)], [GenTx blk]))
-> m ([(GenTx blk, MempoolAddTxResult blk)], [GenTx blk])
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (m (m ([(GenTx blk, MempoolAddTxResult blk)], [GenTx blk]))
 -> m ([(GenTx blk, MempoolAddTxResult blk)], [GenTx blk]))
-> m (m ([(GenTx blk, MempoolAddTxResult blk)], [GenTx blk]))
-> m ([(GenTx blk, MempoolAddTxResult blk)], [GenTx blk])
forall a b. (a -> b) -> a -> b
$ STM m (m ([(GenTx blk, MempoolAddTxResult blk)], [GenTx blk]))
-> m (m ([(GenTx blk, MempoolAddTxResult blk)], [GenTx blk]))
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (m ([(GenTx blk, MempoolAddTxResult blk)], [GenTx blk]))
 -> m (m ([(GenTx blk, MempoolAddTxResult blk)], [GenTx blk])))
-> STM m (m ([(GenTx blk, MempoolAddTxResult blk)], [GenTx blk]))
-> m (m ([(GenTx blk, MempoolAddTxResult blk)], [GenTx blk]))
forall a b. (a -> b) -> a -> b
$ StrictTVar m (InternalState blk) -> STM m (InternalState blk)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (InternalState blk)
mpEnvStateVar STM m (InternalState blk)
-> (InternalState blk
    -> STM m (m ([(GenTx blk, MempoolAddTxResult blk)], [GenTx blk])))
-> STM m (m ([(GenTx blk, MempoolAddTxResult blk)], [GenTx blk]))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= InternalState blk
-> STM m (m ([(GenTx blk, MempoolAddTxResult blk)], [GenTx blk]))
tryAdd
      where
        tryAdd :: InternalState blk
-> STM m (m ([(GenTx blk, MempoolAddTxResult blk)], [GenTx blk]))
tryAdd InternalState blk
is
          -- No space in the Mempool.
          | let firstTxSize :: TxSizeInBytes
firstTxSize = GenTx blk -> TxSizeInBytes
mpEnvTxSize GenTx blk
firstTx
                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
firstTxSize 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)
          = m ([(GenTx blk, MempoolAddTxResult blk)], [GenTx blk])
-> STM m (m ([(GenTx blk, MempoolAddTxResult blk)], [GenTx blk]))
forall (m :: * -> *) a. Monad m => a -> m a
return (m ([(GenTx blk, MempoolAddTxResult blk)], [GenTx blk])
 -> STM m (m ([(GenTx blk, MempoolAddTxResult blk)], [GenTx blk])))
-> m ([(GenTx blk, MempoolAddTxResult blk)], [GenTx blk])
-> STM m (m ([(GenTx blk, MempoolAddTxResult blk)], [GenTx blk]))
forall a b. (a -> b) -> a -> b
$ [(GenTx blk, MempoolAddTxResult blk)]
-> [GenTx blk]
-> m ([(GenTx blk, MempoolAddTxResult blk)], [GenTx blk])
forall (m :: * -> *) a b. Monad m => [a] -> b -> m ([a], b)
done [(GenTx blk, MempoolAddTxResult blk)]
acc [GenTx blk]
toAdd

          | Bool
otherwise
          = do
              let vr :: ValidationResult blk
vr  = LedgerConfig blk
-> GenTx blk
-> (GenTx blk -> TxSizeInBytes)
-> ValidationResult blk
-> ValidationResult blk
forall blk.
(LedgerSupportsMempool blk, HasTxId (GenTx blk)) =>
LedgerConfig blk
-> GenTx blk
-> (GenTx blk -> TxSizeInBytes)
-> ValidationResult blk
-> ValidationResult blk
extendVRNew LedgerConfig blk
cfg GenTx blk
firstTx GenTx blk -> TxSizeInBytes
mpEnvTxSize (ValidationResult blk -> ValidationResult blk)
-> ValidationResult blk -> ValidationResult blk
forall a b. (a -> b) -> a -> b
$
                          InternalState blk -> ValidationResult blk
forall blk. InternalState blk -> ValidationResult blk
validationResultFromIS InternalState blk
is
                  is' :: InternalState blk
is' = ValidationResult blk -> InternalState blk
forall blk. ValidationResult blk -> InternalState blk
internalStateFromVR ValidationResult blk
vr
              Bool -> STM m () -> STM m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Maybe (GenTx blk) -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (ValidationResult blk -> Maybe (GenTx blk)
forall blk. ValidationResult blk -> Maybe (GenTx blk)
vrNewValid ValidationResult blk
vr)) (STM m () -> STM m ()) -> STM m () -> STM m ()
forall a b. (a -> b) -> a -> b
$
                -- Each time we have found a valid transaction, we update the
                -- Mempool. This keeps our STM transactions short, avoiding
                -- repeated work.
                --
                -- Note that even if the transaction were invalid, we could
                -- still write the state, because in that case we would have
                -- that @is == is'@, but there's no reason to do that
                -- additional write.
                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)
mpEnvStateVar InternalState blk
is'

              -- We only extended the ValidationResult with a single
              -- transaction ('firstTx'). So if it's not in 'vrInvalid', it
              -- must be in 'vrNewValid'.
              m ([(GenTx blk, MempoolAddTxResult blk)], [GenTx blk])
-> STM m (m ([(GenTx blk, MempoolAddTxResult blk)], [GenTx blk]))
forall (m :: * -> *) a. Monad m => a -> m a
return (m ([(GenTx blk, MempoolAddTxResult blk)], [GenTx blk])
 -> STM m (m ([(GenTx blk, MempoolAddTxResult blk)], [GenTx blk])))
-> m ([(GenTx blk, MempoolAddTxResult blk)], [GenTx blk])
-> STM m (m ([(GenTx blk, MempoolAddTxResult blk)], [GenTx blk]))
forall a b. (a -> b) -> a -> b
$ case [(GenTx blk, ApplyTxErr blk)] -> Maybe (GenTx blk, ApplyTxErr blk)
forall a. [a] -> Maybe a
listToMaybe (ValidationResult blk -> [(GenTx blk, ApplyTxErr blk)]
forall blk. ValidationResult blk -> [(GenTx blk, ApplyTxErr blk)]
vrInvalid ValidationResult blk
vr) of
                -- The transaction was valid
                Maybe (GenTx blk, ApplyTxErr blk)
Nothing ->
                  Bool
-> m ([(GenTx blk, MempoolAddTxResult blk)], [GenTx blk])
-> m ([(GenTx blk, MempoolAddTxResult blk)], [GenTx blk])
forall a. HasCallStack => Bool -> a -> a
assert (Maybe (GenTx blk) -> Bool
forall a. Maybe a -> Bool
isJust (ValidationResult blk -> Maybe (GenTx blk)
forall blk. ValidationResult blk -> Maybe (GenTx blk)
vrNewValid ValidationResult blk
vr)) (m ([(GenTx blk, MempoolAddTxResult blk)], [GenTx blk])
 -> m ([(GenTx blk, MempoolAddTxResult blk)], [GenTx blk]))
-> m ([(GenTx blk, MempoolAddTxResult blk)], [GenTx blk])
-> m ([(GenTx blk, 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)
mpEnvTracer (TraceEventMempool blk -> m ()) -> TraceEventMempool blk -> m ()
forall a b. (a -> b) -> a -> b
$ GenTx blk -> MempoolSize -> MempoolSize -> TraceEventMempool blk
forall blk.
GenTx blk -> MempoolSize -> MempoolSize -> TraceEventMempool blk
TraceMempoolAddedTx
                      GenTx blk
firstTx
                      (InternalState blk -> MempoolSize
forall blk. InternalState blk -> MempoolSize
isMempoolSize InternalState blk
is)
                      (InternalState blk -> MempoolSize
forall blk. InternalState blk -> MempoolSize
isMempoolSize InternalState blk
is')
                    [(GenTx blk, MempoolAddTxResult blk)]
-> [GenTx blk]
-> m ([(GenTx blk, MempoolAddTxResult blk)], [GenTx blk])
go ((GenTx blk
firstTx, MempoolAddTxResult blk
forall blk. MempoolAddTxResult blk
MempoolTxAdded)(GenTx blk, MempoolAddTxResult blk)
-> [(GenTx blk, MempoolAddTxResult blk)]
-> [(GenTx blk, MempoolAddTxResult blk)]
forall a. a -> [a] -> [a]
:[(GenTx blk, MempoolAddTxResult blk)]
acc) [GenTx blk]
toAdd'
                Just (GenTx blk
_, ApplyTxErr blk
err) ->
                  Bool
-> m ([(GenTx blk, MempoolAddTxResult blk)], [GenTx blk])
-> m ([(GenTx blk, MempoolAddTxResult blk)], [GenTx blk])
forall a. HasCallStack => Bool -> a -> a
assert (Maybe (GenTx blk) -> Bool
forall a. Maybe a -> Bool
isNothing (ValidationResult blk -> Maybe (GenTx blk)
forall blk. ValidationResult blk -> Maybe (GenTx blk)
vrNewValid ValidationResult blk
vr))  (m ([(GenTx blk, MempoolAddTxResult blk)], [GenTx blk])
 -> m ([(GenTx blk, MempoolAddTxResult blk)], [GenTx blk]))
-> m ([(GenTx blk, MempoolAddTxResult blk)], [GenTx blk])
-> m ([(GenTx blk, MempoolAddTxResult blk)], [GenTx blk])
forall a b. (a -> b) -> a -> b
$
                  Bool
-> m ([(GenTx blk, MempoolAddTxResult blk)], [GenTx blk])
-> m ([(GenTx blk, MempoolAddTxResult blk)], [GenTx blk])
forall a. HasCallStack => Bool -> a -> a
assert ([(GenTx blk, ApplyTxErr blk)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (ValidationResult blk -> [(GenTx blk, ApplyTxErr blk)]
forall blk. ValidationResult blk -> [(GenTx blk, ApplyTxErr blk)]
vrInvalid ValidationResult blk
vr) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1) (m ([(GenTx blk, MempoolAddTxResult blk)], [GenTx blk])
 -> m ([(GenTx blk, MempoolAddTxResult blk)], [GenTx blk]))
-> m ([(GenTx blk, MempoolAddTxResult blk)], [GenTx blk])
-> m ([(GenTx blk, 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)
mpEnvTracer (TraceEventMempool blk -> m ()) -> TraceEventMempool blk -> m ()
forall a b. (a -> b) -> a -> b
$ GenTx blk -> ApplyTxErr blk -> MempoolSize -> TraceEventMempool blk
forall blk.
GenTx blk -> ApplyTxErr blk -> MempoolSize -> TraceEventMempool blk
TraceMempoolRejectedTx
                      GenTx blk
firstTx
                      ApplyTxErr blk
err
                      (InternalState blk -> MempoolSize
forall blk. InternalState blk -> MempoolSize
isMempoolSize InternalState blk
is)
                    [(GenTx blk, MempoolAddTxResult blk)]
-> [GenTx blk]
-> m ([(GenTx blk, MempoolAddTxResult blk)], [GenTx blk])
go
                      ((GenTx blk
firstTx, ApplyTxErr blk -> MempoolAddTxResult blk
forall blk. ApplyTxErr blk -> MempoolAddTxResult blk
MempoolTxRejected ApplyTxErr blk
err)(GenTx blk, MempoolAddTxResult blk)
-> [(GenTx blk, MempoolAddTxResult blk)]
-> [(GenTx blk, MempoolAddTxResult blk)]
forall a. a -> [a] -> [a]
:[(GenTx blk, MempoolAddTxResult blk)]
acc)
                      [GenTx blk]
toAdd'

implRemoveTxs
  :: ( IOLike m
     , LedgerSupportsMempool blk
     , HasTxId (GenTx blk)
     , ValidateEnvelope blk
     )
  => MempoolEnv m blk
  -> [GenTxId blk]
  -> m ()
implRemoveTxs :: MempoolEnv m blk -> [GenTxId blk] -> m ()
implRemoveTxs MempoolEnv m blk
mpEnv [GenTxId blk]
txIds = do
    ([GenTx blk]
removed, MempoolSize
mempoolSize) <- STM m ([GenTx blk], MempoolSize) -> m ([GenTx blk], MempoolSize)
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m ([GenTx blk], MempoolSize) -> m ([GenTx blk], MempoolSize))
-> STM m ([GenTx blk], MempoolSize) -> m ([GenTx blk], MempoolSize)
forall a b. (a -> b) -> a -> b
$ do
      IS { TxSeq (GenTx blk)
isTxs :: TxSeq (GenTx blk)
isTxs :: forall blk. InternalState blk -> TxSeq (GenTx blk)
isTxs, TicketNo
isLastTicketNo :: TicketNo
isLastTicketNo :: forall blk. InternalState blk -> TicketNo
isLastTicketNo } <- StrictTVar m (InternalState blk) -> STM m (InternalState blk)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (InternalState blk)
mpEnvStateVar
      LedgerState blk
st <- LedgerInterface m blk -> STM m (LedgerState blk)
forall (m :: * -> *) blk.
LedgerInterface m blk -> STM m (LedgerState blk)
getCurrentLedgerState LedgerInterface m blk
mpEnvLedger
      -- 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 txTickets' :: [TxTicket (GenTx blk)]
txTickets' = (TxTicket (GenTx blk) -> Bool)
-> [TxTicket (GenTx blk)] -> [TxTicket (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 (GenTx blk) -> GenTxId blk)
-> TxTicket (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 (GenTx blk) -> GenTx blk)
-> TxTicket (GenTx blk)
-> GenTxId blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxTicket (GenTx blk) -> GenTx blk
forall tx. TxTicket tx -> tx
txTicketTx)
              (TxSeq (GenTx blk) -> [TxTicket (GenTx blk)]
forall tx. TxSeq tx -> [TxTicket tx]
TxSeq.toList TxSeq (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
st)
          vr :: ValidationResult blk
vr = MempoolCapacityBytesOverride
-> LedgerConfig blk
-> SlotNo
-> TickedLedgerState blk
-> TicketNo
-> [TxTicket (GenTx blk)]
-> ValidationResult blk
forall blk.
(LedgerSupportsMempool blk, HasTxId (GenTx blk)) =>
MempoolCapacityBytesOverride
-> LedgerConfig blk
-> SlotNo
-> TickedLedgerState blk
-> TicketNo
-> [TxTicket (GenTx blk)]
-> ValidationResult blk
revalidateTxsFor
            MempoolCapacityBytesOverride
capacityOverride
            LedgerConfig blk
cfg
            SlotNo
slot
            TickedLedgerState blk
ticked
            TicketNo
isLastTicketNo
            [TxTicket (GenTx blk)]
txTickets'
          is' :: InternalState blk
is' = ValidationResult blk -> InternalState blk
forall blk. ValidationResult blk -> InternalState blk
internalStateFromVR ValidationResult blk
vr
      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)
mpEnvStateVar InternalState blk
is'
      ([GenTx blk], MempoolSize) -> STM m ([GenTx blk], MempoolSize)
forall (m :: * -> *) a. Monad m => a -> m a
return (((GenTx blk, ApplyTxErr blk) -> GenTx blk)
-> [(GenTx blk, ApplyTxErr blk)] -> [GenTx blk]
forall a b. (a -> b) -> [a] -> [b]
map (GenTx blk, ApplyTxErr blk) -> GenTx blk
forall a b. (a, b) -> a
fst (ValidationResult blk -> [(GenTx blk, ApplyTxErr blk)]
forall blk. ValidationResult blk -> [(GenTx blk, ApplyTxErr blk)]
vrInvalid ValidationResult blk
vr), InternalState blk -> MempoolSize
forall blk. InternalState blk -> MempoolSize
isMempoolSize InternalState blk
is')

    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([GenTxId blk] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GenTxId blk]
txIds) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
      Tracer m (TraceEventMempool blk) -> TraceEventMempool blk -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (TraceEventMempool blk)
mpEnvTracer (TraceEventMempool blk -> m ()) -> TraceEventMempool blk -> m ()
forall a b. (a -> b) -> a -> b
$
        [GenTxId blk]
-> [GenTx blk] -> MempoolSize -> TraceEventMempool blk
forall blk.
[GenTxId blk]
-> [GenTx blk] -> MempoolSize -> TraceEventMempool blk
TraceMempoolManuallyRemovedTxs [GenTxId blk]
txIds [GenTx blk]
removed MempoolSize
mempoolSize
  where
    MempoolEnv
      { mpEnvLedgerCfg :: forall (m :: * -> *) blk. MempoolEnv m blk -> LedgerConfig blk
mpEnvLedgerCfg = LedgerConfig blk
cfg
      , LedgerInterface m blk
mpEnvLedger :: LedgerInterface m blk
mpEnvLedger :: forall (m :: * -> *) blk. MempoolEnv m blk -> LedgerInterface m blk
mpEnvLedger
      , Tracer m (TraceEventMempool blk)
mpEnvTracer :: Tracer m (TraceEventMempool blk)
mpEnvTracer :: forall (m :: * -> *) blk.
MempoolEnv m blk -> Tracer m (TraceEventMempool blk)
mpEnvTracer
      , StrictTVar m (InternalState blk)
mpEnvStateVar :: StrictTVar m (InternalState blk)
mpEnvStateVar :: forall (m :: * -> *) blk.
MempoolEnv m blk -> StrictTVar m (InternalState blk)
mpEnvStateVar
      , mpEnvCapacityOverride :: forall (m :: * -> *) blk.
MempoolEnv m blk -> MempoolCapacityBytesOverride
mpEnvCapacityOverride = MempoolCapacityBytesOverride
capacityOverride
      } = MempoolEnv m blk
mpEnv

    toRemove :: Set (GenTxId blk)
toRemove = [GenTxId blk] -> Set (GenTxId blk)
forall a. Ord a => [a] -> Set a
Set.fromList [GenTxId blk]
txIds

implSyncWithLedger :: ( IOLike m
                      , LedgerSupportsMempool blk
                      , HasTxId (GenTx blk)
                      , ValidateEnvelope blk
                      )
                   => MempoolEnv m blk -> m (MempoolSnapshot blk TicketNo)
implSyncWithLedger :: MempoolEnv m blk -> m (MempoolSnapshot blk TicketNo)
implSyncWithLedger mpEnv :: MempoolEnv m blk
mpEnv@MempoolEnv{Tracer m (TraceEventMempool blk)
mpEnvTracer :: Tracer m (TraceEventMempool blk)
mpEnvTracer :: forall (m :: * -> *) blk.
MempoolEnv m blk -> Tracer m (TraceEventMempool blk)
mpEnvTracer, StrictTVar m (InternalState blk)
mpEnvStateVar :: StrictTVar m (InternalState blk)
mpEnvStateVar :: forall (m :: * -> *) blk.
MempoolEnv m blk -> StrictTVar m (InternalState blk)
mpEnvStateVar} = do
    ([GenTx blk]
removed, MempoolSize
mempoolSize, MempoolSnapshot blk TicketNo
snapshot) <- STM m ([GenTx blk], MempoolSize, MempoolSnapshot blk TicketNo)
-> m ([GenTx blk], MempoolSize, MempoolSnapshot blk TicketNo)
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m ([GenTx blk], MempoolSize, MempoolSnapshot blk TicketNo)
 -> m ([GenTx blk], MempoolSize, MempoolSnapshot blk TicketNo))
-> STM m ([GenTx blk], MempoolSize, MempoolSnapshot blk TicketNo)
-> m ([GenTx blk], MempoolSize, MempoolSnapshot blk TicketNo)
forall a b. (a -> b) -> a -> b
$ do
      ValidationResult blk
vr <- MempoolEnv m blk -> STM m (ValidationResult blk)
forall (m :: * -> *) blk.
(IOLike m, LedgerSupportsMempool blk, HasTxId (GenTx blk),
 ValidateEnvelope blk) =>
MempoolEnv m blk -> STM m (ValidationResult blk)
validateIS MempoolEnv m blk
mpEnv
      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)
mpEnvStateVar (ValidationResult blk -> InternalState blk
forall blk. ValidationResult blk -> InternalState blk
internalStateFromVR ValidationResult blk
vr)
      -- The size of the mempool /after/ removing invalid transactions.
      MempoolSize
mempoolSize <- MempoolEnv m blk -> STM m MempoolSize
forall (m :: * -> *) blk.
IOLike m =>
MempoolEnv m blk -> STM m MempoolSize
getMempoolSize MempoolEnv m blk
mpEnv
      MempoolSnapshot blk TicketNo
snapshot    <- MempoolEnv m blk -> STM m (MempoolSnapshot blk TicketNo)
forall (m :: * -> *) blk.
(IOLike m, HasTxId (GenTx blk)) =>
MempoolEnv m blk -> STM m (MempoolSnapshot blk TicketNo)
implGetSnapshot MempoolEnv m blk
mpEnv
      ([GenTx blk], MempoolSize, MempoolSnapshot blk TicketNo)
-> STM m ([GenTx blk], MempoolSize, MempoolSnapshot blk TicketNo)
forall (m :: * -> *) a. Monad m => a -> m a
return (((GenTx blk, ApplyTxErr blk) -> GenTx blk)
-> [(GenTx blk, ApplyTxErr blk)] -> [GenTx blk]
forall a b. (a -> b) -> [a] -> [b]
map (GenTx blk, ApplyTxErr blk) -> GenTx blk
forall a b. (a, b) -> a
fst (ValidationResult blk -> [(GenTx blk, ApplyTxErr blk)]
forall blk. ValidationResult blk -> [(GenTx blk, ApplyTxErr blk)]
vrInvalid ValidationResult blk
vr), MempoolSize
mempoolSize, MempoolSnapshot blk TicketNo
snapshot)
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([GenTx blk] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GenTx blk]
removed) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
      Tracer m (TraceEventMempool blk) -> TraceEventMempool blk -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (TraceEventMempool blk)
mpEnvTracer (TraceEventMempool blk -> m ()) -> TraceEventMempool blk -> m ()
forall a b. (a -> b) -> a -> b
$ [GenTx blk] -> MempoolSize -> TraceEventMempool blk
forall blk. [GenTx blk] -> MempoolSize -> TraceEventMempool blk
TraceMempoolRemoveTxs [GenTx blk]
removed MempoolSize
mempoolSize
    MempoolSnapshot blk TicketNo -> m (MempoolSnapshot blk TicketNo)
forall (m :: * -> *) a. Monad m => a -> m a
return MempoolSnapshot blk TicketNo
snapshot

implGetSnapshot :: (IOLike m, HasTxId (GenTx blk))
                => MempoolEnv m blk
                -> STM m (MempoolSnapshot blk TicketNo)
implGetSnapshot :: MempoolEnv m blk -> STM m (MempoolSnapshot blk TicketNo)
implGetSnapshot MempoolEnv{StrictTVar m (InternalState blk)
mpEnvStateVar :: StrictTVar m (InternalState blk)
mpEnvStateVar :: forall (m :: * -> *) blk.
MempoolEnv m blk -> StrictTVar m (InternalState blk)
mpEnvStateVar} =
    InternalState blk -> MempoolSnapshot blk TicketNo
forall blk.
HasTxId (GenTx blk) =>
InternalState blk -> MempoolSnapshot blk TicketNo
implSnapshotFromIS (InternalState blk -> MempoolSnapshot blk TicketNo)
-> STM m (InternalState blk)
-> STM m (MempoolSnapshot blk TicketNo)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictTVar m (InternalState blk) -> STM m (InternalState blk)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (InternalState blk)
mpEnvStateVar

implGetSnapshotFor :: forall m blk.
                      ( IOLike m
                      , LedgerSupportsMempool blk
                      , HasTxId (GenTx blk)
                      , ValidateEnvelope blk
                      )
                   => MempoolEnv m blk
                   -> ForgeLedgerState blk
                   -> STM m (MempoolSnapshot blk TicketNo)
implGetSnapshotFor :: MempoolEnv m blk
-> ForgeLedgerState blk -> STM m (MempoolSnapshot blk TicketNo)
implGetSnapshotFor MempoolEnv m blk
mpEnv ForgeLedgerState blk
blockLedgerState =
    InternalState blk -> MempoolSnapshot blk TicketNo
updatedSnapshot (InternalState blk -> MempoolSnapshot blk TicketNo)
-> STM m (InternalState blk)
-> STM m (MempoolSnapshot blk TicketNo)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictTVar m (InternalState blk) -> STM m (InternalState blk)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (InternalState blk)
mpEnvStateVar
  where
    MempoolEnv
      { StrictTVar m (InternalState blk)
mpEnvStateVar :: StrictTVar m (InternalState blk)
mpEnvStateVar :: forall (m :: * -> *) blk.
MempoolEnv m blk -> StrictTVar m (InternalState blk)
mpEnvStateVar
      , LedgerConfig blk
mpEnvLedgerCfg :: LedgerConfig blk
mpEnvLedgerCfg :: forall (m :: * -> *) blk. MempoolEnv m blk -> LedgerConfig blk
mpEnvLedgerCfg
      , mpEnvCapacityOverride :: forall (m :: * -> *) blk.
MempoolEnv m blk -> MempoolCapacityBytesOverride
mpEnvCapacityOverride = MempoolCapacityBytesOverride
capacityOverride
      } = MempoolEnv m blk
mpEnv

    updatedSnapshot :: InternalState blk -> MempoolSnapshot blk TicketNo
    updatedSnapshot :: InternalState blk -> MempoolSnapshot blk TicketNo
updatedSnapshot =
          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 blk -> InternalState blk
forall blk. ValidationResult blk -> InternalState blk
internalStateFromVR
        (ValidationResult blk -> InternalState blk)
-> (InternalState blk -> ValidationResult blk)
-> InternalState blk
-> InternalState blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MempoolCapacityBytesOverride
-> LedgerConfig blk
-> ForgeLedgerState blk
-> InternalState blk
-> ValidationResult blk
forall blk.
(LedgerSupportsMempool blk, HasTxId (GenTx blk),
 ValidateEnvelope blk) =>
MempoolCapacityBytesOverride
-> LedgerConfig blk
-> ForgeLedgerState blk
-> InternalState blk
-> ValidationResult blk
validateStateFor MempoolCapacityBytesOverride
capacityOverride LedgerConfig blk
mpEnvLedgerCfg ForgeLedgerState blk
blockLedgerState

-- | \( O(1) \). Return the cached value of the current capacity of the
-- mempool in bytes.
implGetCapacity :: IOLike m => MempoolEnv m blk -> STM m MempoolCapacityBytes
implGetCapacity :: MempoolEnv m blk -> STM m MempoolCapacityBytes
implGetCapacity MempoolEnv{StrictTVar m (InternalState blk)
mpEnvStateVar :: StrictTVar m (InternalState blk)
mpEnvStateVar :: forall (m :: * -> *) blk.
MempoolEnv m blk -> StrictTVar m (InternalState blk)
mpEnvStateVar} =
    InternalState blk -> MempoolCapacityBytes
forall blk. InternalState blk -> MempoolCapacityBytes
isCapacity (InternalState blk -> MempoolCapacityBytes)
-> STM m (InternalState blk) -> STM m MempoolCapacityBytes
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictTVar m (InternalState blk) -> STM m (InternalState blk)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (InternalState blk)
mpEnvStateVar

-- | \( O(1) \). Return the number of transactions in the Mempool paired with
-- their total size in bytes.
getMempoolSize :: IOLike m
               => MempoolEnv m blk
               -> STM m MempoolSize
getMempoolSize :: MempoolEnv m blk -> STM m MempoolSize
getMempoolSize MempoolEnv{StrictTVar m (InternalState blk)
mpEnvStateVar :: StrictTVar m (InternalState blk)
mpEnvStateVar :: forall (m :: * -> *) blk.
MempoolEnv m blk -> StrictTVar m (InternalState blk)
mpEnvStateVar} =
    InternalState blk -> MempoolSize
forall blk. InternalState blk -> MempoolSize
isMempoolSize (InternalState blk -> MempoolSize)
-> STM m (InternalState blk) -> STM m MempoolSize
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictTVar m (InternalState blk) -> STM m (InternalState blk)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (InternalState blk)
mpEnvStateVar

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

implSnapshotFromIS :: HasTxId (GenTx blk)
                   => InternalState blk
                   -> MempoolSnapshot blk TicketNo
implSnapshotFromIS :: InternalState blk -> MempoolSnapshot blk TicketNo
implSnapshotFromIS InternalState blk
is = MempoolSnapshot :: forall blk idx.
[(GenTx blk, idx)]
-> (idx -> [(GenTx blk, idx)])
-> (TxSizeInBytes -> [(GenTx blk, idx)])
-> (idx -> Maybe (GenTx blk))
-> (GenTxId blk -> Bool)
-> MempoolSize
-> SlotNo
-> TickedLedgerState blk
-> MempoolSnapshot blk idx
MempoolSnapshot {
      snapshotTxs :: [(GenTx blk, TicketNo)]
snapshotTxs         = InternalState blk -> [(GenTx blk, TicketNo)]
forall blk. InternalState blk -> [(GenTx blk, TicketNo)]
implSnapshotGetTxs         InternalState blk
is
    , snapshotTxsAfter :: TicketNo -> [(GenTx blk, TicketNo)]
snapshotTxsAfter    = InternalState blk -> TicketNo -> [(GenTx blk, TicketNo)]
forall blk.
InternalState blk -> TicketNo -> [(GenTx blk, TicketNo)]
implSnapshotGetTxsAfter    InternalState blk
is
    , snapshotTxsForSize :: TxSizeInBytes -> [(GenTx blk, TicketNo)]
snapshotTxsForSize  = InternalState blk -> TxSizeInBytes -> [(GenTx blk, TicketNo)]
forall blk.
InternalState blk -> TxSizeInBytes -> [(GenTx blk, TicketNo)]
implSnapshotGetTxsForSize  InternalState blk
is
    , snapshotLookupTx :: TicketNo -> Maybe (GenTx blk)
snapshotLookupTx    = InternalState blk -> TicketNo -> Maybe (GenTx blk)
forall blk. InternalState blk -> TicketNo -> Maybe (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
    }

implSnapshotGetTxs :: InternalState blk
                   -> [(GenTx blk, TicketNo)]
implSnapshotGetTxs :: InternalState blk -> [(GenTx blk, TicketNo)]
implSnapshotGetTxs = ((InternalState blk -> TicketNo -> [(GenTx blk, TicketNo)])
-> TicketNo -> InternalState blk -> [(GenTx blk, TicketNo)]
forall a b c. (a -> b -> c) -> b -> a -> c
flip InternalState blk -> TicketNo -> [(GenTx blk, TicketNo)]
forall blk.
InternalState blk -> TicketNo -> [(GenTx blk, TicketNo)]
implSnapshotGetTxsAfter) TicketNo
zeroTicketNo

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

implSnapshotGetTxsForSize :: InternalState blk
                          -> Word32
                          -> [(GenTx blk, TicketNo)]
implSnapshotGetTxsForSize :: InternalState blk -> TxSizeInBytes -> [(GenTx blk, TicketNo)]
implSnapshotGetTxsForSize IS{TxSeq (GenTx blk)
isTxs :: TxSeq (GenTx blk)
isTxs :: forall blk. InternalState blk -> TxSeq (GenTx blk)
isTxs} TxSizeInBytes
maxSize =
    TxSeq (GenTx blk) -> [(GenTx blk, TicketNo)]
forall tx. TxSeq tx -> [(tx, TicketNo)]
TxSeq.toTuples (TxSeq (GenTx blk) -> [(GenTx blk, TicketNo)])
-> TxSeq (GenTx blk) -> [(GenTx blk, TicketNo)]
forall a b. (a -> b) -> a -> b
$ (TxSeq (GenTx blk), TxSeq (GenTx blk)) -> TxSeq (GenTx blk)
forall a b. (a, b) -> a
fst ((TxSeq (GenTx blk), TxSeq (GenTx blk)) -> TxSeq (GenTx blk))
-> (TxSeq (GenTx blk), TxSeq (GenTx blk)) -> TxSeq (GenTx blk)
forall a b. (a -> b) -> a -> b
$ TxSeq (GenTx blk)
-> TxSizeInBytes -> (TxSeq (GenTx blk), TxSeq (GenTx blk))
forall tx. TxSeq tx -> TxSizeInBytes -> (TxSeq tx, TxSeq tx)
TxSeq.splitAfterTxSize TxSeq (GenTx blk)
isTxs TxSizeInBytes
maxSize

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

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

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

{-------------------------------------------------------------------------------
  Validation
-------------------------------------------------------------------------------}

data ValidationResult blk = ValidationResult {
    -- | The tip of the chain before applying these transactions
    ValidationResult blk -> ChainHash blk
vrBeforeTip      :: ChainHash blk

    -- | The slot number of the (imaginary) block the txs will be placed in
  , ValidationResult blk -> SlotNo
vrSlotNo         :: SlotNo

    -- | Capacity of the Mempool. Corresponds to 'vrBeforeTip' and
    -- 'vrBeforeSlotNo', /not/ 'vrAfter'.
  , ValidationResult blk -> MempoolCapacityBytes
vrBeforeCapacity :: MempoolCapacityBytes

    -- | The transactions that were found to be valid (oldest to newest)
  , ValidationResult blk -> TxSeq (GenTx blk)
vrValid          :: TxSeq (GenTx blk)

    -- | The cached IDs of transactions that were found to be valid (oldest to
    -- newest)
  , ValidationResult blk -> Set (GenTxId blk)
vrValidTxIds     :: Set (GenTxId blk)

    -- | A new transaction (not previously known) which was found to be valid.
    --
    -- n.b. This will only contain a valid transaction that was /newly/ added
    -- to the mempool (not a previously known valid transaction).
  , ValidationResult blk -> Maybe (GenTx blk)
vrNewValid       :: Maybe (GenTx blk)

    -- | The state of the ledger after applying 'vrValid' against the ledger
    -- state identifeid by 'vrBeforeTip'.
  , ValidationResult blk -> TickedLedgerState blk
vrAfter          :: TickedLedgerState blk

    -- | The transactions that were invalid, along with their errors
    --
    -- From oldest to newest.
  , ValidationResult blk -> [(GenTx blk, ApplyTxErr blk)]
vrInvalid        :: [(GenTx blk, ApplyTxErr blk)]

    -- | The mempool 'TicketNo' counter.
    --
    -- When validating new transactions, this should be incremented, starting
    -- from 'isLastTicketNo' of the 'InternalState'.
    -- When validating previously applied transactions, this field should not
    -- be affected.
  , ValidationResult blk -> TicketNo
vrLastTicketNo   :: TicketNo
  }

-- | Construct internal state from 'ValidationResult'
--
-- Discards information about invalid and newly valid transactions
internalStateFromVR :: ValidationResult blk -> InternalState blk
internalStateFromVR :: ValidationResult blk -> InternalState blk
internalStateFromVR ValidationResult blk
vr = IS :: forall blk.
TxSeq (GenTx blk)
-> Set (GenTxId blk)
-> TickedLedgerState blk
-> ChainHash blk
-> SlotNo
-> TicketNo
-> MempoolCapacityBytes
-> InternalState blk
IS {
      isTxs :: TxSeq (GenTx blk)
isTxs          = TxSeq (GenTx blk)
vrValid
    , isTxIds :: Set (GenTxId blk)
isTxIds        = Set (GenTxId blk)
vrValidTxIds
    , isLedgerState :: TickedLedgerState blk
isLedgerState  = TickedLedgerState blk
vrAfter
    , isTip :: ChainHash blk
isTip          = ChainHash blk
vrBeforeTip
    , isSlotNo :: SlotNo
isSlotNo       = SlotNo
vrSlotNo
    , isLastTicketNo :: TicketNo
isLastTicketNo = TicketNo
vrLastTicketNo
    , isCapacity :: MempoolCapacityBytes
isCapacity     = MempoolCapacityBytes
vrBeforeCapacity
    }
  where
    ValidationResult {
        ChainHash blk
vrBeforeTip :: ChainHash blk
vrBeforeTip :: forall blk. ValidationResult blk -> ChainHash blk
vrBeforeTip
      , SlotNo
vrSlotNo :: SlotNo
vrSlotNo :: forall blk. ValidationResult blk -> SlotNo
vrSlotNo
      , MempoolCapacityBytes
vrBeforeCapacity :: MempoolCapacityBytes
vrBeforeCapacity :: forall blk. ValidationResult blk -> MempoolCapacityBytes
vrBeforeCapacity
      , TxSeq (GenTx blk)
vrValid :: TxSeq (GenTx blk)
vrValid :: forall blk. ValidationResult blk -> TxSeq (GenTx blk)
vrValid
      , Set (GenTxId blk)
vrValidTxIds :: Set (GenTxId blk)
vrValidTxIds :: forall blk. ValidationResult blk -> Set (GenTxId blk)
vrValidTxIds
      , TickedLedgerState blk
vrAfter :: TickedLedgerState blk
vrAfter :: forall blk. ValidationResult blk -> TickedLedgerState blk
vrAfter
      , TicketNo
vrLastTicketNo :: TicketNo
vrLastTicketNo :: forall blk. ValidationResult blk -> TicketNo
vrLastTicketNo
      } = ValidationResult blk
vr

-- | Construct a 'ValidationResult' from internal state.
validationResultFromIS :: InternalState blk -> ValidationResult blk
validationResultFromIS :: InternalState blk -> ValidationResult blk
validationResultFromIS InternalState blk
is = ValidationResult :: forall blk.
ChainHash blk
-> SlotNo
-> MempoolCapacityBytes
-> TxSeq (GenTx blk)
-> Set (GenTxId blk)
-> Maybe (GenTx blk)
-> TickedLedgerState blk
-> [(GenTx blk, ApplyTxErr blk)]
-> TicketNo
-> ValidationResult blk
ValidationResult {
      vrBeforeTip :: ChainHash blk
vrBeforeTip      = ChainHash blk
isTip
    , vrSlotNo :: SlotNo
vrSlotNo         = SlotNo
isSlotNo
    , vrBeforeCapacity :: MempoolCapacityBytes
vrBeforeCapacity = MempoolCapacityBytes
isCapacity
    , vrValid :: TxSeq (GenTx blk)
vrValid          = TxSeq (GenTx blk)
isTxs
    , vrValidTxIds :: Set (GenTxId blk)
vrValidTxIds     = Set (GenTxId blk)
isTxIds
    , vrNewValid :: Maybe (GenTx blk)
vrNewValid       = Maybe (GenTx blk)
forall a. Maybe a
Nothing
    , vrAfter :: TickedLedgerState blk
vrAfter          = TickedLedgerState blk
isLedgerState
    , vrInvalid :: [(GenTx blk, ApplyTxErr blk)]
vrInvalid        = []
    , vrLastTicketNo :: TicketNo
vrLastTicketNo   = TicketNo
isLastTicketNo
    }
  where
    IS {
        TxSeq (GenTx blk)
isTxs :: TxSeq (GenTx blk)
isTxs :: forall blk. InternalState blk -> TxSeq (GenTx blk)
isTxs
      , Set (GenTxId blk)
isTxIds :: Set (GenTxId blk)
isTxIds :: forall blk. InternalState blk -> Set (GenTxId blk)
isTxIds
      , TickedLedgerState blk
isLedgerState :: TickedLedgerState blk
isLedgerState :: forall blk. InternalState blk -> TickedLedgerState blk
isLedgerState
      , ChainHash blk
isTip :: ChainHash blk
isTip :: forall blk. InternalState blk -> ChainHash blk
isTip
      , SlotNo
isSlotNo :: SlotNo
isSlotNo :: forall blk. InternalState blk -> SlotNo
isSlotNo
      , TicketNo
isLastTicketNo :: TicketNo
isLastTicketNo :: forall blk. InternalState blk -> TicketNo
isLastTicketNo
      , MempoolCapacityBytes
isCapacity :: MempoolCapacityBytes
isCapacity :: forall blk. InternalState blk -> MempoolCapacityBytes
isCapacity
      } = InternalState blk
is

-- | Extend 'ValidationResult' with a previously validated transaction that
-- may or may not be valid in this ledger state
--
-- n.b. Even previously validated transactions may not be valid in a different
-- ledger state;  it is /still/ useful to indicate whether we have previously
-- validated this transaction because, if we have, we can utilize 'reapplyTx'
-- rather than 'applyTx' and, therefore, skip things like cryptographic
-- signatures.
extendVRPrevApplied :: (LedgerSupportsMempool blk, HasTxId (GenTx blk))
                    => LedgerConfig blk
                    -> TxTicket (GenTx blk)
                    -> ValidationResult blk
                    -> ValidationResult blk
extendVRPrevApplied :: LedgerConfig blk
-> TxTicket (GenTx blk)
-> ValidationResult blk
-> ValidationResult blk
extendVRPrevApplied LedgerConfig blk
cfg TxTicket (GenTx blk)
txTicket ValidationResult blk
vr =
    case Except (ApplyTxErr blk) (TickedLedgerState blk)
-> Either (ApplyTxErr blk) (TickedLedgerState blk)
forall e a. Except e a -> Either e a
runExcept (LedgerConfig blk
-> SlotNo
-> GenTx blk
-> TickedLedgerState blk
-> Except (ApplyTxErr blk) (TickedLedgerState blk)
forall blk.
(LedgerSupportsMempool blk, HasCallStack) =>
LedgerConfig blk
-> SlotNo
-> GenTx blk
-> TickedLedgerState blk
-> Except (ApplyTxErr blk) (TickedLedgerState blk)
reapplyTx LedgerConfig blk
cfg SlotNo
vrSlotNo GenTx blk
tx TickedLedgerState blk
vrAfter) of
      Left ApplyTxErr blk
err  -> ValidationResult blk
vr { vrInvalid :: [(GenTx blk, ApplyTxErr blk)]
vrInvalid = (GenTx blk
tx, ApplyTxErr blk
err) (GenTx blk, ApplyTxErr blk)
-> [(GenTx blk, ApplyTxErr blk)] -> [(GenTx blk, ApplyTxErr blk)]
forall a. a -> [a] -> [a]
: [(GenTx blk, ApplyTxErr blk)]
vrInvalid
                      }
      Right TickedLedgerState blk
st' -> ValidationResult blk
vr { vrValid :: TxSeq (GenTx blk)
vrValid      = TxSeq (GenTx blk)
vrValid TxSeq (GenTx blk) -> TxTicket (GenTx blk) -> TxSeq (GenTx blk)
forall tx. TxSeq tx -> TxTicket tx -> TxSeq tx
:> TxTicket (GenTx blk)
txTicket
                      , vrValidTxIds :: Set (GenTxId blk)
vrValidTxIds = GenTxId blk -> Set (GenTxId blk) -> Set (GenTxId blk)
forall a. Ord a => a -> Set a -> Set a
Set.insert (GenTx blk -> GenTxId blk
forall tx. HasTxId tx => tx -> TxId tx
txId GenTx blk
tx) Set (GenTxId blk)
vrValidTxIds
                      , vrAfter :: TickedLedgerState blk
vrAfter      = TickedLedgerState blk
st'
                      }
  where
    TxTicket { txTicketTx :: forall tx. TxTicket tx -> tx
txTicketTx = GenTx blk
tx } = TxTicket (GenTx blk)
txTicket
    ValidationResult { TxSeq (GenTx blk)
vrValid :: TxSeq (GenTx blk)
vrValid :: forall blk. ValidationResult blk -> TxSeq (GenTx blk)
vrValid, SlotNo
vrSlotNo :: SlotNo
vrSlotNo :: forall blk. ValidationResult blk -> SlotNo
vrSlotNo, Set (GenTxId blk)
vrValidTxIds :: Set (GenTxId blk)
vrValidTxIds :: forall blk. ValidationResult blk -> Set (GenTxId blk)
vrValidTxIds, TickedLedgerState blk
vrAfter :: TickedLedgerState blk
vrAfter :: forall blk. ValidationResult blk -> TickedLedgerState blk
vrAfter, [(GenTx blk, ApplyTxErr blk)]
vrInvalid :: [(GenTx blk, ApplyTxErr blk)]
vrInvalid :: forall blk. ValidationResult blk -> [(GenTx blk, ApplyTxErr blk)]
vrInvalid } = ValidationResult blk
vr

-- | Extend 'ValidationResult' with a new transaction (one which we have not
-- previously validated) that may or may not be valid in this ledger state.
--
-- PRECONDITION: 'vrNewValid' is 'Nothing'. In other words: new transactions
-- should be validated one-by-one, not by calling 'extendVRNew' on its result
-- again.
extendVRNew :: (LedgerSupportsMempool blk, HasTxId (GenTx blk))
            => LedgerConfig blk
            -> GenTx blk
            -> (GenTx blk -> TxSizeInBytes)
            -> ValidationResult blk
            -> ValidationResult blk
extendVRNew :: LedgerConfig blk
-> GenTx blk
-> (GenTx blk -> TxSizeInBytes)
-> ValidationResult blk
-> ValidationResult blk
extendVRNew LedgerConfig blk
cfg GenTx blk
tx GenTx blk -> TxSizeInBytes
txSize ValidationResult blk
vr = Bool -> ValidationResult blk -> ValidationResult blk
forall a. HasCallStack => Bool -> a -> a
assert (Maybe (GenTx blk) -> Bool
forall a. Maybe a -> Bool
isNothing Maybe (GenTx blk)
vrNewValid) (ValidationResult blk -> ValidationResult blk)
-> ValidationResult blk -> ValidationResult blk
forall a b. (a -> b) -> a -> b
$
    case Except (ApplyTxErr blk) (TickedLedgerState blk)
-> Either (ApplyTxErr blk) (TickedLedgerState blk)
forall e a. Except e a -> Either e a
runExcept (LedgerConfig blk
-> SlotNo
-> GenTx blk
-> TickedLedgerState blk
-> Except (ApplyTxErr blk) (TickedLedgerState blk)
forall blk.
LedgerSupportsMempool blk =>
LedgerConfig blk
-> SlotNo
-> GenTx blk
-> TickedLedgerState blk
-> Except (ApplyTxErr blk) (TickedLedgerState blk)
applyTx LedgerConfig blk
cfg SlotNo
vrSlotNo GenTx blk
tx TickedLedgerState blk
vrAfter) of
      Left ApplyTxErr blk
err  -> ValidationResult blk
vr { vrInvalid :: [(GenTx blk, ApplyTxErr blk)]
vrInvalid      = (GenTx blk
tx, ApplyTxErr blk
err) (GenTx blk, ApplyTxErr blk)
-> [(GenTx blk, ApplyTxErr blk)] -> [(GenTx blk, ApplyTxErr blk)]
forall a. a -> [a] -> [a]
: [(GenTx blk, ApplyTxErr blk)]
vrInvalid
                      }
      Right TickedLedgerState blk
st' -> ValidationResult blk
vr { vrValid :: TxSeq (GenTx blk)
vrValid        = TxSeq (GenTx blk)
vrValid TxSeq (GenTx blk) -> TxTicket (GenTx blk) -> TxSeq (GenTx blk)
forall tx. TxSeq tx -> TxTicket tx -> TxSeq tx
:> GenTx blk -> TicketNo -> TxSizeInBytes -> TxTicket (GenTx blk)
forall tx. tx -> TicketNo -> TxSizeInBytes -> TxTicket tx
TxTicket GenTx blk
tx TicketNo
nextTicketNo (GenTx blk -> TxSizeInBytes
txSize GenTx blk
tx)
                      , vrValidTxIds :: Set (GenTxId blk)
vrValidTxIds   = GenTxId blk -> Set (GenTxId blk) -> Set (GenTxId blk)
forall a. Ord a => a -> Set a -> Set a
Set.insert (GenTx blk -> GenTxId blk
forall tx. HasTxId tx => tx -> TxId tx
txId GenTx blk
tx) Set (GenTxId blk)
vrValidTxIds
                      , vrNewValid :: Maybe (GenTx blk)
vrNewValid     = GenTx blk -> Maybe (GenTx blk)
forall a. a -> Maybe a
Just GenTx blk
tx
                      , vrAfter :: TickedLedgerState blk
vrAfter        = TickedLedgerState blk
st'
                      , vrLastTicketNo :: TicketNo
vrLastTicketNo = TicketNo
nextTicketNo
                      }
  where
    ValidationResult {
        TxSeq (GenTx blk)
vrValid :: TxSeq (GenTx blk)
vrValid :: forall blk. ValidationResult blk -> TxSeq (GenTx blk)
vrValid
      , Set (GenTxId blk)
vrValidTxIds :: Set (GenTxId blk)
vrValidTxIds :: forall blk. ValidationResult blk -> Set (GenTxId blk)
vrValidTxIds
      , TickedLedgerState blk
vrAfter :: TickedLedgerState blk
vrAfter :: forall blk. ValidationResult blk -> TickedLedgerState blk
vrAfter
      , [(GenTx blk, ApplyTxErr blk)]
vrInvalid :: [(GenTx blk, ApplyTxErr blk)]
vrInvalid :: forall blk. ValidationResult blk -> [(GenTx blk, ApplyTxErr blk)]
vrInvalid
      , TicketNo
vrLastTicketNo :: TicketNo
vrLastTicketNo :: forall blk. ValidationResult blk -> TicketNo
vrLastTicketNo
      , Maybe (GenTx blk)
vrNewValid :: Maybe (GenTx blk)
vrNewValid :: forall blk. ValidationResult blk -> Maybe (GenTx blk)
vrNewValid
      , SlotNo
vrSlotNo :: SlotNo
vrSlotNo :: forall blk. ValidationResult blk -> SlotNo
vrSlotNo
      } = ValidationResult blk
vr

    nextTicketNo :: TicketNo
nextTicketNo = TicketNo -> TicketNo
forall a. Enum a => a -> a
succ TicketNo
vrLastTicketNo

-- | Validate the internal state against the current ledger state and the
-- given 'BlockSlot', revalidating if necessary.
validateIS :: forall m blk.
              ( IOLike m
              , LedgerSupportsMempool blk
              , HasTxId (GenTx blk)
              , ValidateEnvelope blk
              )
           => MempoolEnv m blk
           -> STM m (ValidationResult blk)
validateIS :: MempoolEnv m blk -> STM m (ValidationResult blk)
validateIS MempoolEnv m blk
mpEnv =
    MempoolCapacityBytesOverride
-> LedgerConfig blk
-> ForgeLedgerState blk
-> InternalState blk
-> ValidationResult blk
forall blk.
(LedgerSupportsMempool blk, HasTxId (GenTx blk),
 ValidateEnvelope blk) =>
MempoolCapacityBytesOverride
-> LedgerConfig blk
-> ForgeLedgerState blk
-> InternalState blk
-> ValidationResult blk
validateStateFor MempoolCapacityBytesOverride
capacityOverride LedgerConfig blk
mpEnvLedgerCfg
      (ForgeLedgerState blk -> InternalState blk -> ValidationResult blk)
-> STM m (ForgeLedgerState blk)
-> STM m (InternalState blk -> ValidationResult blk)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (LedgerState blk -> ForgeLedgerState blk
forall blk. LedgerState blk -> ForgeLedgerState blk
ForgeInUnknownSlot (LedgerState blk -> ForgeLedgerState blk)
-> STM m (LedgerState blk) -> STM m (ForgeLedgerState blk)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LedgerInterface m blk -> STM m (LedgerState blk)
forall (m :: * -> *) blk.
LedgerInterface m blk -> STM m (LedgerState blk)
getCurrentLedgerState LedgerInterface m blk
mpEnvLedger)
      STM m (InternalState blk -> ValidationResult blk)
-> STM m (InternalState blk) -> STM m (ValidationResult blk)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> StrictTVar m (InternalState blk) -> STM m (InternalState blk)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (InternalState blk)
mpEnvStateVar
  where
    MempoolEnv {
        LedgerInterface m blk
mpEnvLedger :: LedgerInterface m blk
mpEnvLedger :: forall (m :: * -> *) blk. MempoolEnv m blk -> LedgerInterface m blk
mpEnvLedger
      , LedgerConfig blk
mpEnvLedgerCfg :: LedgerConfig blk
mpEnvLedgerCfg :: forall (m :: * -> *) blk. MempoolEnv m blk -> LedgerConfig blk
mpEnvLedgerCfg
      , StrictTVar m (InternalState blk)
mpEnvStateVar :: StrictTVar m (InternalState blk)
mpEnvStateVar :: forall (m :: * -> *) blk.
MempoolEnv m blk -> StrictTVar m (InternalState blk)
mpEnvStateVar
      , mpEnvCapacityOverride :: forall (m :: * -> *) blk.
MempoolEnv m blk -> MempoolCapacityBytesOverride
mpEnvCapacityOverride = MempoolCapacityBytesOverride
capacityOverride
      } = MempoolEnv m blk
mpEnv

-- | Given a (valid) internal state, validate it against the given ledger
-- state and 'BlockSlot'.
--
-- When these match the internal state's 'isTip' and 'isSlotNo', this is very
-- cheap, as the given internal state will already be valid against the given
-- inputs.
--
-- When these don't match, the transaction in the internal state will be
-- revalidated ('revalidateTxsFor').
validateStateFor
  :: (LedgerSupportsMempool blk, HasTxId (GenTx blk), ValidateEnvelope blk)
  => MempoolCapacityBytesOverride
  -> LedgerConfig     blk
  -> ForgeLedgerState blk
  -> InternalState    blk
  -> ValidationResult blk
validateStateFor :: MempoolCapacityBytesOverride
-> LedgerConfig blk
-> ForgeLedgerState blk
-> InternalState blk
-> ValidationResult blk
validateStateFor MempoolCapacityBytesOverride
capacityOverride LedgerConfig blk
cfg ForgeLedgerState blk
blockLedgerState InternalState blk
is
    | ChainHash blk
isTip    ChainHash blk -> ChainHash blk -> Bool
forall a. Eq a => a -> a -> Bool
== ChainHash (TickedLedgerState blk) -> ChainHash blk
forall b b'.
Coercible (HeaderHash b) (HeaderHash b') =>
ChainHash b -> ChainHash b'
castHash (TickedLedgerState blk -> ChainHash (TickedLedgerState blk)
forall l. GetTip l => l -> ChainHash l
getTipHash TickedLedgerState blk
st')
    , SlotNo
isSlotNo SlotNo -> SlotNo -> Bool
forall a. Eq a => a -> a -> Bool
== SlotNo
slot
    = InternalState blk -> ValidationResult blk
forall blk. InternalState blk -> ValidationResult blk
validationResultFromIS InternalState blk
is
    | Bool
otherwise
    = MempoolCapacityBytesOverride
-> LedgerConfig blk
-> SlotNo
-> TickedLedgerState blk
-> TicketNo
-> [TxTicket (GenTx blk)]
-> ValidationResult blk
forall blk.
(LedgerSupportsMempool blk, HasTxId (GenTx blk)) =>
MempoolCapacityBytesOverride
-> LedgerConfig blk
-> SlotNo
-> TickedLedgerState blk
-> TicketNo
-> [TxTicket (GenTx blk)]
-> ValidationResult blk
revalidateTxsFor
        MempoolCapacityBytesOverride
capacityOverride
        LedgerConfig blk
cfg
        SlotNo
slot
        TickedLedgerState blk
st'
        TicketNo
isLastTicketNo
        (TxSeq (GenTx blk) -> [TxTicket (GenTx blk)]
forall tx. TxSeq tx -> [TxTicket tx]
TxSeq.toList TxSeq (GenTx blk)
isTxs)
  where
    IS { TxSeq (GenTx blk)
isTxs :: TxSeq (GenTx blk)
isTxs :: forall blk. InternalState blk -> TxSeq (GenTx blk)
isTxs, ChainHash blk
isTip :: ChainHash blk
isTip :: forall blk. InternalState blk -> ChainHash blk
isTip, SlotNo
isSlotNo :: SlotNo
isSlotNo :: forall blk. InternalState blk -> SlotNo
isSlotNo, TicketNo
isLastTicketNo :: TicketNo
isLastTicketNo :: forall blk. InternalState blk -> TicketNo
isLastTicketNo } = InternalState blk
is
    (SlotNo
slot, TickedLedgerState blk
st') = LedgerConfig blk
-> ForgeLedgerState blk -> (SlotNo, TickedLedgerState blk)
forall blk.
(UpdateLedger blk, ValidateEnvelope blk) =>
LedgerConfig blk
-> ForgeLedgerState blk -> (SlotNo, TickedLedgerState blk)
tickLedgerState LedgerConfig blk
cfg ForgeLedgerState blk
blockLedgerState

-- | Revalidate the given transactions (@['TxTicket' ('GenTx' blk)]@), which
-- are /all/ the transactions in the Mempool against the given ticked ledger
-- state, which corresponds to the chain's ledger state.
revalidateTxsFor
  :: (LedgerSupportsMempool blk, HasTxId (GenTx blk))
  => MempoolCapacityBytesOverride
  -> LedgerConfig blk
  -> SlotNo
  -> TickedLedgerState blk
  -> TicketNo
     -- ^ 'isLastTicketNo' & 'vrLastTicketNo'
  -> [TxTicket (GenTx blk)]
  -> ValidationResult blk
revalidateTxsFor :: MempoolCapacityBytesOverride
-> LedgerConfig blk
-> SlotNo
-> TickedLedgerState blk
-> TicketNo
-> [TxTicket (GenTx blk)]
-> ValidationResult blk
revalidateTxsFor MempoolCapacityBytesOverride
capacityOverride LedgerConfig blk
cfg SlotNo
slot TickedLedgerState blk
st TicketNo
lastTicketNo [TxTicket (GenTx blk)]
txTickets =
    (TxTicket (GenTx blk)
 -> ValidationResult blk -> ValidationResult blk)
-> [TxTicket (GenTx blk)]
-> ValidationResult blk
-> ValidationResult blk
forall a b. (a -> b -> b) -> [a] -> b -> b
repeatedly
      (LedgerConfig blk
-> TxTicket (GenTx blk)
-> ValidationResult blk
-> ValidationResult blk
forall blk.
(LedgerSupportsMempool blk, HasTxId (GenTx blk)) =>
LedgerConfig blk
-> TxTicket (GenTx blk)
-> ValidationResult blk
-> ValidationResult blk
extendVRPrevApplied LedgerConfig blk
cfg)
      [TxTicket (GenTx blk)]
txTickets
      (InternalState blk -> ValidationResult blk
forall blk. InternalState blk -> ValidationResult blk
validationResultFromIS InternalState blk
is)
  where
    is :: InternalState blk
is = MempoolCapacityBytesOverride
-> TicketNo -> SlotNo -> TickedLedgerState blk -> InternalState blk
forall blk.
LedgerSupportsMempool blk =>
MempoolCapacityBytesOverride
-> TicketNo -> SlotNo -> TickedLedgerState blk -> InternalState blk
initInternalState MempoolCapacityBytesOverride
capacityOverride TicketNo
lastTicketNo SlotNo
slot TickedLedgerState blk
st

-- | Tick the 'LedgerState' using the given 'BlockSlot'.
tickLedgerState
  :: forall blk. (UpdateLedger blk, ValidateEnvelope blk)
  => LedgerConfig     blk
  -> ForgeLedgerState blk
  -> (SlotNo, TickedLedgerState blk)
tickLedgerState :: LedgerConfig blk
-> ForgeLedgerState blk -> (SlotNo, TickedLedgerState blk)
tickLedgerState LedgerConfig blk
_cfg (ForgeInKnownSlot SlotNo
slot TickedLedgerState blk
st) = (SlotNo
slot, TickedLedgerState blk
st)
tickLedgerState  LedgerConfig blk
cfg (ForgeInUnknownSlot LedgerState blk
st) =
    (SlotNo
slot, LedgerConfig blk
-> SlotNo -> LedgerState blk -> TickedLedgerState blk
forall l. IsLedger l => LedgerCfg l -> SlotNo -> l -> Ticked l
applyChainTick LedgerConfig blk
cfg SlotNo
slot LedgerState blk
st)
  where
    -- Optimistically assume that the transactions will be included in a block
    -- in the next available slot
    --
    -- TODO: We should use time here instead
    -- <https://github.com/input-output-hk/ouroboros-network/issues/1298>
    -- Once we do, the ValidateEnvelope constraint can go.
    slot :: SlotNo
    slot :: SlotNo
slot = case LedgerState blk -> WithOrigin SlotNo
forall blk.
UpdateLedger blk =>
LedgerState blk -> WithOrigin SlotNo
ledgerTipSlot LedgerState blk
st of
             WithOrigin SlotNo
Origin      -> Proxy blk -> SlotNo
forall blk. BasicEnvelopeValidation blk => Proxy blk -> SlotNo
minimumPossibleSlotNo (Proxy blk
forall k (t :: k). Proxy t
Proxy @blk)
             NotOrigin SlotNo
s -> SlotNo -> SlotNo
forall a. Enum a => a -> a
succ SlotNo
s