{-# 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 (..)
  , ValidatedTxWithDiffs (..)
  , 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.Tracer
import qualified Data.Aeson as Aeson
import qualified Data.Aeson.Key as AesonKey
import Data.Bifunctor (second)
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
-------------------------------------------------------------------------------}

-- | We cache the differences produced by validating each transaction, as the
-- current differences in UTxO-HD do not depend on which block the transaction
-- was validated. This means that these differences cannot be "stale", as long
-- as the transaction is considered, the differences will be the same. If we
-- extend UTxO-HD to consider more differences, this might be violated and we
-- will have to reconsider what we can cache and what we can't.
data ValidatedTxWithDiffs blk = ValidatedTxWithDiffs
  { forall blk. ValidatedTxWithDiffs blk -> Validated (GenTx blk)
validatedTx :: !(Validated (GenTx blk))
  , forall blk.
ValidatedTxWithDiffs blk
-> LedgerTables (TickedLedgerState blk) DiffMK
validatedTxDiffs :: !(LedgerTables (TickedLedgerState blk) DiffMK)
  }
  deriving (forall x.
 ValidatedTxWithDiffs blk -> Rep (ValidatedTxWithDiffs blk) x)
-> (forall x.
    Rep (ValidatedTxWithDiffs blk) x -> ValidatedTxWithDiffs blk)
-> Generic (ValidatedTxWithDiffs blk)
forall x.
Rep (ValidatedTxWithDiffs blk) x -> ValidatedTxWithDiffs blk
forall x.
ValidatedTxWithDiffs blk -> Rep (ValidatedTxWithDiffs blk) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall blk x.
Rep (ValidatedTxWithDiffs blk) x -> ValidatedTxWithDiffs blk
forall blk x.
ValidatedTxWithDiffs blk -> Rep (ValidatedTxWithDiffs blk) x
$cfrom :: forall blk x.
ValidatedTxWithDiffs blk -> Rep (ValidatedTxWithDiffs blk) x
from :: forall x.
ValidatedTxWithDiffs blk -> Rep (ValidatedTxWithDiffs blk) x
$cto :: forall blk x.
Rep (ValidatedTxWithDiffs blk) x -> ValidatedTxWithDiffs blk
to :: forall x.
Rep (ValidatedTxWithDiffs blk) x -> ValidatedTxWithDiffs blk
Generic

deriving instance
  ( NoThunks (Validated (GenTx blk))
  , NoThunks (TxIn (LedgerState blk))
  , NoThunks (TxOut (LedgerState blk))
  ) =>
  NoThunks (ValidatedTxWithDiffs blk)

-- | Internal state in the mempool
data InternalState blk = IS
  { forall blk.
InternalState blk
-> TxSeq (TxMeasureWithDiffTime blk) (ValidatedTxWithDiffs blk)
isTxs :: !(TxSeq (TxMeasureWithDiffTime blk) (ValidatedTxWithDiffs 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) (ValidatedTxWithDiffs blk) -> Int
forall a. TxSeq (TxMeasureWithDiffTime blk) a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (TxSeq (TxMeasureWithDiffTime blk) (ValidatedTxWithDiffs blk)
 -> Int)
-> TxSeq (TxMeasureWithDiffTime blk) (ValidatedTxWithDiffs blk)
-> Int
forall a b. (a -> b) -> a -> b
$ InternalState blk
-> TxSeq (TxMeasureWithDiffTime blk) (ValidatedTxWithDiffs blk)
forall blk.
InternalState blk
-> TxSeq (TxMeasureWithDiffTime blk) (ValidatedTxWithDiffs 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) (ValidatedTxWithDiffs blk)
-> TxMeasureWithDiffTime blk
forall sz tx. Measure sz => TxSeq sz tx -> sz
TxSeq.toSize (TxSeq (TxMeasureWithDiffTime blk) (ValidatedTxWithDiffs blk)
 -> TxMeasureWithDiffTime blk)
-> TxSeq (TxMeasureWithDiffTime blk) (ValidatedTxWithDiffs blk)
-> TxMeasureWithDiffTime blk
forall a b. (a -> b) -> a -> b
$ InternalState blk
-> TxSeq (TxMeasureWithDiffTime blk) (ValidatedTxWithDiffs blk)
forall blk.
InternalState blk
-> TxSeq (TxMeasureWithDiffTime blk) (ValidatedTxWithDiffs 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) (ValidatedTxWithDiffs blk)
isTxs = TxSeq (TxMeasureWithDiffTime blk) (ValidatedTxWithDiffs 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 -> STM m (MempoolLedgerDBView m blk)
getCurrentLedgerState :: STM m (MempoolLedgerDBView m blk)
  }

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.
  --
  -- The forker is not tracked as a resource because shutting down the mempool
  -- only happens if the system is going down, and in that case open forkers are unimportant.
  }

-- | 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 :: STM m (MempoolLedgerDBView m blk)
getCurrentLedgerState = 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 (second ledgerStateReadOnlyForker)
          $ ChainDB.openReadOnlyForkerAtPoint
            chainDB
            (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 -> 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) ->
  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)
-> m (MempoolEnv m blk)
initMempoolEnv LedgerInterface m blk
ledgerInterface LedgerCfg (LedgerState blk)
cfg MempoolCapacityBytesOverride
capacityOverride Maybe MempoolTimeoutConfig
mbTimeoutConfig Tracer m (TraceEventMempool blk)
tracer = 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 -> STM m (MempoolLedgerDBView m blk)
forall (m :: * -> *) blk.
LedgerInterface m blk -> STM m (MempoolLedgerDBView m blk)
getCurrentLedgerState LedgerInterface m blk
ledgerInterface
  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 loop to try again here.
    Left{} -> do
      LedgerInterface m blk
