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

-- | Definition of common types used in "Ouroboros.Consensus.Mempool.Init",
-- "Ouroboros.Consensus.Mempool.Update" and "Ouroboros.Consensus.Mempool.Query".
module Ouroboros.Consensus.Mempool.Impl.Common
  ( -- * Internal state
    InternalState (..)
  , isMempoolSize

    -- * Mempool environment
  , MempoolEnv (..)
  , initMempoolEnv

    -- * Ledger interface
  , LedgerInterface (..)
  , MempoolLedgerDBView (..)
  , chainDBLedgerInterface

    -- * Validation
  , RevalidateTxsResult (..)
  , computeSnapshot
  , revalidateTxsFor
  , validateNewTransaction

    -- * Tracing
  , MempoolRejectionDetails (..)
  , TraceEventMempool (..)
  , jsonMempoolRejectionDetails

    -- * Conversions
  , snapshotFromIS

    -- * Ticking a ledger state
  , tickLedgerState
  ) where

import Control.Concurrent.Class.MonadSTM.Strict.TMVar (newTMVarIO)
import Control.Monad.Trans.Except (runExcept)
import Control.ResourceRegistry
import Control.Tracer
import qualified Data.Aeson as Aeson
import qualified Data.Aeson.Key as AesonKey
import qualified Data.Foldable as Foldable
import qualified Data.List.NonEmpty as NE
import Data.Set (Set)
import qualified Data.Set as Set
import qualified Data.Text as Text
import Data.Typeable
import GHC.Generics (Generic)
import NoThunks.Class
import Ouroboros.Consensus.Block
import Ouroboros.Consensus.HeaderValidation
import Ouroboros.Consensus.Ledger.Abstract
import Ouroboros.Consensus.Ledger.Extended (ledgerState)
import Ouroboros.Consensus.Ledger.SupportsMempool
import Ouroboros.Consensus.Ledger.Tables.Utils
import Ouroboros.Consensus.Mempool.API
import Ouroboros.Consensus.Mempool.Capacity
import Ouroboros.Consensus.Mempool.TxSeq (TxSeq (..), TxTicket (..))
import qualified Ouroboros.Consensus.Mempool.TxSeq as TxSeq
import Ouroboros.Consensus.Storage.ChainDB (ChainDB)
import qualified Ouroboros.Consensus.Storage.ChainDB.API as ChainDB
import Ouroboros.Consensus.Storage.LedgerDB.Forker
import Ouroboros.Consensus.Util.Enclose (EnclosingTimed)
import Ouroboros.Consensus.Util.IOLike hiding (newMVar)
import Ouroboros.Consensus.Util.NormalForm.StrictMVar
import Ouroboros.Network.Protocol.LocalStateQuery.Type

{-------------------------------------------------------------------------------
  Internal State
-------------------------------------------------------------------------------}