-> LedgerCfg (LedgerState blk)
-> MempoolCapacityBytesOverride
-> Maybe MempoolTimeoutConfig
-> Tracer m (TraceEventMempool blk)
-> m (MempoolEnv m blk)
forall (m :: * -> *) blk.
(IOLike m, LedgerSupportsMempool blk, ValidateEnvelope blk) =>
LedgerInterface m blk
-> LedgerConfig blk
-> MempoolCapacityBytesOverride
-> Maybe MempoolTimeoutConfig
-> Tracer m (TraceEventMempool blk)
-> m (MempoolEnv m blk)
initMempoolEnv LedgerInterface m blk
ledgerInterface LedgerCfg (LedgerState blk)
cfg MempoolCapacityBytesOverride
capacityOverride Maybe MempoolTimeoutConfig
mbTimeoutConfig Tracer m (TraceEventMempool blk)
tracer
    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
          , 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), LedgerTables (TickedLedgerState blk) DiffMK)
  , 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),
       LedgerTables (TickedLedgerState blk) DiffMK),
    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),
      LedgerTables (TickedLedgerState blk) DiffMK)
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),
 LedgerTables (TickedLedgerState blk) DiffMK)
-> Either
     (ApplyTxErr blk)
     (Validated (GenTx blk),
      LedgerTables (TickedLedgerState blk) DiffMK)
forall a b. b -> Either a b
Right (Validated (GenTx blk)
vtx, TickedLedgerState blk DiffMK
-> LedgerTables (TickedLedgerState blk) DiffMK
forall (mk :: * -> * -> *).
(CanMapMK mk, CanMapKeysMK mk, ZeroableMK mk) =>
TickedLedgerState blk mk -> LedgerTables (TickedLedgerState blk) mk
forall (l :: LedgerStateKind) (mk :: * -> * -> *).
(HasLedgerTables l, CanMapMK mk, CanMapKeysMK mk, ZeroableMK mk) =>
l mk -> LedgerTables l mk
projectLedgerTables TickedLedgerState blk DiffMK
st')
      , \DiffTimeMeasure
dur ->
          InternalState blk
is
            { isTxs =
                isTxs
                  :> TxTicket
                    (ValidatedTxWithDiffs vtx (projectLedgerTables st'))
                    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) (ValidatedTxWithDiffs blk)
isTxs :: forall blk.
InternalState blk
-> TxSeq (TxMeasureWithDiffTime blk) (ValidatedTxWithDiffs blk)
isTxs :: TxSeq (TxMeasureWithDiffTime blk) (ValidatedTxWithDiffs 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 ::
  forall blk.
  (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) (ValidatedTxWithDiffs 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) (ValidatedTxWithDiffs 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) (ValidatedTxWithDiffs blk)]
txTickets =
  let inputTxs :: [(Validated (GenTx blk),
  LedgerTables (Ticked (LedgerState blk)) DiffMK,
  (TicketNo, TxMeasureWithDiffTime blk))]
inputTxs = (TxTicket (TxMeasureWithDiffTime blk) (ValidatedTxWithDiffs blk)
 -> (Validated (GenTx blk),
     LedgerTables (Ticked (LedgerState blk)) DiffMK,
     (TicketNo, TxMeasureWithDiffTime blk)))
-> [TxTicket
      (TxMeasureWithDiffTime blk) (ValidatedTxWithDiffs blk)]
-> [(Validated (GenTx blk),
     LedgerTables (Ticked (LedgerState blk)) DiffMK,
     (TicketNo, TxMeasureWithDiffTime blk))]
forall a b. (a -> b) -> [a] -> [b]
map TxTicket (TxMeasureWithDiffTime blk) (ValidatedTxWithDiffs blk)
-> (Validated (GenTx blk),
    LedgerTables (Ticked (LedgerState blk)) DiffMK,
    (TicketNo, TxMeasureWithDiffTime blk))
forall {b} {blk}.
TxTicket b (ValidatedTxWithDiffs blk)
-> (Validated (GenTx blk),
    LedgerTables (TickedLedgerState blk) DiffMK, (TicketNo, b))
wrap [TxTicket (TxMeasureWithDiffTime blk) (ValidatedTxWithDiffs blk)]
txTickets
      inputKeys :: LedgerTables (LedgerState blk) KeysMK
inputKeys = ((Validated (GenTx blk),
  LedgerTables (Ticked (LedgerState blk)) DiffMK,
  (TicketNo, TxMeasureWithDiffTime blk))
 -> LedgerTables (LedgerState blk) KeysMK)
-> [(Validated (GenTx blk),
     LedgerTables (Ticked (LedgerState blk)) DiffMK,
     (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),
     LedgerTables (Ticked (LedgerState blk)) DiffMK,
     (TicketNo, TxMeasureWithDiffTime blk))
    -> GenTx blk)
-> (Validated (GenTx blk),
    LedgerTables (Ticked (LedgerState blk)) DiffMK,
    (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),
     LedgerTables (Ticked (LedgerState blk)) DiffMK,
     (TicketNo, TxMeasureWithDiffTime blk))
    -> Validated (GenTx blk))
-> (Validated (GenTx blk),
    LedgerTables (Ticked (LedgerState blk)) DiffMK,
    (TicketNo, TxMeasureWithDiffTime blk))
-> GenTx blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Validated (GenTx blk),
 LedgerTables (Ticked (LedgerState blk)) DiffMK,
 (TicketNo, TxMeasureWithDiffTime blk))
-> Validated (GenTx blk)
forall {a} {b} {c}. (a, b, c) -> a
fst3) [(Validated (GenTx blk),
  LedgerTables (Ticked (LedgerState blk)) DiffMK,
  (TicketNo, TxMeasureWithDiffTime blk))]
inputTxs

      ReapplyTxsResult [Invalidated blk]
err [(Validated (GenTx blk), InputTxDiffs blk Collect,
  (TicketNo, TxMeasureWithDiffTime blk))]
validTxs TickedLedgerState blk EmptyMK
st' =
        forall blk (wtd :: WhatToDoWithTxDiffs) extra.
LedgerSupportsMempool blk =>
LedgerConfig blk
-> SlotNo
-> [(Validated (GenTx blk), InputTxDiffs blk wtd, extra)]
-> TickedLedgerState blk ValuesMK
-> ReapplyTxsResult extra blk wtd
reapplyTxs @blk @Collect LedgerCfg (LedgerState blk)
cfg SlotNo
slot [(Validated (GenTx blk),
  LedgerTables (Ticked (LedgerState blk)) DiffMK,
  (TicketNo, TxMeasureWithDiffTime blk))]
[(Validated (GenTx blk), InputTxDiffs blk Collect,
  (TicketNo, TxMeasureWithDiffTime blk))]
inputTxs (TickedLedgerState blk ValuesMK
 -> ReapplyTxsResult
      (TicketNo, TxMeasureWithDiffTime blk) blk Collect)
-> TickedLedgerState blk ValuesMK
-> ReapplyTxsResult
     (TicketNo, TxMeasureWithDiffTime blk) blk Collect
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 LedgerTables (LedgerState blk) KeysMK
inputKeys TickedLedgerState blk DiffMK
st

      outputKeys :: LedgerTables (LedgerState blk) KeysMK
outputKeys = ((Validated (GenTx blk),
  LedgerTables (Ticked (LedgerState blk)) DiffMK,
  (TicketNo, TxMeasureWithDiffTime blk))
 -> LedgerTables (LedgerState blk) KeysMK)
-> [(Validated (GenTx blk),
     LedgerTables (Ticked (LedgerState blk)) DiffMK,
     (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),
     LedgerTables (Ticked (LedgerState blk)) DiffMK,
     (TicketNo, TxMeasureWithDiffTime blk))
    -> GenTx blk)
-> (Validated (GenTx blk),
    LedgerTables (Ticked (LedgerState blk)) DiffMK,
    (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),
     LedgerTables (Ticked (LedgerState blk)) DiffMK,
     (TicketNo, TxMeasureWithDiffTime blk))
    -> Validated (GenTx blk))
-> (Validated (GenTx blk),
    LedgerTables (Ticked (LedgerState blk)) DiffMK,
    (TicketNo, TxMeasureWithDiffTime blk))
-> GenTx blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Validated (GenTx blk),
 LedgerTables (Ticked (LedgerState blk)) DiffMK,
 (TicketNo, TxMeasureWithDiffTime blk))
-> Validated (GenTx blk)
forall {a} {b} {c}. (a, b, c) -> a
fst3) [(Validated (GenTx blk),
  LedgerTables (Ticked (LedgerState blk)) DiffMK,
  (TicketNo, TxMeasureWithDiffTime blk))]
validTxs
      outputDiffs :: DiffMK (TxIn (LedgerState blk)) (TxOut (LedgerState blk))
outputDiffs = (DiffMK (TxIn (LedgerState blk)) (TxOut (LedgerState blk))
 -> DiffMK (TxIn (LedgerState blk)) (TxOut (LedgerState blk))
 -> DiffMK (TxIn (LedgerState blk)) (TxOut (LedgerState blk)))
-> DiffMK (TxIn (LedgerState blk)) (TxOut (LedgerState blk))
-> [DiffMK (TxIn (LedgerState blk)) (TxOut (LedgerState blk))]
-> DiffMK (TxIn (LedgerState blk)) (TxOut (LedgerState blk))
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
Foldable.foldl' DiffMK (TxIn (LedgerState blk)) (TxOut (LedgerState blk))
-> DiffMK (TxIn (LedgerState blk)) (TxOut (LedgerState blk))
-> DiffMK (TxIn (LedgerState blk)) (TxOut (LedgerState blk))
forall k v. Ord k => DiffMK k v -> DiffMK k v -> DiffMK k v
rawPrependDiffs (Diff (TxIn (LedgerState blk)) (TxOut (LedgerState blk))
-> DiffMK (TxIn (LedgerState blk)) (TxOut (LedgerState blk))
forall k v. Diff k v -> DiffMK k v
DiffMK Diff (TxIn (LedgerState blk)) (TxOut (LedgerState blk))
forall a. Monoid a => a
mempty) ([DiffMK (TxIn (LedgerState blk)) (TxOut (LedgerState blk))]
 -> DiffMK (TxIn (LedgerState blk)) (TxOut (LedgerState blk)))
-> [DiffMK (TxIn (LedgerState blk)) (TxOut (LedgerState blk))]
-> DiffMK (TxIn (LedgerState blk)) (TxOut (LedgerState blk))
forall a b. (a -> b) -> a -> b
$ ((Validated (GenTx blk),
  LedgerTables (Ticked (LedgerState blk)) DiffMK,
  (TicketNo, TxMeasureWithDiffTime blk))
 -> DiffMK (TxIn (LedgerState blk)) (TxOut (LedgerState blk)))
-> [(Validated (GenTx blk),
     LedgerTables (Ticked (LedgerState blk)) DiffMK,
     (TicketNo, TxMeasureWithDiffTime blk))]
-> [DiffMK (TxIn (LedgerState blk)) (TxOut (LedgerState blk))]
forall a b. (a -> b) -> [a] -> [b]
map (LedgerTables (Ticked (LedgerState blk)) DiffMK
-> DiffMK
     (TxIn (Ticked (LedgerState blk)))
     (TxOut (Ticked (LedgerState blk)))
LedgerTables (Ticked (LedgerState blk)) DiffMK
-> DiffMK (TxIn (LedgerState blk)) (TxOut (LedgerState blk))
forall (l :: LedgerStateKind) (mk :: * -> * -> *).
LedgerTables l mk -> mk (TxIn l) (TxOut l)
getLedgerTables (LedgerTables (Ticked (LedgerState blk)) DiffMK
 -> DiffMK (TxIn (LedgerState blk)) (TxOut (LedgerState blk)))
-> ((Validated (GenTx blk),
     LedgerTables (Ticked (LedgerState blk)) DiffMK,
     (TicketNo, TxMeasureWithDiffTime blk))
    -> LedgerTables (Ticked (LedgerState blk)) DiffMK)
-> (Validated (GenTx blk),
    LedgerTables (Ticked (LedgerState blk)) DiffMK,
    (TicketNo, TxMeasureWithDiffTime blk))
-> DiffMK (TxIn (LedgerState blk)) (TxOut (LedgerState blk))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Validated (GenTx blk),
 LedgerTables (Ticked (LedgerState blk)) DiffMK,
 (TicketNo, TxMeasureWithDiffTime blk))
-> LedgerTables (Ticked (LedgerState blk)) DiffMK
forall {a} {b} {c}. (a, b, c) -> b
snd3) [(Validated (GenTx blk),
  LedgerTables (Ticked (LedgerState blk)) DiffMK,
  (TicketNo, TxMeasureWithDiffTime blk))]