-- | Internal state in the mempool
data InternalState blk = IS
  { forall blk.
InternalState blk
-> TxSeq (TxMeasureWithDiffTime blk) (Validated (GenTx blk))
isTxs :: !(TxSeq (TxMeasureWithDiffTime blk) (Validated (GenTx blk)))
  -- ^ 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.
  , forall blk. InternalState blk -> Set (GenTxId blk)
isTxIds :: !(Set (GenTxId 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'.
  , forall blk.
InternalState blk -> LedgerTables (LedgerState blk) KeysMK
isTxKeys :: !(LedgerTables (LedgerState blk) KeysMK)
  -- ^ The cached set of keys needed for the transactions
  -- currently in the mempool.
  --
  -- INVARIANT: @'isTxKeys' == foldMap (getTransactionKeySets . txForgetValidated) $ toList 'isTxs'@
  , forall blk.
InternalState blk -> LedgerTables (LedgerState blk) ValuesMK
isTxValues :: !(LedgerTables (LedgerState blk) ValuesMK)
  -- ^ The cached values corresponding to reading 'isTxKeys' at
  -- 'isLedgerState'. These values can be used unless we switch to
  -- a different ledger state. It usually happens in the forging
  -- loop that the same ledger state that was in 'isLedgerState'
  -- is used, but ticked to a different slot so we can reuse these
  -- values.
  --
  -- INVARIANT: 'isTxValues' should be equal to @getForkerAtTarget ... 'isLedgerState' >>= \f -> forkerReadTables f isTxKeys@
  , forall blk. InternalState blk -> TickedLedgerState blk DiffMK
isLedgerState :: !(TickedLedgerState blk DiffMK)
  -- ^ 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.
  , forall blk. InternalState blk -> Point blk
isTip :: !(Point blk)
  -- ^ The tip of the chain that 'isTxs' was validated against
  , forall blk. InternalState blk -> SlotNo
isSlotNo :: !SlotNo
  -- ^ The most recent 'SlotNo' that 'isTxs' was validated against
  --
  -- Note in particular that if the mempool is revalidated against a state S
  -- at slot s, then the state will be ticked (for now to the successor
  -- slot, see 'tickLedgerState') and 'isSlotNo' will be set to @succ s@,
  -- which is different from the slot of the original ledger state, which
  -- will remain in 'isTip'.
  , forall blk. InternalState blk -> TicketNo
isLastTicketNo :: !TicketNo
  -- ^ The mempool 'TicketNo' counter.
  --
  -- See 'vrLastTicketNo' for more information.
  , forall blk. InternalState blk -> TxMeasure blk
isCapacity :: !(TxMeasure blk)
  -- ^ 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.
  }
  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
$cfrom :: forall blk x. InternalState blk -> Rep (InternalState blk) x
from :: forall x. InternalState blk -> Rep (InternalState blk) x
$cto :: forall blk x. Rep (InternalState blk) x -> InternalState blk
to :: forall x. Rep (InternalState blk) x -> InternalState blk
Generic

deriving instance
  ( NoThunks (Validated (GenTx blk))
  , NoThunks (GenTxId blk)
  , NoThunks (TickedLedgerState blk DiffMK)
  , NoThunks (TxIn (LedgerState blk))
  , NoThunks (TxOut (LedgerState blk))
  , NoThunks (TxMeasure 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 :: TxLimits blk => InternalState blk -> MempoolSize
isMempoolSize :: forall blk. TxLimits blk => InternalState blk -> MempoolSize
isMempoolSize InternalState blk
is =
  MempoolSize
    { msNumTxs :: Word32
msNumTxs = Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word32) -> Int -> Word32
forall a b. (a -> b) -> a -> b
$ TxSeq (TxMeasureWithDiffTime blk) (Validated (GenTx blk)) -> Int
forall a. TxSeq (TxMeasureWithDiffTime blk) a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (TxSeq (TxMeasureWithDiffTime blk) (Validated (GenTx blk)) -> Int)
-> TxSeq (TxMeasureWithDiffTime blk) (Validated (GenTx blk)) -> Int
forall a b. (a -> b) -> a -> b
$ InternalState blk
-> TxSeq (TxMeasureWithDiffTime blk) (Validated (GenTx blk))
forall blk.
InternalState blk
-> TxSeq (TxMeasureWithDiffTime blk) (Validated (GenTx blk))
isTxs InternalState blk
is
    , msNumBytes :: ByteSize32
msNumBytes = TxMeasure blk -> ByteSize32
forall a. HasByteSize a => a -> ByteSize32
txMeasureByteSize (TxMeasure blk -> ByteSize32) -> TxMeasure blk -> ByteSize32
forall a b. (a -> b) -> a -> b
$ TxMeasureWithDiffTime blk -> TxMeasure blk
forall blk. TxMeasureWithDiffTime blk -> TxMeasure blk
forgetTxMeasureWithDiffTime (TxMeasureWithDiffTime blk -> TxMeasure blk)
-> TxMeasureWithDiffTime blk -> TxMeasure blk
forall a b. (a -> b) -> a -> b
$ TxSeq (TxMeasureWithDiffTime blk) (Validated (GenTx blk))
-> TxMeasureWithDiffTime blk
forall sz tx. Measure sz => TxSeq sz tx -> sz
TxSeq.toSize (TxSeq (TxMeasureWithDiffTime blk) (Validated (GenTx blk))
 -> TxMeasureWithDiffTime blk)
-> TxSeq (TxMeasureWithDiffTime blk) (Validated (GenTx blk))
-> TxMeasureWithDiffTime blk
forall a b. (a -> b) -> a -> b
$ InternalState blk
-> TxSeq (TxMeasureWithDiffTime blk) (Validated (GenTx blk))
forall blk.
InternalState blk
-> TxSeq (TxMeasureWithDiffTime blk) (Validated (GenTx blk))
isTxs InternalState blk
is
    }

initInternalState ::
  LedgerSupportsMempool blk =>
  MempoolCapacityBytesOverride ->
  -- | Used for 'isLastTicketNo'
  TicketNo ->
  LedgerConfig blk ->
  SlotNo ->
  TickedLedgerState blk DiffMK ->
  InternalState blk
initInternalState :: forall blk.
LedgerSupportsMempool blk =>
MempoolCapacityBytesOverride
-> TicketNo
-> LedgerConfig blk
-> SlotNo
-> TickedLedgerState blk DiffMK
-> InternalState blk
initInternalState MempoolCapacityBytesOverride
capacityOverride TicketNo
lastTicketNo LedgerConfig blk
cfg SlotNo
slot TickedLedgerState blk DiffMK
st =
  IS
    { isTxs :: TxSeq (TxMeasureWithDiffTime blk) (Validated (GenTx blk))
isTxs = TxSeq (TxMeasureWithDiffTime blk) (Validated (GenTx blk))
forall sz tx. Measure sz => TxSeq sz tx
TxSeq.Empty
    , isTxIds :: Set (GenTxId blk)
isTxIds = Set (GenTxId blk)
forall a. Set a
Set.empty
    , isTxKeys :: LedgerTables (LedgerState blk) KeysMK
isTxKeys = LedgerTables (LedgerState blk) KeysMK
forall (mk :: * -> * -> *) (l :: LedgerStateKind).
(ZeroableMK mk, LedgerTableConstraints l) =>
LedgerTables l mk
emptyLedgerTables
    , isTxValues :: LedgerTables (LedgerState blk) ValuesMK
isTxValues = LedgerTables (LedgerState blk) ValuesMK
forall (mk :: * -> * -> *) (l :: LedgerStateKind).
(ZeroableMK mk, LedgerTableConstraints l) =>
LedgerTables l mk
emptyLedgerTables
    , isLedgerState :: TickedLedgerState blk DiffMK
isLedgerState = TickedLedgerState blk DiffMK
st
    , isTip :: Point blk
isTip = Point (Ticked (LedgerState blk)) -> Point blk
forall {k1} {k2} (b :: k1) (b' :: k2).
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint (Point (Ticked (LedgerState blk)) -> Point blk)
-> Point (Ticked (LedgerState blk)) -> Point blk
forall a b. (a -> b) -> a -> b
$ TickedLedgerState blk DiffMK -> Point (Ticked (LedgerState blk))
forall (mk :: * -> * -> *).
Ticked (LedgerState blk) mk -> Point (Ticked (LedgerState blk))
forall (l :: LedgerStateKind) (mk :: * -> * -> *).
GetTip l =>
l mk -> Point l
getTip TickedLedgerState blk DiffMK
st
    , isSlotNo :: SlotNo
isSlotNo = SlotNo
slot
    , isLastTicketNo :: TicketNo
isLastTicketNo = TicketNo
lastTicketNo
    , isCapacity :: TxMeasure blk
isCapacity = LedgerConfig blk
-> TickedLedgerState blk DiffMK
-> MempoolCapacityBytesOverride
-> TxMeasure blk
forall blk (mk :: * -> * -> *).
LedgerSupportsMempool blk =>
LedgerConfig blk
-> TickedLedgerState blk mk
-> MempoolCapacityBytesOverride
-> TxMeasure blk
computeMempoolCapacity LedgerConfig blk
cfg TickedLedgerState blk DiffMK
st MempoolCapacityBytesOverride
capacityOverride
    }

{-------------------------------------------------------------------------------
  Ledger Interface
-------------------------------------------------------------------------------}

-- | Abstract interface needed to run a Mempool.
newtype LedgerInterface m blk = LedgerInterface
  { forall (m :: * -> *) blk.
LedgerInterface m blk
-> ResourceRegistry m -> STM m (MempoolLedgerDBView m blk)
getCurrentLedgerState :: ResourceRegistry m -> STM m (MempoolLedgerDBView m blk)
  -- ^ The resource registry should be the one of the Mempool
  -- ('mpEnvRegistry'). It will be used to allocate the forker.
  }

data MempoolLedgerDBView m blk = MempoolLedgerDBView
  { forall (m :: * -> *) blk.
MempoolLedgerDBView m blk -> LedgerState blk EmptyMK
mldViewState :: LedgerState blk EmptyMK
  -- ^ The ledger state currently at the tip of the LedgerDB
  , forall (m :: * -> *) blk.
MempoolLedgerDBView m blk
-> m (Either GetForkerError (ReadOnlyForker m (LedgerState blk)))
mldViewGetForker :: m (Either GetForkerError (ReadOnlyForker m (LedgerState blk)))
  -- ^ An action to get a forker at 'mldViewState' or an error in the unlikely
  -- case that such state is now gone from the LedgerDB.
  }

instance
  (StandardHash blk, UpdateLedger blk) =>
  Eq (MempoolLedgerDBView m blk)
  where
  MempoolLedgerDBView LedgerState blk EmptyMK
a m (Either GetForkerError (ReadOnlyForker m (LedgerState blk)))
_ == :: MempoolLedgerDBView m blk -> MempoolLedgerDBView m blk -> Bool
== MempoolLedgerDBView LedgerState blk EmptyMK
b m (Either GetForkerError (ReadOnlyForker m (LedgerState blk)))
_ =
    LedgerState blk EmptyMK -> Point blk
forall blk (mk :: * -> * -> *).
UpdateLedger blk =>
LedgerState blk mk -> Point blk
ledgerTipPoint LedgerState blk EmptyMK
a Point blk -> Point blk -> Bool
forall a. Eq a => a -> a -> Bool
== LedgerState blk EmptyMK -> Point blk
forall blk (mk :: * -> * -> *).
UpdateLedger blk =>
LedgerState blk mk -> Point blk
ledgerTipPoint LedgerState blk EmptyMK
b

-- | Create a 'LedgerInterface' from a 'ChainDB'.
chainDBLedgerInterface ::
  (IOLike m, IsLedger (LedgerState blk)) =>
  ChainDB m blk ->
  LedgerInterface m blk
chainDBLedgerInterface :: forall (m :: * -> *) blk.
(IOLike m, IsLedger (LedgerState blk)) =>
ChainDB m blk -> LedgerInterface m blk
chainDBLedgerInterface ChainDB m blk
chainDB =
  LedgerInterface
    { getCurrentLedgerState :: ResourceRegistry m -> STM m (MempoolLedgerDBView m blk)
getCurrentLedgerState = \ResourceRegistry m
reg -> do
        st <- ChainDB m blk -> STM m (ExtLedgerState blk EmptyMK)
forall (m :: * -> *) blk.
ChainDB m blk -> STM m (ExtLedgerState blk EmptyMK)
ChainDB.getCurrentLedger ChainDB m blk
chainDB
        pure
          $ MempoolLedgerDBView
            (ledgerState st)
          $ fmap (fmap ledgerStateReadOnlyForker)
          $ ChainDB.getReadOnlyForkerAtPoint chainDB reg (SpecificPoint (castPoint $ getTip st))
    }

{-------------------------------------------------------------------------------
  Mempool environment
-------------------------------------------------------------------------------}

-- | The mempool environment captures all the associated variables wrt the
-- Mempool and is accessed by the Mempool interface on demand to perform the
-- different operations.
data MempoolEnv m blk = MempoolEnv
  { forall (m :: * -> *) blk. MempoolEnv m blk -> LedgerInterface m blk
mpEnvLedger :: LedgerInterface m blk
  , forall (m :: * -> *) blk.
MempoolEnv m blk
-> StrictMVar m (ReadOnlyForker m (LedgerState blk))
mpEnvForker :: StrictMVar m (ReadOnlyForker m (LedgerState blk))
  , forall (m :: * -> *) blk. MempoolEnv m blk -> LedgerConfig blk
mpEnvLedgerCfg :: LedgerConfig blk
  , forall (m :: * -> *) blk. MempoolEnv m blk -> ResourceRegistry m
mpEnvRegistry :: ResourceRegistry m
  , forall (m :: * -> *) blk.
MempoolEnv m blk -> StrictTMVar m (InternalState blk)
mpEnvStateVar :: StrictTMVar m (InternalState blk)
  , forall (m :: * -> *) blk. MempoolEnv m blk -> StrictMVar m ()
mpEnvAddTxsRemoteFifo :: StrictMVar m ()
  , forall (m :: * -> *) blk. MempoolEnv m blk -> StrictMVar m ()
mpEnvAddTxsAllFifo :: StrictMVar m ()
  , forall (m :: * -> *) blk.
MempoolEnv m blk -> Tracer m (TraceEventMempool blk)
mpEnvTracer :: Tracer m (TraceEventMempool blk)
  , forall (m :: * -> *) blk.
MempoolEnv m blk -> MempoolCapacityBytesOverride
mpEnvCapacityOverride :: MempoolCapacityBytesOverride
  , forall (m :: * -> *) blk.
MempoolEnv m blk -> Maybe MempoolTimeoutConfig
mpEnvTimeoutConfig :: Maybe MempoolTimeoutConfig
  }

initMempoolEnv ::
  ( IOLike m
  , LedgerSupportsMempool blk
  , ValidateEnvelope blk
  ) =>
  LedgerInterface m blk ->
  LedgerConfig blk ->
  MempoolCapacityBytesOverride ->
  Maybe MempoolTimeoutConfig ->
  Tracer m (TraceEventMempool blk) ->
  ResourceRegistry m ->
  m (MempoolEnv m blk)
initMempoolEnv :: forall (m :: * -> *) blk.
(IOLike m, LedgerSupportsMempool blk, ValidateEnvelope blk) =>
LedgerInterface m blk
-> LedgerConfig blk
-> MempoolCapacityBytesOverride
-> Maybe MempoolTimeoutConfig
-> Tracer m (TraceEventMempool blk)
-> ResourceRegistry m
-> m (MempoolEnv m blk)
initMempoolEnv LedgerInterface m blk
ledgerInterface LedgerCfg (LedgerState blk)
cfg MempoolCapacityBytesOverride
capacityOverride Maybe MempoolTimeoutConfig
mbTimeoutConfig Tracer m (TraceEventMempool blk)
tracer ResourceRegistry m
topLevelRegistry = do
  (_, mpEnvRegistry) <- ResourceRegistry m
-> (ResourceId -> m (ResourceRegistry m))
-> (ResourceRegistry m -> m ())
-> m (ResourceKey m, ResourceRegistry m)
forall (m :: * -> *) a.
(MonadSTM m, MonadMask m, MonadThread m, HasCallStack) =>
ResourceRegistry m
-> (ResourceId -> m a) -> (a -> m ()) -> m (ResourceKey m, a)
allocate ResourceRegistry m
topLevelRegistry (\ResourceId
_ -> m (ResourceRegistry m)
forall (m :: * -> *).
(MonadSTM m, MonadThread m, HasCallStack) =>
m (ResourceRegistry m)
unsafeNewRegistry) ResourceRegistry m -> m ()
forall (m :: * -> *).
(MonadMask m, MonadThread m, MonadSTM m, HasCallStack) =>
ResourceRegistry m -> m ()
closeRegistry
  initMempoolEnv' mpEnvRegistry
 where
  initMempoolEnv' :: ResourceRegistry m -> m (MempoolEnv m blk)
initMempoolEnv' ResourceRegistry m
reg = do
    MempoolLedgerDBView st meFrk <- STM m (MempoolLedgerDBView m blk) -> m (MempoolLedgerDBView m blk)
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (MempoolLedgerDBView m blk)
 -> m (MempoolLedgerDBView m blk))
-> STM m (MempoolLedgerDBView m blk)
-> m (MempoolLedgerDBView m blk)
forall a b. (a -> b) -> a -> b
$ LedgerInterface m blk
-> ResourceRegistry m -> STM m (MempoolLedgerDBView m blk)
forall (m :: * -> *) blk.
LedgerInterface m blk
-> ResourceRegistry m -> STM m (MempoolLedgerDBView m blk)
getCurrentLedgerState LedgerInterface m blk
ledgerInterface ResourceRegistry m
reg
    eFrk <- meFrk
    case eFrk of
      -- This should happen very rarely, if between getting the state and getting
      -- the forker, the ledgerdb has changed. We just retry here.
      Left{} -> ResourceRegistry m -> m (MempoolEnv m blk)
initMempoolEnv' ResourceRegistry m
reg
      Right ReadOnlyForker m (LedgerState blk)
frk -> do
        frkMVar <- ReadOnlyForker m (LedgerState blk)
-> m (StrictMVar m (ReadOnlyForker m (LedgerState blk)))
forall (m :: * -> *) a.
(HasCallStack, MonadMVar m, NoThunks a) =>
a -> m (StrictMVar m a)
newMVar ReadOnlyForker m (LedgerState blk)
frk
        let (slot, st') = tickLedgerState cfg (ForgeInUnknownSlot st)
        isVar <-
          newTMVarIO $
            initInternalState capacityOverride TxSeq.zeroTicketNo cfg slot st'
        addTxRemoteFifo <- newMVar ()
        addTxAllFifo <- newMVar ()
        return
          MempoolEnv
            { mpEnvLedger = ledgerInterface
            , mpEnvLedgerCfg = cfg
            , mpEnvForker = frkMVar
            , mpEnvRegistry = reg
            , mpEnvStateVar = isVar
            , mpEnvAddTxsRemoteFifo = addTxRemoteFifo
            , mpEnvAddTxsAllFifo = addTxAllFifo
            , mpEnvTracer = tracer
            , mpEnvCapacityOverride = capacityOverride
            , mpEnvTimeoutConfig = mbTimeoutConfig
            }

{-------------------------------------------------------------------------------
  Ticking the ledger state
-------------------------------------------------------------------------------}

-- | Tick the 'LedgerState' using the given 'BlockSlot'.
tickLedgerState ::
  forall blk.
  (UpdateLedger blk, ValidateEnvelope blk) =>
  LedgerConfig blk ->
  ForgeLedgerState blk ->
  (SlotNo, TickedLedgerState blk DiffMK)
tickLedgerState :: forall blk.
(UpdateLedger blk, ValidateEnvelope blk) =>
LedgerConfig blk
-> ForgeLedgerState blk -> (SlotNo, TickedLedgerState blk DiffMK)
tickLedgerState LedgerConfig blk
_cfg (ForgeInKnownSlot SlotNo
slot TickedLedgerState blk DiffMK
st) = (SlotNo
slot, TickedLedgerState blk DiffMK
st)
tickLedgerState LedgerConfig blk
cfg (ForgeInUnknownSlot LedgerState blk EmptyMK
st) =
  (SlotNo
slot, ComputeLedgerEvents
-> LedgerConfig blk
-> SlotNo
-> LedgerState blk EmptyMK
-> TickedLedgerState blk DiffMK
forall (l :: LedgerStateKind).
IsLedger l =>
ComputeLedgerEvents
-> LedgerCfg l -> SlotNo -> l EmptyMK -> Ticked l DiffMK
applyChainTick ComputeLedgerEvents
OmitLedgerEvents LedgerConfig blk
cfg SlotNo
slot LedgerState blk EmptyMK
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/IntersectMBO/ouroboros-network/issues/1298>
  -- Once we do, the ValidateEnvelope constraint can go.
  slot :: SlotNo
  slot :: SlotNo
slot = case LedgerState blk EmptyMK -> WithOrigin SlotNo
forall blk (mk :: * -> * -> *).
UpdateLedger blk =>
LedgerState blk mk -> WithOrigin SlotNo
ledgerTipSlot LedgerState blk EmptyMK
st of
    WithOrigin SlotNo
Origin -> Proxy blk -> SlotNo
forall blk. BasicEnvelopeValidation blk => Proxy blk -> SlotNo
minimumPossibleSlotNo (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @blk)
    NotOrigin SlotNo
s -> SlotNo -> SlotNo
forall a. Enum a => a -> a
succ SlotNo
s

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

-- | Extend 'InternalState' with a new transaction (one which we have not
-- previously validated) that may or may not be valid in this ledger state.
validateNewTransaction ::
  (LedgerSupportsMempool blk, HasTxId (GenTx blk)) =>
  LedgerConfig blk ->
  WhetherToIntervene ->
  GenTx blk ->
  TxMeasure blk ->
  -- | Values to cache if success
  LedgerTables (LedgerState blk) ValuesMK ->
  -- | This state is the internal state with the tables for this transaction
  -- advanced through the diffs in the internal state. One could think we can
  -- create this value here, but it is needed for some other uses like calling
  -- 'txMeasure' before this function.
  TickedLedgerState blk ValuesMK ->
  InternalState blk ->
  ( Either (ApplyTxErr blk) (Validated (GenTx blk))
  , DiffTimeMeasure -> InternalState blk
  )
validateNewTransaction :: forall blk.
(LedgerSupportsMempool blk, HasTxId (GenTx blk)) =>
LedgerConfig blk
-> WhetherToIntervene
-> GenTx blk
-> TxMeasure blk
-> LedgerTables (LedgerState blk) ValuesMK
-> TickedLedgerState blk ValuesMK
-> InternalState blk
-> (Either (ApplyTxErr blk) (Validated (GenTx blk)),
    DiffTimeMeasure -> InternalState blk)
validateNewTransaction LedgerConfig blk
cfg WhetherToIntervene
wti GenTx blk
tx TxMeasure blk
txsz LedgerTables (LedgerState blk) ValuesMK
origValues TickedLedgerState blk ValuesMK
st InternalState blk
is =
  case Except
  (ApplyTxErr blk)
  (TickedLedgerState blk DiffMK, Validated (GenTx blk))
-> Either
     (ApplyTxErr blk)
     (TickedLedgerState blk DiffMK, Validated (GenTx blk))
forall e a. Except e a -> Either e a
runExcept (LedgerConfig blk
-> WhetherToIntervene
-> SlotNo
-> GenTx blk
-> TickedLedgerState blk ValuesMK
-> Except
     (ApplyTxErr blk)
     (TickedLedgerState blk DiffMK, Validated (GenTx blk))
forall blk.
LedgerSupportsMempool blk =>
LedgerConfig blk
-> WhetherToIntervene
-> SlotNo
-> GenTx blk
-> TickedLedgerState blk ValuesMK
-> Except
     (ApplyTxErr blk)
     (TickedLedgerState blk DiffMK, Validated (GenTx blk))
applyTx LedgerConfig blk
cfg WhetherToIntervene
wti SlotNo
isSlotNo GenTx blk
tx TickedLedgerState blk ValuesMK
st) of
    Left ApplyTxErr blk
err -> (ApplyTxErr blk -> Either (ApplyTxErr blk) (Validated (GenTx blk))
forall a b. a -> Either a b
Left ApplyTxErr blk
err, \DiffTimeMeasure
_dur -> InternalState blk
is)
    Right (TickedLedgerState blk DiffMK
st', Validated (GenTx blk)
vtx) ->
      ( Validated (GenTx blk)
-> Either (ApplyTxErr blk) (Validated (GenTx blk))
forall a b. b -> Either a b
Right Validated (GenTx blk)
vtx
      , \DiffTimeMeasure
dur ->
          InternalState blk
is
            { isTxs = isTxs :> TxTicket vtx nextTicketNo (MkTxMeasureWithDiffTime txsz dur)
            , isTxKeys = isTxKeys <> getTransactionKeySets tx
            , isTxValues = ltliftA2 unionValues isTxValues origValues
            , isTxIds = Set.insert (txId tx) isTxIds
            , isLedgerState = prependMempoolDiffs isLedgerState st'
            , isLastTicketNo = nextTicketNo
            }
      )
 where
  IS
    { TxSeq (TxMeasureWithDiffTime blk) (Validated (GenTx blk))
isTxs :: forall blk.
InternalState blk
-> TxSeq (TxMeasureWithDiffTime blk) (Validated (GenTx blk))
isTxs :: TxSeq (TxMeasureWithDiffTime blk) (Validated (GenTx blk))
isTxs
    , Set (GenTxId blk)
isTxIds :: forall blk. InternalState blk -> Set (GenTxId blk)
isTxIds :: Set (GenTxId blk)
isTxIds
    , LedgerTables (LedgerState blk) KeysMK
isTxKeys :: forall blk.
InternalState blk -> LedgerTables (LedgerState blk) KeysMK
isTxKeys :: LedgerTables (LedgerState blk) KeysMK
isTxKeys
    , LedgerTables (LedgerState blk) ValuesMK
isTxValues :: forall blk.
InternalState blk -> LedgerTables (LedgerState blk) ValuesMK
isTxValues :: LedgerTables (LedgerState blk) ValuesMK
isTxValues
    , TickedLedgerState blk DiffMK
isLedgerState :: forall blk. InternalState blk -> TickedLedgerState blk DiffMK
isLedgerState :: TickedLedgerState blk DiffMK
isLedgerState
    , TicketNo
isLastTicketNo :: forall blk. InternalState blk -> TicketNo
isLastTicketNo :: TicketNo
isLastTicketNo
    , SlotNo
isSlotNo :: forall blk. InternalState blk -> SlotNo
isSlotNo :: SlotNo
isSlotNo
    } = InternalState blk
is

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

-- | Revalidate the given transactions against the given ticked ledger state,
-- producing a new 'InternalState'.
--
-- Note that this function will perform revalidation so it is expected that the
-- transactions given to it were previously applied, for example if we are
-- revalidating the whole set of transactions onto a new state, or if we remove
-- some transactions and revalidate the remaining ones.
revalidateTxsFor ::
  (LedgerSupportsMempool blk, HasTxId (GenTx blk)) =>
  MempoolCapacityBytesOverride ->
  LedgerConfig blk ->
  SlotNo ->
  -- | The ticked ledger state againt which txs will be revalidated
  TickedLedgerState blk DiffMK ->
  -- | The tables with all the inputs for the transactions
  LedgerTables (LedgerState blk) ValuesMK ->
  -- | 'isLastTicketNo' and 'vrLastTicketNo'
  TicketNo ->
  [TxTicket (TxMeasureWithDiffTime blk) (Validated (GenTx blk))] ->
  RevalidateTxsResult blk
revalidateTxsFor :: forall blk.
(LedgerSupportsMempool blk, HasTxId (GenTx blk)) =>
MempoolCapacityBytesOverride
-> LedgerConfig blk
-> SlotNo
-> TickedLedgerState blk DiffMK
-> LedgerTables (LedgerState blk) ValuesMK
-> TicketNo
-> [TxTicket (TxMeasureWithDiffTime blk) (Validated (GenTx blk))]
-> RevalidateTxsResult blk
revalidateTxsFor MempoolCapacityBytesOverride
capacityOverride LedgerCfg (LedgerState blk)
cfg SlotNo
slot TickedLedgerState blk DiffMK
st LedgerTables (LedgerState blk) ValuesMK
values TicketNo
lastTicketNo [TxTicket (TxMeasureWithDiffTime blk) (Validated (GenTx blk))]
txTickets =
  let theTxs :: [(Validated (GenTx blk), (TicketNo, TxMeasureWithDiffTime blk))]
theTxs = (TxTicket (TxMeasureWithDiffTime blk) (Validated (GenTx blk))
 -> (Validated (GenTx blk), (TicketNo, TxMeasureWithDiffTime blk)))
-> [TxTicket (TxMeasureWithDiffTime blk) (Validated (GenTx blk))]
-> [(Validated (GenTx blk), (TicketNo, TxMeasureWithDiffTime blk))]
forall a b. (a -> b) -> [a] -> [b]
map TxTicket (TxMeasureWithDiffTime blk) (Validated (GenTx blk))
-> (Validated (GenTx blk), (TicketNo, TxMeasureWithDiffTime blk))
forall {b} {a}. TxTicket b a -> (a, (TicketNo, b))
wrap [TxTicket (TxMeasureWithDiffTime blk) (Validated (GenTx blk))]
txTickets
      wrap :: TxTicket b a -> (a, (TicketNo, b))
wrap = (\(TxTicket a
tx TicketNo
tk b
tz) -> (a
tx, (TicketNo
tk, b
tz)))
      unwrap :: (tx, (TicketNo, sz)) -> TxTicket sz tx
unwrap = (\(tx
tx, (TicketNo
tk, sz
tz)) -> tx -> TicketNo -> sz -> TxTicket sz tx
forall sz tx. tx -> TicketNo -> sz -> TxTicket sz tx
TxTicket tx
tx TicketNo
tk sz
tz)
      ReapplyTxsResult [Invalidated blk]
err [(Validated (GenTx blk), (TicketNo, TxMeasureWithDiffTime blk))]
val TickedLedgerState blk TrackingMK
st' =
        ComputeDiffs
-> LedgerCfg (LedgerState blk)
-> SlotNo
-> [(Validated (GenTx blk), (TicketNo, TxMeasureWithDiffTime blk))]
-> TickedLedgerState blk ValuesMK
-> ReapplyTxsResult (TicketNo, TxMeasureWithDiffTime blk) blk
forall blk extra.
LedgerSupportsMempool blk =>
ComputeDiffs
-> LedgerConfig blk
-> SlotNo
-> [(Validated (GenTx blk), extra)]
-> TickedLedgerState blk ValuesMK
-> ReapplyTxsResult extra blk
forall extra.
ComputeDiffs
-> LedgerCfg (LedgerState blk)
-> SlotNo
-> [(Validated (GenTx blk), extra)]
-> TickedLedgerState blk ValuesMK
-> ReapplyTxsResult extra blk
reapplyTxs ComputeDiffs
ComputeDiffs LedgerCfg (LedgerState blk)
cfg SlotNo
slot [(Validated (GenTx blk), (TicketNo, TxMeasureWithDiffTime blk))]
theTxs (TickedLedgerState blk ValuesMK
 -> ReapplyTxsResult (TicketNo, TxMeasureWithDiffTime blk) blk)
-> TickedLedgerState blk ValuesMK
-> ReapplyTxsResult (TicketNo, TxMeasureWithDiffTime blk) blk
forall a b. (a -> b) -> a -> b
$
          LedgerTables (LedgerState blk) ValuesMK
-> LedgerTables (LedgerState blk) KeysMK
-> TickedLedgerState blk DiffMK
-> TickedLedgerState blk ValuesMK
forall blk.
LedgerSupportsMempool blk =>
LedgerTables (LedgerState blk) ValuesMK
-> LedgerTables (LedgerState blk) KeysMK
-> TickedLedgerState blk DiffMK
-> TickedLedgerState blk ValuesMK
applyMempoolDiffs
            LedgerTables (LedgerState blk) ValuesMK
values
            (((Validated (GenTx blk), (TicketNo, TxMeasureWithDiffTime blk))
 -> LedgerTables (LedgerState blk) KeysMK)
-> [(Validated (GenTx blk), (TicketNo, TxMeasureWithDiffTime blk))]
-> LedgerTables (LedgerState blk) KeysMK
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
Foldable.foldMap' (GenTx blk -> LedgerTables (LedgerState blk) KeysMK
forall blk.
LedgerSupportsMempool blk =>
GenTx blk -> LedgerTables (LedgerState blk) KeysMK
getTransactionKeySets (GenTx blk -> LedgerTables (LedgerState blk) KeysMK)
-> ((Validated (GenTx blk), (TicketNo, TxMeasureWithDiffTime blk))
    -> GenTx blk)
-> (Validated (GenTx blk), (TicketNo, TxMeasureWithDiffTime blk))
-> LedgerTables (LedgerState blk) KeysMK
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)
-> ((Validated (GenTx blk), (TicketNo, TxMeasureWithDiffTime blk))
    -> Validated (GenTx blk))
-> (Validated (GenTx blk), (TicketNo, TxMeasureWithDiffTime blk))
-> GenTx blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Validated (GenTx blk), (TicketNo, TxMeasureWithDiffTime blk))
-> Validated (GenTx blk)
forall a b. (a, b) -> a
fst) [(Validated (GenTx blk), (TicketNo, TxMeasureWithDiffTime blk))]
theTxs)
            TickedLedgerState blk DiffMK
st
      keys :: LedgerTables (LedgerState blk) KeysMK
keys = ((Validated (GenTx blk), (TicketNo, TxMeasureWithDiffTime blk))
 -> LedgerTables (LedgerState blk) KeysMK)
-> [(Validated (GenTx blk), (TicketNo, TxMeasureWithDiffTime blk))]
-> LedgerTables (LedgerState blk) KeysMK
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
Foldable.foldMap' (GenTx blk -> LedgerTables (LedgerState blk) KeysMK
forall blk.
LedgerSupportsMempool blk =>
GenTx blk -> LedgerTables (LedgerState blk) KeysMK
getTransactionKeySets (GenTx blk -> LedgerTables (LedgerState blk) KeysMK)
-> ((Validated (GenTx blk), (TicketNo, TxMeasureWithDiffTime blk))
    -> GenTx blk)
-> (Validated (GenTx blk), (TicketNo, TxMeasureWithDiffTime blk))
-> LedgerTables (LedgerState blk) KeysMK
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)
-> ((Validated (GenTx blk), (TicketNo, TxMeasureWithDiffTime blk))
    -> Validated (GenTx blk))
-> (Validated (GenTx blk), (TicketNo, TxMeasureWithDiffTime blk))
-> GenTx blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Validated (GenTx blk), (TicketNo, TxMeasureWithDiffTime blk))
-> Validated (GenTx blk)
forall a b. (a, b) -> a
fst) [(Validated (GenTx blk), (TicketNo, TxMeasureWithDiffTime blk))]
val
   in InternalState blk -> [Invalidated blk] -> RevalidateTxsResult blk