validTxs
   in InternalState blk -> [Invalidated blk] -> RevalidateTxsResult blk
forall blk.
InternalState blk -> [Invalidated blk] -> RevalidateTxsResult blk
RevalidateTxsResult
        ( IS
            { isTxs :: TxSeq (TxMeasureWithDiffTime blk) (ValidatedTxWithDiffs blk)
isTxs = [TxTicket (TxMeasureWithDiffTime blk) (ValidatedTxWithDiffs blk)]
-> TxSeq (TxMeasureWithDiffTime blk) (ValidatedTxWithDiffs blk)
forall sz tx. Measure sz => [TxTicket sz tx] -> TxSeq sz tx
TxSeq.fromList ([TxTicket (TxMeasureWithDiffTime blk) (ValidatedTxWithDiffs blk)]
 -> TxSeq (TxMeasureWithDiffTime blk) (ValidatedTxWithDiffs blk))
-> [TxTicket
      (TxMeasureWithDiffTime blk) (ValidatedTxWithDiffs blk)]
-> TxSeq (TxMeasureWithDiffTime blk) (ValidatedTxWithDiffs blk)
forall a b. (a -> b) -> a -> b
$ ((Validated (GenTx blk),
  LedgerTables (Ticked (LedgerState blk)) DiffMK,
  (TicketNo, TxMeasureWithDiffTime blk))
 -> TxTicket (TxMeasureWithDiffTime blk) (ValidatedTxWithDiffs blk))
-> [(Validated (GenTx blk),
     LedgerTables (Ticked (LedgerState blk)) DiffMK,
     (TicketNo, TxMeasureWithDiffTime blk))]
-> [TxTicket
      (TxMeasureWithDiffTime blk) (ValidatedTxWithDiffs blk)]
forall a b. (a -> b) -> [a] -> [b]
map (Validated (GenTx blk),
 LedgerTables (Ticked (LedgerState blk)) DiffMK,
 (TicketNo, TxMeasureWithDiffTime blk))
-> TxTicket (TxMeasureWithDiffTime blk) (ValidatedTxWithDiffs blk)
forall {blk} {sz}.
(Validated (GenTx blk),
 LedgerTables (TickedLedgerState blk) DiffMK, (TicketNo, sz))
-> TxTicket sz (ValidatedTxWithDiffs blk)
unwrap [(Validated (GenTx blk),
  LedgerTables (Ticked (LedgerState blk)) DiffMK,
  (TicketNo, TxMeasureWithDiffTime blk))]
validTxs
            , 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),
  LedgerTables (Ticked (LedgerState blk)) DiffMK,
  (TicketNo, TxMeasureWithDiffTime blk))
 -> GenTxId blk)
-> [(Validated (GenTx blk),
     LedgerTables (Ticked (LedgerState blk)) DiffMK,
     (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),
     LedgerTables (Ticked (LedgerState blk)) DiffMK,
     (TicketNo, TxMeasureWithDiffTime blk))
    -> GenTx blk)
-> (Validated (GenTx blk),
    LedgerTables (Ticked (LedgerState blk)) DiffMK,
    (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),
     LedgerTables (Ticked (LedgerState blk)) DiffMK,
     (TicketNo, TxMeasureWithDiffTime blk))
    -> Validated (GenTx blk))
-> (Validated (GenTx blk),
    LedgerTables (Ticked (LedgerState blk)) DiffMK,
    (TicketNo, TxMeasureWithDiffTime blk))
-> GenTx blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Validated (GenTx blk),
 LedgerTables (Ticked (LedgerState blk)) DiffMK,
 (TicketNo, TxMeasureWithDiffTime blk))
-> Validated (GenTx blk)
forall {a} {b} {c}. (a, b, c) -> a
fst3) [(Validated (GenTx blk),
  LedgerTables (Ticked (LedgerState blk)) DiffMK,
  (TicketNo, TxMeasureWithDiffTime blk))]
validTxs
            , isTxKeys :: LedgerTables (LedgerState blk) KeysMK
isTxKeys = LedgerTables (LedgerState blk) KeysMK
outputKeys
            , 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
outputKeys
            , isLedgerState :: TickedLedgerState blk DiffMK
isLedgerState =
                TickedLedgerState blk EmptyMK
st'
                  TickedLedgerState blk EmptyMK
-> LedgerTables (Ticked (LedgerState blk)) DiffMK
-> TickedLedgerState blk DiffMK
forall (mk :: * -> * -> *) (any :: * -> * -> *).
(CanMapMK mk, CanMapKeysMK mk, ZeroableMK mk) =>
Ticked (LedgerState blk) any
-> LedgerTables (Ticked (LedgerState blk)) mk
-> Ticked (LedgerState blk) mk
forall (l :: LedgerStateKind) (mk :: * -> * -> *)
       (any :: * -> * -> *).
(HasLedgerTables l, CanMapMK mk, CanMapKeysMK mk, ZeroableMK mk) =>
l any -> LedgerTables l mk -> l mk
`withLedgerTables` ((forall k v.
 LedgerTableConstraints' (Ticked (LedgerState blk)) k v =>
 DiffMK k v -> DiffMK k v -> DiffMK k v)
-> LedgerTables (Ticked (LedgerState blk)) DiffMK
-> LedgerTables (Ticked (LedgerState blk)) DiffMK
-> LedgerTables (Ticked (LedgerState blk)) DiffMK
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 DiffMK k v -> DiffMK k v -> DiffMK k v
forall k v. Ord k => DiffMK k v -> DiffMK k v -> DiffMK k v
forall k v.
LedgerTableConstraints' (Ticked (LedgerState blk)) k v =>
DiffMK k v -> DiffMK k v -> DiffMK k v
rawPrependDiffs (TickedLedgerState blk DiffMK
-> LedgerTables (Ticked (LedgerState blk)) DiffMK
forall (mk :: * -> * -> *).
(CanMapMK mk, CanMapKeysMK mk, ZeroableMK mk) =>
Ticked (LedgerState blk) mk
-> LedgerTables (Ticked (LedgerState blk)) mk
forall (l :: LedgerStateKind) (mk :: * -> * -> *).
(HasLedgerTables l, CanMapMK mk, CanMapKeysMK mk, ZeroableMK mk) =>
l mk -> LedgerTables l mk
projectLedgerTables TickedLedgerState blk DiffMK
st) (DiffMK
  (TxIn (Ticked (LedgerState blk)))
  (TxOut (Ticked (LedgerState blk)))
-> LedgerTables (Ticked (LedgerState blk)) DiffMK
forall (l :: LedgerStateKind) (mk :: * -> * -> *).
mk (TxIn l) (TxOut l) -> LedgerTables l mk
LedgerTables DiffMK
  (TxIn (Ticked (LedgerState blk)))
  (TxOut (Ticked (LedgerState blk)))
DiffMK (TxIn (LedgerState blk)) (TxOut (LedgerState blk))
outputDiffs))
            , 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 EmptyMK
-> MempoolCapacityBytesOverride
-> TxMeasure blk
forall blk (mk :: * -> * -> *).
LedgerSupportsMempool blk =>
LedgerConfig blk
-> TickedLedgerState blk mk
-> MempoolCapacityBytesOverride
-> TxMeasure blk
computeMempoolCapacity LedgerCfg (LedgerState blk)
cfg TickedLedgerState blk EmptyMK
st' MempoolCapacityBytesOverride
capacityOverride
            }
        )
        [Invalidated blk]
err
 where
  wrap :: TxTicket b (ValidatedTxWithDiffs blk)
-> (Validated (GenTx blk),
    LedgerTables (TickedLedgerState blk) DiffMK, (TicketNo, b))
wrap = \(TxTicket (ValidatedTxWithDiffs Validated (GenTx blk)
tx LedgerTables (TickedLedgerState blk) DiffMK
df) TicketNo
tk b
tz) -> (Validated (GenTx blk)
tx, LedgerTables (TickedLedgerState blk) DiffMK
df, (TicketNo
tk, b
tz))
  unwrap :: (Validated (GenTx blk),
 LedgerTables (TickedLedgerState blk) DiffMK, (TicketNo, sz))
-> TxTicket sz (ValidatedTxWithDiffs blk)
unwrap = \(Validated (GenTx blk)
tx, LedgerTables (TickedLedgerState blk) DiffMK
df, (TicketNo
tk, sz
tz)) -> ValidatedTxWithDiffs blk
-> TicketNo -> sz -> TxTicket sz (ValidatedTxWithDiffs blk)
forall sz tx. tx -> TicketNo -> sz -> TxTicket sz tx
TxTicket (Validated (GenTx blk)
-> LedgerTables (TickedLedgerState blk) DiffMK
-> ValidatedTxWithDiffs blk
forall blk.
Validated (GenTx blk)
-> LedgerTables (TickedLedgerState blk) DiffMK
-> ValidatedTxWithDiffs blk
ValidatedTxWithDiffs Validated (GenTx blk)
tx LedgerTables (TickedLedgerState blk) DiffMK
df) TicketNo
tk sz
tz
  fst3 :: (a, b, c) -> a
fst3 (a
x, b
_, c
_) = a
x
  snd3 :: (a, b, c) -> b
snd3 (a
_, b
x, c
_) = b
x

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 ::
  forall blk.
  (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 ->
  TicketNo ->
  [TxTicket (TxMeasureWithDiffTime blk) (ValidatedTxWithDiffs 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) (ValidatedTxWithDiffs 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) (ValidatedTxWithDiffs blk)]
txTickets =
  let inputTxs :: [(Validated (GenTx blk), (),
  (LedgerTables (TickedLedgerState blk) DiffMK, TicketNo,
   TxMeasureWithDiffTime blk))]
inputTxs = (TxTicket (TxMeasureWithDiffTime blk) (ValidatedTxWithDiffs blk)
 -> (Validated (GenTx blk), (),
     (LedgerTables (TickedLedgerState blk) DiffMK, TicketNo,
      TxMeasureWithDiffTime blk)))
-> [TxTicket
      (TxMeasureWithDiffTime blk) (ValidatedTxWithDiffs blk)]
-> [(Validated (GenTx blk), (),
     (LedgerTables (TickedLedgerState blk) DiffMK, TicketNo,
      TxMeasureWithDiffTime blk))]
forall a b. (a -> b) -> [a] -> [b]
map TxTicket (TxMeasureWithDiffTime blk) (ValidatedTxWithDiffs blk)
-> (Validated (GenTx blk), (),
    (LedgerTables (TickedLedgerState blk) DiffMK, TicketNo,
     TxMeasureWithDiffTime blk))
forall {c} {blk}.
TxTicket c (ValidatedTxWithDiffs blk)
-> (Validated (GenTx blk), (),
    (LedgerTables (TickedLedgerState blk) DiffMK, TicketNo, c))
wrap [TxTicket (TxMeasureWithDiffTime blk) (ValidatedTxWithDiffs blk)]
txTickets
      inputKeys :: LedgerTables (LedgerState blk) KeysMK
inputKeys = ((Validated (GenTx blk), (),
  (LedgerTables (TickedLedgerState blk) DiffMK, TicketNo,
   TxMeasureWithDiffTime blk))
 -> LedgerTables (LedgerState blk) KeysMK)
-> [(Validated (GenTx blk), (),
     (LedgerTables (TickedLedgerState blk) DiffMK, 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), (),
     (LedgerTables (TickedLedgerState blk) DiffMK, TicketNo,
      TxMeasureWithDiffTime blk))
    -> GenTx blk)
-> (Validated (GenTx blk), (),
    (LedgerTables (TickedLedgerState blk) DiffMK, 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), (),
     (LedgerTables (TickedLedgerState blk) DiffMK, TicketNo,
      TxMeasureWithDiffTime blk))
    -> Validated (GenTx blk))
-> (Validated (GenTx blk), (),
    (LedgerTables (TickedLedgerState blk) DiffMK, TicketNo,
     TxMeasureWithDiffTime blk))
-> GenTx blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Validated (GenTx blk), (),
 (LedgerTables (TickedLedgerState blk) DiffMK, TicketNo,
  TxMeasureWithDiffTime blk))
-> Validated (GenTx blk)
forall {a} {b} {c}. (a, b, c) -> a
fst3) [(Validated (GenTx blk), (),
  (LedgerTables (TickedLedgerState blk) DiffMK, TicketNo,
   TxMeasureWithDiffTime blk))]