forall blk.
InternalState blk -> [Invalidated blk] -> RevalidateTxsResult blk
RevalidateTxsResult
        ( IS
            { isTxs :: TxSeq (TxMeasureWithDiffTime blk) (Validated (GenTx blk))
isTxs = [TxTicket (TxMeasureWithDiffTime blk) (Validated (GenTx blk))]
-> TxSeq (TxMeasureWithDiffTime blk) (Validated (GenTx blk))
forall sz tx. Measure sz => [TxTicket sz tx] -> TxSeq sz tx
TxSeq.fromList ([TxTicket (TxMeasureWithDiffTime blk) (Validated (GenTx blk))]
 -> TxSeq (TxMeasureWithDiffTime blk) (Validated (GenTx blk)))
-> [TxTicket (TxMeasureWithDiffTime blk) (Validated (GenTx blk))]
-> TxSeq (TxMeasureWithDiffTime blk) (Validated (GenTx blk))
forall a b. (a -> b) -> a -> b
$ ((Validated (GenTx blk), (TicketNo, TxMeasureWithDiffTime blk))
 -> TxTicket (TxMeasureWithDiffTime blk) (Validated (GenTx blk)))
-> [(Validated (GenTx blk), (TicketNo, TxMeasureWithDiffTime blk))]
-> [TxTicket (TxMeasureWithDiffTime blk) (Validated (GenTx blk))]
forall a b. (a -> b) -> [a] -> [b]
map (Validated (GenTx blk), (TicketNo, TxMeasureWithDiffTime blk))
-> TxTicket (TxMeasureWithDiffTime blk) (Validated (GenTx blk))
forall {tx} {sz}. (tx, (TicketNo, sz)) -> TxTicket sz tx
unwrap [(Validated (GenTx blk), (TicketNo, TxMeasureWithDiffTime blk))]
val
            , isTxIds :: Set (GenTxId blk)
isTxIds = [GenTxId blk] -> Set (GenTxId blk)
forall a. Ord a => [a] -> Set a
Set.fromList ([GenTxId blk] -> Set (GenTxId blk))
-> [GenTxId blk] -> Set (GenTxId blk)
forall a b. (a -> b) -> a -> b
$ ((Validated (GenTx blk), (TicketNo, TxMeasureWithDiffTime blk))
 -> GenTxId blk)
-> [(Validated (GenTx blk), (TicketNo, TxMeasureWithDiffTime blk))]
-> [GenTxId blk]
forall a b. (a -> b) -> [a] -> [b]
map (GenTx blk -> GenTxId blk
forall tx. HasTxId tx => tx -> TxId tx
txId (GenTx blk -> GenTxId blk)
-> ((Validated (GenTx blk), (TicketNo, TxMeasureWithDiffTime blk))
    -> GenTx blk)
-> (Validated (GenTx blk), (TicketNo, TxMeasureWithDiffTime 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)
-> ((Validated (GenTx blk), (TicketNo, TxMeasureWithDiffTime blk))
    -> Validated (GenTx blk))
-> (Validated (GenTx blk), (TicketNo, TxMeasureWithDiffTime blk))
-> GenTx blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Validated (GenTx blk), (TicketNo, TxMeasureWithDiffTime blk))
-> Validated (GenTx blk)
forall a b. (a, b) -> a
fst) [(Validated (GenTx blk), (TicketNo, TxMeasureWithDiffTime blk))]
val
            , isTxKeys :: LedgerTables (LedgerState blk) KeysMK
isTxKeys = LedgerTables (LedgerState blk) KeysMK
keys
            , isTxValues :: LedgerTables (LedgerState blk) ValuesMK
isTxValues = (forall k v.
 LedgerTableConstraints' (LedgerState blk) k v =>
 ValuesMK k v -> KeysMK k v -> ValuesMK k v)
-> LedgerTables (LedgerState blk) ValuesMK
-> LedgerTables (LedgerState blk) KeysMK
-> LedgerTables (LedgerState blk) ValuesMK
forall (l :: LedgerStateKind) (mk1 :: * -> * -> *)
       (mk2 :: * -> * -> *) (mk3 :: * -> * -> *).
LedgerTableConstraints l =>
(forall k v.
 LedgerTableConstraints' l k v =>
 mk1 k v -> mk2 k v -> mk3 k v)
-> LedgerTables l mk1 -> LedgerTables l mk2 -> LedgerTables l mk3
ltliftA2 ValuesMK k v -> KeysMK k v -> ValuesMK k v
forall k v. Ord k => ValuesMK k v -> KeysMK k v -> ValuesMK k v
forall k v.
LedgerTableConstraints' (LedgerState blk) k v =>
ValuesMK k v -> KeysMK k v -> ValuesMK k v
restrictValuesMK LedgerTables (LedgerState blk) ValuesMK
values LedgerTables (LedgerState blk) KeysMK
keys
            , isLedgerState :: TickedLedgerState blk DiffMK
isLedgerState = TickedLedgerState blk TrackingMK -> TickedLedgerState blk DiffMK
forall (l :: LedgerStateKind).
(HasLedgerTables l, LedgerTableConstraints l) =>
l TrackingMK -> l DiffMK
trackingToDiffs TickedLedgerState blk TrackingMK
st'
            , isTip :: Point blk
isTip = Point (Ticked (LedgerState blk)) -> Point blk
forall {k1} {k2} (b :: k1) (b' :: k2).
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint (Point (Ticked (LedgerState blk)) -> Point blk)
-> Point (Ticked (LedgerState blk)) -> Point blk
forall a b. (a -> b) -> a -> b
$ TickedLedgerState blk DiffMK -> Point (Ticked (LedgerState blk))
forall (mk :: * -> * -> *).
Ticked (LedgerState blk) mk -> Point (Ticked (LedgerState blk))
forall (l :: LedgerStateKind) (mk :: * -> * -> *).
GetTip l =>
l mk -> Point l
getTip TickedLedgerState blk DiffMK
st
            , isSlotNo :: SlotNo
isSlotNo = SlotNo
slot
            , isLastTicketNo :: TicketNo
isLastTicketNo = TicketNo
lastTicketNo
            , isCapacity :: TxMeasure blk
isCapacity = LedgerCfg (LedgerState blk)
-> TickedLedgerState blk TrackingMK
-> MempoolCapacityBytesOverride
-> TxMeasure blk
forall blk (mk :: * -> * -> *).
LedgerSupportsMempool blk =>
LedgerConfig blk
-> TickedLedgerState blk mk
-> MempoolCapacityBytesOverride
-> TxMeasure blk
computeMempoolCapacity LedgerCfg (LedgerState blk)
cfg TickedLedgerState blk TrackingMK
st' MempoolCapacityBytesOverride
capacityOverride
            }
        )
        [Invalidated blk]
err

data RevalidateTxsResult blk
  = RevalidateTxsResult
  { forall blk. RevalidateTxsResult blk -> InternalState blk
newInternalState :: !(InternalState blk)
  -- ^ The internal state after revalidation
  , forall blk. RevalidateTxsResult blk -> [Invalidated blk]
removedTxs :: ![Invalidated blk]
  -- ^ The previously valid transactions that were now invalid
  }

-- | Compute snapshot is largely the same as revalidate the transactions
-- but we ignore the diffs.
computeSnapshot ::
  (LedgerSupportsMempool blk, HasTxId (GenTx blk)) =>
  MempoolCapacityBytesOverride ->
  LedgerConfig blk ->
  SlotNo ->
  -- | The ticked ledger state againt which txs will be revalidated
  TickedLedgerState blk DiffMK ->
  -- | The tables with all the inputs for the transactions
  LedgerTables (LedgerState blk) ValuesMK ->
  -- | 'isLastTicketNo' and 'vrLastTicketNo'
  TicketNo ->
  [TxTicket (TxMeasureWithDiffTime blk) (Validated (GenTx blk))] ->
  MempoolSnapshot blk
computeSnapshot :: forall blk.
(LedgerSupportsMempool blk, HasTxId (GenTx blk)) =>
MempoolCapacityBytesOverride
-> LedgerConfig blk
-> SlotNo
-> TickedLedgerState blk DiffMK
-> LedgerTables (LedgerState blk) ValuesMK
-> TicketNo
-> [TxTicket (TxMeasureWithDiffTime blk) (Validated (GenTx blk))]
-> MempoolSnapshot blk
computeSnapshot MempoolCapacityBytesOverride
capacityOverride LedgerCfg (LedgerState blk)
cfg SlotNo
slot TickedLedgerState blk DiffMK
st LedgerTables (LedgerState blk) ValuesMK
values TicketNo
lastTicketNo [TxTicket (TxMeasureWithDiffTime blk) (Validated (GenTx blk))]
txTickets =
  let theTxs :: [(Validated (GenTx blk), (TicketNo, TxMeasureWithDiffTime blk))]
theTxs = (TxTicket (TxMeasureWithDiffTime blk) (Validated (GenTx blk))
 -> (Validated (GenTx blk), (TicketNo, TxMeasureWithDiffTime blk)))
-> [TxTicket (TxMeasureWithDiffTime blk) (Validated (GenTx blk))]
-> [(Validated (GenTx blk), (TicketNo, TxMeasureWithDiffTime blk))]
forall a b. (a -> b) -> [a] -> [b]
map TxTicket (TxMeasureWithDiffTime blk) (Validated (GenTx blk))
-> (Validated (GenTx blk), (TicketNo, TxMeasureWithDiffTime blk))
forall {b} {a}. TxTicket b a -> (a, (TicketNo, b))
wrap [TxTicket (TxMeasureWithDiffTime blk) (Validated (GenTx blk))]
txTickets
      wrap :: TxTicket b a -> (a, (TicketNo, b))
wrap = (\(TxTicket a
tx TicketNo
tk b
tz) -> (a
tx, (TicketNo
tk, b
tz)))
      unwrap :: (tx, (TicketNo, sz)) -> TxTicket sz tx
unwrap = (\(tx
tx, (TicketNo
tk, sz
tz)) -> tx -> TicketNo -> sz -> TxTicket sz tx
forall sz tx. tx -> TicketNo -> sz -> TxTicket sz tx
TxTicket tx
tx TicketNo
tk sz
tz)
      ReapplyTxsResult [Invalidated blk]
_ [(Validated (GenTx blk), (TicketNo, TxMeasureWithDiffTime blk))]
val TickedLedgerState blk TrackingMK
st' =
        ComputeDiffs
-> LedgerCfg (LedgerState blk)
-> SlotNo
-> [(Validated (GenTx blk), (TicketNo, TxMeasureWithDiffTime blk))]
-> TickedLedgerState blk ValuesMK
-> ReapplyTxsResult (TicketNo, TxMeasureWithDiffTime blk) blk
forall blk extra.
LedgerSupportsMempool blk =>
ComputeDiffs
-> LedgerConfig blk
-> SlotNo
-> [(Validated (GenTx blk), extra)]
-> TickedLedgerState blk ValuesMK
-> ReapplyTxsResult extra blk
forall extra.
ComputeDiffs
-> LedgerCfg (LedgerState blk)
-> SlotNo
-> [(Validated (GenTx blk), extra)]
-> TickedLedgerState blk ValuesMK
-> ReapplyTxsResult extra blk
reapplyTxs ComputeDiffs
IgnoreDiffs LedgerCfg (LedgerState blk)
cfg SlotNo
slot [(Validated (GenTx blk), (TicketNo, TxMeasureWithDiffTime blk))]
theTxs (TickedLedgerState blk ValuesMK
 -> ReapplyTxsResult (TicketNo, TxMeasureWithDiffTime blk) blk)
-> TickedLedgerState blk ValuesMK
-> ReapplyTxsResult (TicketNo, TxMeasureWithDiffTime blk) blk
forall a b. (a -> b) -> a -> b
$
          LedgerTables (LedgerState blk) ValuesMK
-> LedgerTables (LedgerState blk) KeysMK
-> TickedLedgerState blk DiffMK
-> TickedLedgerState blk ValuesMK
forall blk.
LedgerSupportsMempool blk =>
LedgerTables (LedgerState blk) ValuesMK
-> LedgerTables (LedgerState blk) KeysMK
-> TickedLedgerState blk DiffMK
-> TickedLedgerState blk ValuesMK
applyMempoolDiffs
            LedgerTables (LedgerState blk) ValuesMK
values
            (((Validated (GenTx blk), (TicketNo, TxMeasureWithDiffTime blk))
 -> LedgerTables (LedgerState blk) KeysMK)
-> [(Validated (GenTx blk), (TicketNo, TxMeasureWithDiffTime blk))]
-> LedgerTables (LedgerState blk) KeysMK
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
Foldable.foldMap' (GenTx blk -> LedgerTables (LedgerState blk) KeysMK
forall blk.
LedgerSupportsMempool blk =>
GenTx blk -> LedgerTables (LedgerState blk) KeysMK
getTransactionKeySets (GenTx blk -> LedgerTables (LedgerState blk) KeysMK)
-> ((Validated (GenTx blk), (TicketNo, TxMeasureWithDiffTime blk))
    -> GenTx blk)
-> (Validated (GenTx blk), (TicketNo, TxMeasureWithDiffTime blk))
-> LedgerTables (LedgerState blk) KeysMK
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)
-> ((Validated (GenTx blk), (TicketNo, TxMeasureWithDiffTime blk))
    -> Validated (GenTx blk))
-> (Validated (GenTx blk), (TicketNo, TxMeasureWithDiffTime blk))
-> GenTx blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Validated (GenTx blk), (TicketNo, TxMeasureWithDiffTime blk))
-> Validated (GenTx blk)
forall a b. (a, b) -> a
fst) [(Validated (GenTx blk), (TicketNo, TxMeasureWithDiffTime blk))]
theTxs)
            TickedLedgerState blk DiffMK
st
   in InternalState blk -> MempoolSnapshot blk
forall blk.
(HasTxId (GenTx blk), TxLimits blk,
 GetTip (TickedLedgerState blk)) =>
InternalState blk -> MempoolSnapshot blk
snapshotFromIS (InternalState blk -> MempoolSnapshot blk)
-> InternalState blk -> MempoolSnapshot blk
forall a b. (a -> b) -> a -> b
$
        IS
          { isTxs :: TxSeq (TxMeasureWithDiffTime blk) (Validated (GenTx blk))
isTxs = [TxTicket (TxMeasureWithDiffTime blk) (Validated (GenTx blk))]
-> TxSeq (TxMeasureWithDiffTime blk) (Validated (GenTx blk))
forall sz tx. Measure sz => [TxTicket sz tx] -> TxSeq sz tx
TxSeq.fromList ([TxTicket (TxMeasureWithDiffTime blk) (Validated (GenTx blk))]
 -> TxSeq (TxMeasureWithDiffTime blk) (Validated (GenTx blk)))
-> [TxTicket (TxMeasureWithDiffTime blk) (Validated (GenTx blk))]
-> TxSeq (TxMeasureWithDiffTime blk) (Validated (GenTx blk))
forall a b. (a -> b) -> a -> b
$ ((Validated (GenTx blk), (TicketNo, TxMeasureWithDiffTime blk))
 -> TxTicket (TxMeasureWithDiffTime blk) (Validated (GenTx blk)))
-> [(Validated (GenTx blk), (TicketNo, TxMeasureWithDiffTime blk))]
-> [TxTicket (TxMeasureWithDiffTime blk) (Validated (GenTx blk))]
forall a b. (a -> b) -> [a] -> [b]
map (Validated (GenTx blk), (TicketNo, TxMeasureWithDiffTime blk))
-> TxTicket (TxMeasureWithDiffTime blk) (Validated (GenTx blk))
forall {tx} {sz}. (tx, (TicketNo, sz)) -> TxTicket sz tx
unwrap [(Validated (GenTx blk), (TicketNo, TxMeasureWithDiffTime blk))]
val
          , isTxIds :: Set (GenTxId blk)
isTxIds = [GenTxId blk] -> Set (GenTxId blk)
forall a. Ord a => [a] -> Set a
Set.fromList ([GenTxId blk] -> Set (GenTxId blk))
-> [GenTxId blk] -> Set (GenTxId blk)
forall a b. (a -> b) -> a -> b
$ ((Validated (GenTx blk), (TicketNo, TxMeasureWithDiffTime blk))
 -> GenTxId blk)
-> [(Validated (GenTx blk), (TicketNo, TxMeasureWithDiffTime blk))]
-> [GenTxId blk]
forall a b. (a -> b) -> [a] -> [b]
map (GenTx blk -> GenTxId blk
forall tx. HasTxId tx => tx -> TxId tx
txId (GenTx blk -> GenTxId blk)
-> ((Validated (GenTx blk), (TicketNo, TxMeasureWithDiffTime blk))
    -> GenTx blk)
-> (Validated (GenTx blk), (TicketNo, TxMeasureWithDiffTime 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)
-> ((Validated (GenTx blk), (TicketNo, TxMeasureWithDiffTime blk))
    -> Validated (GenTx blk))
-> (Validated (GenTx blk), (TicketNo, TxMeasureWithDiffTime blk))
-> GenTx blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Validated (GenTx blk), (TicketNo, TxMeasureWithDiffTime blk))
-> Validated (GenTx blk)
forall a b. (a, b) -> a
fst) [(Validated (GenTx blk), (TicketNo, TxMeasureWithDiffTime blk))]
val
          , -- These two can be empty since we don't need the resulting
            -- values at all when making a snapshot, as we won't update
            -- the internal state.
            isTxKeys :: LedgerTables (LedgerState blk) KeysMK
isTxKeys = LedgerTables (LedgerState blk) KeysMK
forall (mk :: * -> * -> *) (l :: LedgerStateKind).
(ZeroableMK mk, LedgerTableConstraints l) =>
LedgerTables l mk
emptyLedgerTables
          , isTxValues :: LedgerTables (LedgerState blk) ValuesMK
isTxValues = LedgerTables (LedgerState blk) ValuesMK
forall (mk :: * -> * -> *) (l :: LedgerStateKind).
(ZeroableMK mk, LedgerTableConstraints l) =>
LedgerTables l mk
emptyLedgerTables
          , isLedgerState :: TickedLedgerState blk DiffMK
isLedgerState = TickedLedgerState blk TrackingMK -> TickedLedgerState blk DiffMK
forall (l :: LedgerStateKind).
(HasLedgerTables l, LedgerTableConstraints l) =>
l TrackingMK -> l DiffMK
trackingToDiffs TickedLedgerState blk TrackingMK
st'
          , isTip :: Point blk
isTip = Point (TickedLedgerState blk) -> Point blk
forall {k1} {k2} (b :: k1) (b' :: k2).
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint (Point (TickedLedgerState blk) -> Point blk)
-> Point (TickedLedgerState blk) -> Point blk
forall a b. (a -> b) -> a -> b
$ TickedLedgerState blk DiffMK -> Point (TickedLedgerState blk)
forall (mk :: * -> * -> *).
Ticked (LedgerState blk) mk -> Point (TickedLedgerState blk)
forall (l :: LedgerStateKind) (mk :: * -> * -> *).
GetTip l =>
l mk -> Point l
getTip TickedLedgerState blk DiffMK
st
          , isSlotNo :: SlotNo
isSlotNo = SlotNo
slot
          , isLastTicketNo :: TicketNo
isLastTicketNo = TicketNo
lastTicketNo
          , isCapacity :: TxMeasure blk
isCapacity = LedgerCfg (LedgerState blk)
-> TickedLedgerState blk TrackingMK
-> MempoolCapacityBytesOverride
-> TxMeasure blk
forall blk (mk :: * -> * -> *).
LedgerSupportsMempool blk =>
LedgerConfig blk
-> TickedLedgerState blk mk
-> MempoolCapacityBytesOverride
-> TxMeasure blk
computeMempoolCapacity LedgerCfg (LedgerState blk)
cfg TickedLedgerState blk TrackingMK
st' MempoolCapacityBytesOverride
capacityOverride
          }

{-------------------------------------------------------------------------------
  Conversions
-------------------------------------------------------------------------------}

-- | Create a Mempool Snapshot from a given Internal State of the mempool.
snapshotFromIS ::
  forall blk.
  (HasTxId (GenTx blk), TxLimits blk, GetTip (TickedLedgerState blk)) =>
  InternalState blk ->
  MempoolSnapshot blk
snapshotFromIS :: forall blk.
(HasTxId (GenTx blk), TxLimits blk,
 GetTip (TickedLedgerState blk)) =>
InternalState blk -> MempoolSnapshot blk
snapshotFromIS InternalState blk
is =
  MempoolSnapshot
    { snapshotTxs :: [(Validated (GenTx blk), TicketNo, TxMeasure blk)]
snapshotTxs = InternalState blk
-> [(Validated (GenTx blk), TicketNo, TxMeasure blk)]
implSnapshotGetTxs InternalState blk
is
    , snapshotTxsAfter :: TicketNo -> [(Validated (GenTx blk), TicketNo, TxMeasure blk)]
snapshotTxsAfter = InternalState blk
-> TicketNo -> [(Validated (GenTx blk), TicketNo, TxMeasure blk)]
implSnapshotGetTxsAfter InternalState blk
is
    , snapshotLookupTx :: TicketNo -> Maybe (Validated (GenTx blk))
snapshotLookupTx = InternalState blk -> TicketNo -> Maybe (Validated (GenTx blk))
implSnapshotGetTx InternalState blk
is
    , snapshotHasTx :: GenTxId blk -> Bool
snapshotHasTx = InternalState blk -> GenTxId blk -> Bool
implSnapshotHasTx InternalState blk
is
    , snapshotMempoolSize :: MempoolSize
snapshotMempoolSize = InternalState blk -> MempoolSize
implSnapshotGetMempoolSize InternalState blk
is
    , snapshotSlotNo :: SlotNo
snapshotSlotNo = InternalState blk -> SlotNo
forall blk. InternalState blk -> SlotNo
isSlotNo InternalState blk
is
    , snapshotStateHash :: ChainHash (TickedLedgerState blk)
snapshotStateHash = TickedLedgerState blk DiffMK -> ChainHash (TickedLedgerState blk)
forall (l :: LedgerStateKind) (mk :: * -> * -> *).
GetTip l =>
l mk -> ChainHash l
getTipHash (TickedLedgerState blk DiffMK -> ChainHash (TickedLedgerState blk))
-> TickedLedgerState blk DiffMK
-> ChainHash (TickedLedgerState blk)
forall a b. (a -> b) -> a -> b
$ InternalState blk -> TickedLedgerState blk DiffMK
forall blk. InternalState blk -> TickedLedgerState blk DiffMK
isLedgerState InternalState blk
is
    , snapshotTake :: TxMeasure blk
-> ([Validated (GenTx blk)], TxMeasureWithDiffTime blk)
snapshotTake = InternalState blk
-> TxMeasure blk
-> ([Validated (GenTx blk)], TxMeasureWithDiffTime blk)
implSnapshotTake InternalState blk
is
    , snapshotPoint :: Point blk
snapshotPoint = Point (TickedLedgerState blk) -> Point blk
forall {k1} {k2} (b :: k1) (b' :: k2).
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint (Point (TickedLedgerState blk) -> Point blk)
-> Point (TickedLedgerState blk) -> Point blk
forall a b. (a -> b) -> a -> b
$ TickedLedgerState blk DiffMK -> Point (TickedLedgerState blk)
forall (mk :: * -> * -> *).
Ticked (LedgerState blk) mk -> Point (TickedLedgerState blk)
forall (l :: LedgerStateKind) (mk :: * -> * -> *).
GetTip l =>
l mk -> Point l
getTip (TickedLedgerState blk DiffMK -> Point (TickedLedgerState blk))
-> TickedLedgerState blk DiffMK -> Point (TickedLedgerState blk)
forall a b. (a -> b) -> a -> b
$ InternalState blk -> TickedLedgerState blk DiffMK
forall blk. InternalState blk -> TickedLedgerState blk DiffMK
isLedgerState InternalState blk
is
    }
 where
  implSnapshotGetTxs ::
    InternalState blk ->
    [(Validated (GenTx blk), TicketNo, TxMeasure blk)]
  implSnapshotGetTxs :: InternalState blk
-> [(Validated (GenTx blk), TicketNo, TxMeasure blk)]
implSnapshotGetTxs = (InternalState blk
 -> TicketNo -> [(Validated (GenTx blk), TicketNo, TxMeasure blk)])
-> TicketNo
-> InternalState blk
-> [(Validated (GenTx blk), TicketNo, TxMeasure blk)]
forall a b c. (a -> b -> c) -> b -> a -> c
flip InternalState blk
-> TicketNo -> [(Validated (GenTx blk), TicketNo, TxMeasure blk)]
implSnapshotGetTxsAfter TicketNo
TxSeq.zeroTicketNo

  implSnapshotGetTxsAfter ::
    InternalState blk ->
    TicketNo ->
    [(Validated (GenTx blk), TicketNo, TxMeasure blk)]
  implSnapshotGetTxsAfter :: InternalState blk
-> TicketNo -> [(Validated (GenTx blk), TicketNo, TxMeasure blk)]
implSnapshotGetTxsAfter IS{TxSeq (TxMeasureWithDiffTime blk) (Validated (GenTx blk))
isTxs :: forall blk.
InternalState blk
-> TxSeq (TxMeasureWithDiffTime blk) (Validated (GenTx blk))
isTxs :: TxSeq (TxMeasureWithDiffTime blk) (Validated (GenTx blk))
isTxs} =
    (\[(Validated (GenTx blk), TicketNo, TxMeasureWithDiffTime blk)]
x -> [(Validated (GenTx blk)
a, TicketNo
b, TxMeasureWithDiffTime blk -> TxMeasure blk
forall blk. TxMeasureWithDiffTime blk -> TxMeasure blk
forgetTxMeasureWithDiffTime TxMeasureWithDiffTime blk
c) | (Validated (GenTx blk)
a, TicketNo
b, TxMeasureWithDiffTime blk
c) <- [(Validated (GenTx blk), TicketNo, TxMeasureWithDiffTime blk)]
x])
      ([(Validated (GenTx blk), TicketNo, TxMeasureWithDiffTime blk)]
 -> [(Validated (GenTx blk), TicketNo, TxMeasure blk)])
-> (TicketNo
    -> [(Validated (GenTx blk), TicketNo, TxMeasureWithDiffTime blk)])
-> TicketNo
-> [(Validated (GenTx blk), TicketNo, TxMeasure blk)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxSeq (TxMeasureWithDiffTime blk) (Validated (GenTx blk))
-> [(Validated (GenTx blk), TicketNo, TxMeasureWithDiffTime blk)]
forall sz tx. TxSeq sz tx -> [(tx, TicketNo, sz)]
TxSeq.toTuples
      (TxSeq (TxMeasureWithDiffTime blk) (Validated (GenTx blk))
 -> [(Validated (GenTx blk), TicketNo, TxMeasureWithDiffTime blk)])
-> (TicketNo
    -> TxSeq (TxMeasureWithDiffTime blk) (Validated (GenTx blk)))
-> TicketNo
-> [(Validated (GenTx blk), TicketNo, TxMeasureWithDiffTime blk)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TxSeq (TxMeasureWithDiffTime blk) (Validated (GenTx blk)),
 TxSeq (TxMeasureWithDiffTime blk) (Validated (GenTx blk)))
-> TxSeq (TxMeasureWithDiffTime blk) (Validated (GenTx blk))
forall a b. (a, b) -> b
snd
      ((TxSeq (TxMeasureWithDiffTime blk) (Validated (GenTx blk)),
  TxSeq (TxMeasureWithDiffTime blk) (Validated (GenTx blk)))
 -> TxSeq (TxMeasureWithDiffTime blk) (Validated (GenTx blk)))
-> (TicketNo
    -> (TxSeq (TxMeasureWithDiffTime blk) (Validated (GenTx blk)),
        TxSeq (TxMeasureWithDiffTime blk) (Validated (GenTx blk))))
-> TicketNo
-> TxSeq (TxMeasureWithDiffTime blk) (Validated (GenTx blk))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxSeq (TxMeasureWithDiffTime blk) (Validated (GenTx blk))
-> TicketNo
-> (TxSeq (TxMeasureWithDiffTime blk) (Validated (GenTx blk)),
    TxSeq (TxMeasureWithDiffTime blk) (Validated (GenTx blk)))
forall sz tx.
Measure sz =>
TxSeq sz tx -> TicketNo -> (TxSeq sz tx, TxSeq sz tx)
TxSeq.splitAfterTicketNo TxSeq (TxMeasureWithDiffTime blk) (Validated (GenTx blk))
isTxs

  implSnapshotTake ::
    InternalState blk ->
    TxMeasure blk ->
    ([Validated (GenTx blk)], TxMeasureWithDiffTime blk)
  implSnapshotTake :: InternalState blk
-> TxMeasure blk
-> ([Validated (GenTx blk)], TxMeasureWithDiffTime blk)
implSnapshotTake IS{TxSeq (TxMeasureWithDiffTime blk) (Validated (GenTx blk))
isTxs :: forall blk.
InternalState blk
-> TxSeq (TxMeasureWithDiffTime blk) (Validated (GenTx blk))
isTxs :: TxSeq (TxMeasureWithDiffTime blk) (Validated (GenTx blk))
isTxs} TxMeasure blk
limit =
    ((TxTicket (TxMeasureWithDiffTime blk) (Validated (GenTx blk))
 -> Validated (GenTx blk))
-> [TxTicket (TxMeasureWithDiffTime blk) (Validated (GenTx blk))]
-> [Validated (GenTx blk)]
forall a b. (a -> b) -> [a] -> [b]
map TxTicket (TxMeasureWithDiffTime blk) (Validated (GenTx blk))
-> Validated (GenTx blk)
forall sz tx. TxTicket sz tx -> tx
TxSeq.txTicketTx (TxSeq (TxMeasureWithDiffTime blk) (Validated (GenTx blk))
-> [TxTicket (TxMeasureWithDiffTime blk) (Validated (GenTx blk))]
forall sz tx. TxSeq sz tx -> [TxTicket sz tx]
TxSeq.toList TxSeq (TxMeasureWithDiffTime blk) (Validated (GenTx blk))
x), TxSeq (TxMeasureWithDiffTime blk) (Validated (GenTx blk))
-> TxMeasureWithDiffTime blk
forall sz tx. Measure sz => TxSeq sz tx -> sz
TxSeq.toSize TxSeq (TxMeasureWithDiffTime blk) (Validated (GenTx blk))
x)
   where
    (TxSeq (TxMeasureWithDiffTime blk) (Validated (GenTx blk))
x, TxSeq (TxMeasureWithDiffTime blk) (Validated (GenTx blk))
_y) = TxSeq (TxMeasureWithDiffTime blk) (Validated (GenTx blk))
-> TxMeasureWithDiffTime blk
-> (TxSeq (TxMeasureWithDiffTime blk) (Validated (GenTx blk)),
    TxSeq (TxMeasureWithDiffTime blk) (Validated (GenTx blk)))
forall sz tx.
Measure sz =>
TxSeq sz tx -> sz -> (TxSeq sz tx, TxSeq sz tx)
TxSeq.splitAfterTxSize TxSeq (TxMeasureWithDiffTime blk) (Validated (GenTx blk))
isTxs (TxMeasureWithDiffTime blk
 -> (TxSeq (TxMeasureWithDiffTime blk) (Validated (GenTx blk)),
     TxSeq (TxMeasureWithDiffTime blk) (Validated (GenTx blk))))
-> TxMeasureWithDiffTime blk
-> (TxSeq (TxMeasureWithDiffTime blk) (Validated (GenTx blk)),
    TxSeq (TxMeasureWithDiffTime blk) (Validated (GenTx blk)))
forall a b. (a -> b) -> a -> b
$ TxMeasure blk -> DiffTimeMeasure -> TxMeasureWithDiffTime blk
forall blk.
TxMeasure blk -> DiffTimeMeasure -> TxMeasureWithDiffTime blk
MkTxMeasureWithDiffTime TxMeasure blk
limit DiffTimeMeasure
InfiniteDiffTimeMeasure

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

  implSnapshotHasTx ::
    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 = InternalState blk -> MempoolSize
forall blk. TxLimits blk => InternalState blk -> MempoolSize
isMempoolSize

{-------------------------------------------------------------------------------
  Tracing support for the mempool operations
-------------------------------------------------------------------------------}

-- | Events traced by the Mempool.
data TraceEventMempool blk
  = TraceMempoolAddedTx
      -- | New, valid transaction that was added to the Mempool.
      (Validated (GenTx blk))
      -- | The size of the Mempool before adding the transaction.
      MempoolSize
      -- | The size of the Mempool after adding the transaction.
      MempoolSize
  | TraceMempoolRejectedTx
      -- | New, invalid transaction thas was rejected and thus not added to
      -- the Mempool.
      (GenTx blk)
      -- | The reason for rejecting the transaction.
      (ApplyTxErr blk)
      -- | More details about the reason
      MempoolRejectionDetails
      -- | The current size of the Mempool.
      MempoolSize
  | TraceMempoolRemoveTxs
      -- | Previously valid transactions that are no longer valid because of
      -- changes in the ledger state (details are in the provided 'ApplyTxErr').
      -- These transactions have been removed from the Mempool.
      [(Validated (GenTx blk), ApplyTxErr blk)]
      -- | The current size of the Mempool.
      MempoolSize
  | TraceMempoolManuallyRemovedTxs
      -- | Transactions that have been manually removed from the Mempool.
      (NE.NonEmpty (GenTxId blk))
      -- | Previously valid transactions that are no longer valid because they
      -- dependend on transactions that were manually removed from the
      -- Mempool. These transactions have also been removed from the Mempool.
      --
      -- This list shares not transactions with the list of manually removed
      -- transactions.
      [Validated (GenTx blk)]
      -- | The current size of the Mempool.
      MempoolSize
  | -- | Emitted when the mempool is adjusted after the tip has changed.
    TraceMempoolSynced
      -- | How long the sync operation took.
      EnclosingTimed
  | -- | A sync is not needed, as the point at the tip of the LedgerDB and the
    -- point at the mempool are the same.
    TraceMempoolSyncNotNeeded (Point blk)
  | -- | We will try to add a transaction.
    TraceMempoolAttemptingAdd (GenTx blk)
  | -- | When performing a re-sync we will read the LedgerDB tip twice. This
    -- trace will be emitted if in between those two steps the LedgerDB moved to
    -- an alternative fork. It is completely innocuous but we would like to
    -- double check that it happens very rarely or almost never.
    TraceMempoolTipMovedBetweenSTMBlocks
  deriving (forall x. TraceEventMempool blk -> Rep (TraceEventMempool blk) x)
-> (forall x.
    Rep (TraceEventMempool blk) x -> TraceEventMempool blk)
-> Generic (TraceEventMempool blk)
forall x. Rep (TraceEventMempool blk) x -> TraceEventMempool blk
forall x. TraceEventMempool blk -> Rep (TraceEventMempool blk) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall blk x.
Rep (TraceEventMempool blk) x -> TraceEventMempool blk
forall blk x.
TraceEventMempool blk -> Rep (TraceEventMempool blk) x
$cfrom :: forall blk x.
TraceEventMempool blk -> Rep (TraceEventMempool blk) x
from :: forall x. TraceEventMempool blk -> Rep (TraceEventMempool blk) x
$cto :: forall blk x.
Rep (TraceEventMempool blk) x -> TraceEventMempool blk
to :: forall x. Rep (TraceEventMempool blk) x -> TraceEventMempool blk
Generic

deriving instance
  ( Eq (GenTx blk)
  , Eq (Validated (GenTx blk))
  , Eq (GenTxId blk)
  , Eq (ApplyTxErr blk)
  , StandardHash blk
  ) =>
  Eq (TraceEventMempool blk)

deriving instance
  ( Show (GenTx blk)
  , Show (Validated (GenTx blk))
  , Show (GenTxId blk)
  , Show (ApplyTxErr blk)
  , StandardHash blk
  ) =>
  Show (TraceEventMempool blk)

data MempoolRejectionDetails
  = -- | The ledger's @MEMPOOL@ rule rejected the tx
    MempoolRejectedByLedger
  | -- | The tx violated 'mempoolTimeoutSoft'
    --
    -- It did not violate 'mempoolTimeoutHard', since that would raise an
    -- exception instead of merely rejecting the tx (not even constructing a
    -- 'MempoolTxRejected').
    MempoolRejectedByTimeoutSoft !DiffTime
  deriving (MempoolRejectionDetails -> MempoolRejectionDetails -> Bool
(MempoolRejectionDetails -> MempoolRejectionDetails -> Bool)
-> (MempoolRejectionDetails -> MempoolRejectionDetails -> Bool)
-> Eq MempoolRejectionDetails
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: MempoolRejectionDetails -> MempoolRejectionDetails -> Bool
== :: MempoolRejectionDetails -> MempoolRejectionDetails -> Bool
$c/= :: MempoolRejectionDetails -> MempoolRejectionDetails -> Bool
/= :: MempoolRejectionDetails -> MempoolRejectionDetails -> Bool
Eq, Int -> MempoolRejectionDetails -> ShowS
[MempoolRejectionDetails] -> ShowS
MempoolRejectionDetails -> String
(Int -> MempoolRejectionDetails -> ShowS)
-> (MempoolRejectionDetails -> String)
-> ([MempoolRejectionDetails] -> ShowS)
-> Show MempoolRejectionDetails
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> MempoolRejectionDetails -> ShowS
showsPrec :: Int -> MempoolRejectionDetails -> ShowS
$cshow :: MempoolRejectionDetails -> String
show :: MempoolRejectionDetails -> String
$cshowList :: [MempoolRejectionDetails] -> ShowS
showList :: [MempoolRejectionDetails] -> ShowS
Show)

jsonMempoolRejectionDetails :: MempoolRejectionDetails -> Aeson.Value
jsonMempoolRejectionDetails :: MempoolRejectionDetails -> Value
jsonMempoolRejectionDetails = \case
  MempoolRejectionDetails
MempoolRejectedByLedger ->
    Text -> Value
Aeson.String
      (String -> Text
Text.pack String
"MempoolRejectedByLedger")
  MempoolRejectedByTimeoutSoft DiffTime
dt ->
    [Pair] -> Value
Aeson.object
      [String -> Key
AesonKey.fromString String
"MempoolRejectedByTimeoutSoft" Key -> DiffTime -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
Aeson..= DiffTime
dt]