inputTxs

      ReapplyTxsResult [Invalidated blk]
_ [(Validated (GenTx blk), InputTxDiffs blk Discard,
  (LedgerTables (TickedLedgerState blk) DiffMK, TicketNo,
   TxMeasureWithDiffTime blk))]
validatedTxs TickedLedgerState blk EmptyMK
st' =
        forall blk (wtd :: WhatToDoWithTxDiffs) extra.
LedgerSupportsMempool blk =>
LedgerConfig blk
-> SlotNo
-> [(Validated (GenTx blk), InputTxDiffs blk wtd, extra)]
-> TickedLedgerState blk ValuesMK
-> ReapplyTxsResult extra blk wtd
reapplyTxs @blk @Discard LedgerCfg (LedgerState blk)
cfg SlotNo
slot [(Validated (GenTx blk), (),
  (LedgerTables (TickedLedgerState blk) DiffMK, TicketNo,
   TxMeasureWithDiffTime blk))]
[(Validated (GenTx blk), InputTxDiffs blk Discard,
  (LedgerTables (TickedLedgerState blk) DiffMK, TicketNo,
   TxMeasureWithDiffTime blk))]
inputTxs (TickedLedgerState blk ValuesMK
 -> ReapplyTxsResult
      (LedgerTables (TickedLedgerState blk) DiffMK, TicketNo,
       TxMeasureWithDiffTime blk)
      blk
      Discard)
-> TickedLedgerState blk ValuesMK
-> ReapplyTxsResult
     (LedgerTables (TickedLedgerState blk) DiffMK, TicketNo,
      TxMeasureWithDiffTime blk)
     blk
     Discard
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 LedgerTables (LedgerState blk) KeysMK
inputKeys 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) (ValidatedTxWithDiffs blk)
isTxs = [TxTicket (TxMeasureWithDiffTime blk) (ValidatedTxWithDiffs blk)]
-> TxSeq (TxMeasureWithDiffTime blk) (ValidatedTxWithDiffs blk)
forall sz tx. Measure sz => [TxTicket sz tx] -> TxSeq sz tx
TxSeq.fromList ([TxTicket (TxMeasureWithDiffTime blk) (ValidatedTxWithDiffs blk)]
 -> TxSeq (TxMeasureWithDiffTime blk) (ValidatedTxWithDiffs blk))
-> [TxTicket
      (TxMeasureWithDiffTime blk) (ValidatedTxWithDiffs blk)]
-> TxSeq (TxMeasureWithDiffTime blk) (ValidatedTxWithDiffs blk)
forall a b. (a -> b) -> a -> b
$ ((Validated (GenTx blk), (),
  (LedgerTables (TickedLedgerState blk) DiffMK, TicketNo,
   TxMeasureWithDiffTime blk))
 -> TxTicket (TxMeasureWithDiffTime blk) (ValidatedTxWithDiffs blk))
-> [(Validated (GenTx blk), (),
     (LedgerTables (TickedLedgerState blk) DiffMK, TicketNo,
      TxMeasureWithDiffTime blk))]
-> [TxTicket
      (TxMeasureWithDiffTime blk) (ValidatedTxWithDiffs blk)]
forall a b. (a -> b) -> [a] -> [b]
map (Validated (GenTx blk), (),
 (LedgerTables (TickedLedgerState blk) DiffMK, TicketNo,
  TxMeasureWithDiffTime blk))
-> TxTicket (TxMeasureWithDiffTime blk) (ValidatedTxWithDiffs blk)
forall {blk} {sz}.
(Validated (GenTx blk), (),
 (LedgerTables (TickedLedgerState blk) DiffMK, TicketNo, sz))
-> TxTicket sz (ValidatedTxWithDiffs blk)
unwrap [(Validated (GenTx blk), (),
  (LedgerTables (TickedLedgerState blk) DiffMK, TicketNo,
   TxMeasureWithDiffTime blk))]
validatedTxs
          , 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), (),
  (LedgerTables (TickedLedgerState blk) DiffMK, TicketNo,
   TxMeasureWithDiffTime blk))
 -> GenTxId blk)
-> [(Validated (GenTx blk), (),
     (LedgerTables (TickedLedgerState blk) DiffMK, 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), (),
     (LedgerTables (TickedLedgerState blk) DiffMK, TicketNo,
      TxMeasureWithDiffTime blk))
    -> GenTx blk)
-> (Validated (GenTx blk), (),
    (LedgerTables (TickedLedgerState blk) DiffMK, 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), (),
     (LedgerTables (TickedLedgerState blk) DiffMK, TicketNo,
      TxMeasureWithDiffTime blk))
    -> Validated (GenTx blk))
-> (Validated (GenTx blk), (),
    (LedgerTables (TickedLedgerState blk) DiffMK, TicketNo,
     TxMeasureWithDiffTime blk))
-> GenTx blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Validated (GenTx blk), (),
 (LedgerTables (TickedLedgerState blk) DiffMK, TicketNo,
  TxMeasureWithDiffTime blk))
-> Validated (GenTx blk)
forall {a} {b} {c}. (a, b, c) -> a
fst3) [(Validated (GenTx blk), (),
  (LedgerTables (TickedLedgerState blk) DiffMK, TicketNo,
   TxMeasureWithDiffTime blk))]
validatedTxs
          , -- 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
          , -- This one can use the empty tables because we don't use the
            -- resulting ledger state except for its point
            isLedgerState :: TickedLedgerState blk DiffMK
isLedgerState = TickedLedgerState blk EmptyMK
st' TickedLedgerState blk EmptyMK
-> LedgerTables (TickedLedgerState blk) DiffMK
-> TickedLedgerState blk DiffMK
forall (mk :: * -> * -> *) (any :: * -> * -> *).
(CanMapMK mk, CanMapKeysMK mk, ZeroableMK mk) =>
Ticked (LedgerState blk) any
-> LedgerTables (TickedLedgerState blk) mk
-> Ticked (LedgerState blk) mk
forall (l :: LedgerStateKind) (mk :: * -> * -> *)
       (any :: * -> * -> *).
(HasLedgerTables l, CanMapMK mk, CanMapKeysMK mk, ZeroableMK mk) =>
l any -> LedgerTables l mk -> l mk
`withLedgerTables` LedgerTables (TickedLedgerState blk) DiffMK
forall (mk :: * -> * -> *) (l :: LedgerStateKind).
(ZeroableMK mk, LedgerTableConstraints l) =>
LedgerTables l mk
emptyLedgerTables
          , 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 EmptyMK
-> MempoolCapacityBytesOverride
-> TxMeasure blk
forall blk (mk :: * -> * -> *).
LedgerSupportsMempool blk =>
LedgerConfig blk
-> TickedLedgerState blk mk
-> MempoolCapacityBytesOverride
-> TxMeasure blk
computeMempoolCapacity LedgerCfg (LedgerState blk)
cfg TickedLedgerState blk EmptyMK
st' MempoolCapacityBytesOverride
capacityOverride
          }
 where
  fst3 :: (a, b, c) -> a
fst3 (a
x, b
_, c
_) = a
x
  wrap :: TxTicket c (ValidatedTxWithDiffs blk)
-> (Validated (GenTx blk), (),
    (LedgerTables (TickedLedgerState blk) DiffMK, TicketNo, c))
wrap = (\(TxTicket (ValidatedTxWithDiffs Validated (GenTx blk)
tx LedgerTables (TickedLedgerState blk) DiffMK
df) TicketNo
tk c
tz) -> (Validated (GenTx blk)
tx, (), (LedgerTables (TickedLedgerState blk) DiffMK
df, TicketNo
tk, c
tz)))
  unwrap :: (Validated (GenTx blk), (),
 (LedgerTables (TickedLedgerState blk) DiffMK, TicketNo, sz))
-> TxTicket sz (ValidatedTxWithDiffs blk)
unwrap = (\(Validated (GenTx blk)
tx, (), (LedgerTables (TickedLedgerState blk) DiffMK
df, TicketNo
tk, sz
tz)) -> (ValidatedTxWithDiffs blk
-> TicketNo -> sz -> TxTicket sz (ValidatedTxWithDiffs blk)
forall sz tx. tx -> TicketNo -> sz -> TxTicket sz tx
TxTicket (Validated (GenTx blk)
-> LedgerTables (TickedLedgerState blk) DiffMK
-> ValidatedTxWithDiffs blk
forall blk.
Validated (GenTx blk)
-> LedgerTables (TickedLedgerState blk) DiffMK
-> ValidatedTxWithDiffs blk
ValidatedTxWithDiffs Validated (GenTx blk)
tx LedgerTables (TickedLedgerState blk) DiffMK
df) TicketNo
tk sz
tz))

{-------------------------------------------------------------------------------
  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 blk
snapshotStateHash = Point blk -> ChainHash blk
forall {k} (block :: k). Point block -> ChainHash block
pointHash (Point blk -> ChainHash blk) -> Point blk -> ChainHash blk
forall a b. (a -> b) -> a -> b
$ 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
$ Ticked (LedgerState 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 (Ticked (LedgerState blk) DiffMK -> Point (TickedLedgerState blk))
-> Ticked (LedgerState blk) DiffMK -> Point (TickedLedgerState blk)
forall a b. (a -> b) -> a -> b
$ InternalState blk -> Ticked (LedgerState 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
$ Ticked (LedgerState 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 (Ticked (LedgerState blk) DiffMK -> Point (TickedLedgerState blk))
-> Ticked (LedgerState blk) DiffMK -> Point (TickedLedgerState blk)
forall a b. (a -> b) -> a -> b
$ InternalState blk -> Ticked (LedgerState 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) (ValidatedTxWithDiffs blk)
isTxs :: forall blk.
InternalState blk
-> TxSeq (TxMeasureWithDiffTime blk) (ValidatedTxWithDiffs blk)
isTxs :: TxSeq (TxMeasureWithDiffTime blk) (ValidatedTxWithDiffs blk)
isTxs} =
    (\[(ValidatedTxWithDiffs blk, TicketNo, TxMeasureWithDiffTime blk)]
x -> [(ValidatedTxWithDiffs blk -> Validated (GenTx blk)
forall blk. ValidatedTxWithDiffs blk -> Validated (GenTx blk)
validatedTx ValidatedTxWithDiffs blk
a, TicketNo
b, TxMeasureWithDiffTime blk -> TxMeasure blk
forall blk. TxMeasureWithDiffTime blk -> TxMeasure blk
forgetTxMeasureWithDiffTime TxMeasureWithDiffTime blk
c) | (ValidatedTxWithDiffs blk
a, TicketNo
b, TxMeasureWithDiffTime blk
c) <- [(ValidatedTxWithDiffs blk, TicketNo, TxMeasureWithDiffTime blk)]
x])
      ([(ValidatedTxWithDiffs blk, TicketNo, TxMeasureWithDiffTime blk)]
 -> [(Validated (GenTx blk), TicketNo, TxMeasure blk)])
-> (TicketNo
    -> [(ValidatedTxWithDiffs blk, TicketNo,
         TxMeasureWithDiffTime blk)])
-> TicketNo
-> [(Validated (GenTx blk), TicketNo, TxMeasure blk)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxSeq (TxMeasureWithDiffTime blk) (ValidatedTxWithDiffs blk)
-> [(ValidatedTxWithDiffs blk, TicketNo,
     TxMeasureWithDiffTime blk)]
forall sz tx. TxSeq sz tx -> [(tx, TicketNo, sz)]
TxSeq.toTuples
      (TxSeq (TxMeasureWithDiffTime blk) (ValidatedTxWithDiffs blk)
 -> [(ValidatedTxWithDiffs blk, TicketNo,
      TxMeasureWithDiffTime blk)])
-> (TicketNo
    -> TxSeq (TxMeasureWithDiffTime blk) (ValidatedTxWithDiffs blk))
-> TicketNo
-> [(ValidatedTxWithDiffs blk, TicketNo,
     TxMeasureWithDiffTime blk)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TxSeq (TxMeasureWithDiffTime blk) (ValidatedTxWithDiffs blk),
 TxSeq (TxMeasureWithDiffTime blk) (ValidatedTxWithDiffs blk))
-> TxSeq (TxMeasureWithDiffTime blk) (ValidatedTxWithDiffs blk)
forall a b. (a, b) -> b
snd
      ((TxSeq (TxMeasureWithDiffTime blk) (ValidatedTxWithDiffs blk),
  TxSeq (TxMeasureWithDiffTime blk) (ValidatedTxWithDiffs blk))
 -> TxSeq (TxMeasureWithDiffTime blk) (ValidatedTxWithDiffs blk))
-> (TicketNo
    -> (TxSeq (TxMeasureWithDiffTime blk) (ValidatedTxWithDiffs blk),
        TxSeq (TxMeasureWithDiffTime blk) (ValidatedTxWithDiffs blk)))
-> TicketNo
-> TxSeq (TxMeasureWithDiffTime blk) (ValidatedTxWithDiffs blk)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxSeq (TxMeasureWithDiffTime blk) (ValidatedTxWithDiffs blk)
-> TicketNo
-> (TxSeq (TxMeasureWithDiffTime blk) (ValidatedTxWithDiffs blk),
    TxSeq (TxMeasureWithDiffTime blk) (ValidatedTxWithDiffs blk))
forall sz tx.
Measure sz =>
TxSeq sz tx -> TicketNo -> (TxSeq sz tx, TxSeq sz tx)
TxSeq.splitAfterTicketNo TxSeq (TxMeasureWithDiffTime blk) (ValidatedTxWithDiffs 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) (ValidatedTxWithDiffs blk)
isTxs :: forall blk.
InternalState blk
-> TxSeq (TxMeasureWithDiffTime blk) (ValidatedTxWithDiffs blk)
isTxs :: TxSeq (TxMeasureWithDiffTime blk) (ValidatedTxWithDiffs blk)
isTxs} TxMeasure blk
limit =
    ((TxTicket (TxMeasureWithDiffTime blk) (ValidatedTxWithDiffs blk)
 -> Validated (GenTx blk))
-> [TxTicket
      (TxMeasureWithDiffTime blk) (ValidatedTxWithDiffs blk)]
-> [Validated (GenTx blk)]
forall a b. (a -> b) -> [a] -> [b]
map (ValidatedTxWithDiffs blk -> Validated (GenTx blk)
forall blk. ValidatedTxWithDiffs blk -> Validated (GenTx blk)
validatedTx (ValidatedTxWithDiffs blk -> Validated (GenTx blk))
-> (TxTicket (TxMeasureWithDiffTime blk) (ValidatedTxWithDiffs blk)
    -> ValidatedTxWithDiffs blk)
-> TxTicket (TxMeasureWithDiffTime blk) (ValidatedTxWithDiffs blk)
-> Validated (GenTx blk)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxTicket (TxMeasureWithDiffTime blk) (ValidatedTxWithDiffs blk)
-> ValidatedTxWithDiffs blk
forall sz tx. TxTicket sz tx -> tx
TxSeq.txTicketTx) (TxSeq (TxMeasureWithDiffTime blk) (ValidatedTxWithDiffs blk)
-> [TxTicket
      (TxMeasureWithDiffTime blk) (ValidatedTxWithDiffs blk)]
forall sz tx. TxSeq sz tx -> [TxTicket sz tx]
TxSeq.toList TxSeq (TxMeasureWithDiffTime blk) (ValidatedTxWithDiffs blk)
x), TxSeq (TxMeasureWithDiffTime blk) (ValidatedTxWithDiffs blk)
-> TxMeasureWithDiffTime blk
forall sz tx. Measure sz => TxSeq sz tx -> sz
TxSeq.toSize TxSeq (TxMeasureWithDiffTime blk) (ValidatedTxWithDiffs blk)
x)
   where
    (TxSeq (TxMeasureWithDiffTime blk) (ValidatedTxWithDiffs blk)
x, TxSeq (TxMeasureWithDiffTime blk) (ValidatedTxWithDiffs blk)
_y) = TxSeq (TxMeasureWithDiffTime blk) (ValidatedTxWithDiffs blk)
-> TxMeasureWithDiffTime blk
-> (TxSeq (TxMeasureWithDiffTime blk) (ValidatedTxWithDiffs blk),
    TxSeq (TxMeasureWithDiffTime blk) (ValidatedTxWithDiffs blk))
forall sz tx.
Measure sz =>
TxSeq sz tx -> sz -> (TxSeq sz tx, TxSeq sz tx)
TxSeq.splitAfterTxSize TxSeq (TxMeasureWithDiffTime blk) (ValidatedTxWithDiffs blk)
isTxs (TxMeasureWithDiffTime blk
 -> (TxSeq (TxMeasureWithDiffTime blk) (ValidatedTxWithDiffs blk),
     TxSeq (TxMeasureWithDiffTime blk) (ValidatedTxWithDiffs blk)))
-> TxMeasureWithDiffTime blk
-> (TxSeq (TxMeasureWithDiffTime blk) (ValidatedTxWithDiffs blk),
    TxSeq (TxMeasureWithDiffTime blk) (ValidatedTxWithDiffs 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) (ValidatedTxWithDiffs blk)
isTxs :: forall blk.
InternalState blk
-> TxSeq (TxMeasureWithDiffTime blk) (ValidatedTxWithDiffs blk)
isTxs :: TxSeq (TxMeasureWithDiffTime blk) (ValidatedTxWithDiffs blk)
isTxs} = (ValidatedTxWithDiffs blk -> Validated (GenTx blk))
-> Maybe (ValidatedTxWithDiffs blk)
-> Maybe (Validated (GenTx blk))
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ValidatedTxWithDiffs blk -> Validated (GenTx blk)
forall blk. ValidatedTxWithDiffs blk -> Validated (GenTx blk)
validatedTx (Maybe (ValidatedTxWithDiffs blk) -> Maybe (Validated (GenTx blk)))
-> (TicketNo -> Maybe (ValidatedTxWithDiffs blk))
-> TicketNo
-> Maybe (Validated (GenTx blk))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TxSeq (TxMeasureWithDiffTime blk) (ValidatedTxWithDiffs blk)
isTxs TxSeq (TxMeasureWithDiffTime blk) (ValidatedTxWithDiffs blk)
-> TicketNo -> Maybe (ValidatedTxWithDiffs 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]