{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# 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 (..)
  , chainDBLedgerInterface
    -- * Validation
  , ValidationResult (..)
  , extendVRNew
  , extendVRPrevApplied
  , revalidateTxsFor
  , validateStateFor
    -- * Tracing
  , TraceEventMempool (..)
    -- * Conversions
  , internalStateFromVR
  , snapshotFromIS
  , validationResultFromIS
    -- * Ticking a ledger state
  , tickLedgerState
  ) where

import           Control.Concurrent.Class.MonadMVar (MVar, newMVar)
import           Control.Exception (assert)
import           Control.Monad.Trans.Except (runExcept)
import           Control.Tracer
import           Data.Maybe (isNothing)
import           Data.Set (Set)
import qualified Data.Set as Set
import           Data.Typeable
import           GHC.Generics (Generic)
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.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.Util (repeatedly)
import           Ouroboros.Consensus.Util.Enclose (EnclosingTimed)
import           Ouroboros.Consensus.Util.IOLike hiding (newMVar)

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

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

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

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

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

      -- | 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 -> SlotNo
isSlotNo       :: !SlotNo

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

      -- | Current maximum capacity of the Mempool. Result of
      -- 'computeMempoolCapacity' using the current chain's
      -- 'TickedLedgerState'.
      --
      -- NOTE: this does not correspond to 'isLedgerState', which is the
      -- 'TickedLedgerState' /after/ applying the transactions in the Mempool.
      -- There might be a transaction in the Mempool triggering a change in
      -- the maximum transaction capacity of a block, which would change the
      -- Mempool's capacity (unless overridden). We don't want the Mempool's
      -- capacity to depend on its contents. The mempool is assuming /all/ its
      -- transactions will be in the next block. So any changes caused by that
      -- block will take effect after applying it and will only affect the
      -- next block.
    , forall blk. InternalState blk -> TxMeasure blk
isCapacity     :: !(TxMeasure blk)
    }
  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 (Ticked (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 (TxMeasure blk) (Validated (GenTx blk)) -> Int
forall a. TxSeq (TxMeasure blk) a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (TxSeq (TxMeasure blk) (Validated (GenTx blk)) -> Int)
-> TxSeq (TxMeasure blk) (Validated (GenTx blk)) -> Int
forall a b. (a -> b) -> a -> b
$ InternalState blk -> TxSeq (TxMeasure blk) (Validated (GenTx blk))
forall blk.
InternalState blk -> TxSeq (TxMeasure 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
$ TxSeq (TxMeasure blk) (Validated (GenTx blk)) -> TxMeasure blk
forall sz tx. Measure sz => TxSeq sz tx -> sz
TxSeq.toSize (TxSeq (TxMeasure blk) (Validated (GenTx blk)) -> TxMeasure blk)
-> TxSeq (TxMeasure blk) (Validated (GenTx blk)) -> TxMeasure blk
forall a b. (a -> b) -> a -> b
$ InternalState blk -> TxSeq (TxMeasure blk) (Validated (GenTx blk))
forall blk.
InternalState blk -> TxSeq (TxMeasure blk) (Validated (GenTx blk))
isTxs InternalState blk
is
  }

initInternalState ::
     LedgerSupportsMempool blk
  => MempoolCapacityBytesOverride
  -> TicketNo  -- ^ Used for 'isLastTicketNo'
  -> LedgerConfig blk
  -> SlotNo
  -> TickedLedgerState blk
  -> InternalState blk
initInternalState :: forall blk.
LedgerSupportsMempool blk =>
MempoolCapacityBytesOverride
-> TicketNo
-> LedgerConfig blk
-> SlotNo
-> TickedLedgerState blk
-> InternalState blk
initInternalState MempoolCapacityBytesOverride
capacityOverride TicketNo
lastTicketNo LedgerConfig blk
cfg SlotNo
slot TickedLedgerState blk
st = IS {
      isTxs :: TxSeq (TxMeasure blk) (Validated (GenTx blk))
isTxs          = TxSeq (TxMeasure 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
    , isLedgerState :: TickedLedgerState blk
isLedgerState  = TickedLedgerState blk
st
    , isTip :: ChainHash blk
isTip          = ChainHash (TickedLedgerState blk) -> ChainHash blk
forall {k1} {k2} (b :: k1) (b' :: k2).
Coercible (HeaderHash b) (HeaderHash b') =>
ChainHash b -> ChainHash b'
castHash (TickedLedgerState blk -> ChainHash (TickedLedgerState blk)
forall l. GetTip l => l -> ChainHash l
getTipHash TickedLedgerState blk
st)
    , isSlotNo :: SlotNo
isSlotNo       = SlotNo
slot
    , isLastTicketNo :: TicketNo
isLastTicketNo = TicketNo
lastTicketNo
    , isCapacity :: TxMeasure blk
isCapacity     = LedgerConfig blk
-> TickedLedgerState blk
-> MempoolCapacityBytesOverride
-> TxMeasure blk
forall blk.
LedgerSupportsMempool blk =>
LedgerConfig blk
-> TickedLedgerState blk
-> MempoolCapacityBytesOverride
-> TxMeasure blk
computeMempoolCapacity LedgerConfig blk
cfg TickedLedgerState blk
st MempoolCapacityBytesOverride
capacityOverride
    }

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

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

-- | 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 (LedgerState blk)
getCurrentLedgerState = ExtLedgerState blk -> LedgerState blk
forall blk. ExtLedgerState blk -> LedgerState blk
ledgerState (ExtLedgerState blk -> LedgerState blk)
-> STM m (ExtLedgerState blk) -> STM m (LedgerState blk)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ChainDB m blk -> STM m (ExtLedgerState blk)
forall (m :: * -> *) blk.
(Monad (STM m), IsLedger (LedgerState blk)) =>
ChainDB m blk -> STM m (ExtLedgerState blk)
ChainDB.getCurrentLedger ChainDB m blk
chainDB
    }

{-------------------------------------------------------------------------------
  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 -> LedgerConfig blk
mpEnvLedgerCfg        :: LedgerConfig blk
    , forall (m :: * -> *) blk.
MempoolEnv m blk -> StrictTVar m (InternalState blk)
mpEnvStateVar         :: StrictTVar m (InternalState blk)
    , forall (m :: * -> *) blk. MempoolEnv m blk -> MVar m ()
mpEnvAddTxsRemoteFifo :: MVar m ()
    , forall (m :: * -> *) blk. MempoolEnv m blk -> MVar m ()
mpEnvAddTxsAllFifo    :: MVar 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
    }

initMempoolEnv :: ( IOLike m
                  , NoThunks (GenTxId blk)
                  , LedgerSupportsMempool blk
                  , ValidateEnvelope blk
                  )
               => LedgerInterface m blk
               -> LedgerConfig blk
               -> MempoolCapacityBytesOverride
               -> Tracer m (TraceEventMempool blk)
               -> m (MempoolEnv m blk)
initMempoolEnv :: forall (m :: * -> *) blk.
(IOLike m, NoThunks (GenTxId blk), LedgerSupportsMempool blk,
 ValidateEnvelope blk) =>
LedgerInterface m blk
-> LedgerConfig blk
-> MempoolCapacityBytesOverride
-> Tracer m (TraceEventMempool blk)
-> m (MempoolEnv m blk)
initMempoolEnv LedgerInterface m blk
ledgerInterface LedgerCfg (LedgerState blk)
cfg MempoolCapacityBytesOverride
capacityOverride Tracer m (TraceEventMempool blk)
tracer = do
    LedgerState blk
st <- STM m (LedgerState blk) -> m (LedgerState blk)
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (LedgerState blk) -> m (LedgerState blk))
-> STM m (LedgerState blk) -> m (LedgerState blk)
forall a b. (a -> b) -> a -> b
$ LedgerInterface m blk -> STM m (LedgerState blk)
forall (m :: * -> *) blk.
LedgerInterface m blk -> STM m (LedgerState blk)
getCurrentLedgerState LedgerInterface m blk
ledgerInterface
    let (SlotNo
slot, Ticked (LedgerState blk)
st') = LedgerCfg (LedgerState blk)
-> ForgeLedgerState blk -> (SlotNo, Ticked (LedgerState blk))
forall blk.
(UpdateLedger blk, ValidateEnvelope blk) =>
LedgerConfig blk
-> ForgeLedgerState blk -> (SlotNo, TickedLedgerState blk)
tickLedgerState LedgerCfg (LedgerState blk)
cfg (LedgerState blk -> ForgeLedgerState blk
forall blk. LedgerState blk -> ForgeLedgerState blk
ForgeInUnknownSlot LedgerState blk
st)
    StrictTVar m (InternalState blk)
isVar <-
        InternalState blk -> m (StrictTVar m (InternalState blk))
forall (m :: * -> *) a.
(HasCallStack, MonadSTM m, NoThunks a) =>
a -> m (StrictTVar m a)
newTVarIO
      (InternalState blk -> m (StrictTVar m (InternalState blk)))
-> InternalState blk -> m (StrictTVar m (InternalState blk))
forall a b. (a -> b) -> a -> b
$ MempoolCapacityBytesOverride
-> TicketNo
-> LedgerCfg (LedgerState blk)
-> SlotNo
-> Ticked (LedgerState blk)
-> InternalState blk
forall blk.
LedgerSupportsMempool blk =>
MempoolCapacityBytesOverride
-> TicketNo
-> LedgerConfig blk
-> SlotNo
-> TickedLedgerState blk
-> InternalState blk
initInternalState MempoolCapacityBytesOverride
capacityOverride TicketNo
TxSeq.zeroTicketNo LedgerCfg (LedgerState blk)
cfg SlotNo
slot Ticked (LedgerState blk)
st'
    MVar m ()
addTxRemoteFifo <- () -> m (MVar m ())
forall a. a -> m (MVar m a)
forall (m :: * -> *) a. MonadMVar m => a -> m (MVar m a)
newMVar ()
    MVar m ()
addTxAllFifo    <- () -> m (MVar m ())
forall a. a -> m (MVar m a)
forall (m :: * -> *) a. MonadMVar m => a -> m (MVar m a)
newMVar ()
    MempoolEnv m blk -> m (MempoolEnv m blk)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return MempoolEnv
      { mpEnvLedger :: LedgerInterface m blk
mpEnvLedger           = LedgerInterface m blk
ledgerInterface
      , mpEnvLedgerCfg :: LedgerCfg (LedgerState blk)
mpEnvLedgerCfg        = LedgerCfg (LedgerState blk)
cfg
      , mpEnvStateVar :: StrictTVar m (InternalState blk)
mpEnvStateVar         = StrictTVar m (InternalState blk)
isVar
      , mpEnvAddTxsRemoteFifo :: MVar m ()
mpEnvAddTxsRemoteFifo = MVar m ()
addTxRemoteFifo
      , mpEnvAddTxsAllFifo :: MVar m ()
mpEnvAddTxsAllFifo    = MVar m ()
addTxAllFifo
      , mpEnvTracer :: Tracer m (TraceEventMempool blk)
mpEnvTracer           = Tracer m (TraceEventMempool blk)
tracer
      , mpEnvCapacityOverride :: MempoolCapacityBytesOverride
mpEnvCapacityOverride = MempoolCapacityBytesOverride
capacityOverride
      }

{-------------------------------------------------------------------------------
  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)
tickLedgerState :: forall blk.
(UpdateLedger blk, ValidateEnvelope blk) =>
LedgerConfig blk
-> ForgeLedgerState blk -> (SlotNo, TickedLedgerState blk)
tickLedgerState LedgerConfig blk
_cfg (ForgeInKnownSlot SlotNo
slot TickedLedgerState blk
st) = (SlotNo
slot, TickedLedgerState blk
st)
tickLedgerState  LedgerConfig blk
cfg (ForgeInUnknownSlot LedgerState blk
st) =
    (SlotNo
slot, LedgerConfig blk
-> SlotNo -> LedgerState blk -> TickedLedgerState blk
forall l. IsLedger l => LedgerCfg l -> SlotNo -> l -> Ticked l
applyChainTick LedgerConfig blk
cfg SlotNo
slot LedgerState blk
st)
  where
    -- Optimistically assume that the transactions will be included in a block
    -- in the next available slot
    --
    -- TODO: We should use time here instead
    -- <https://github.com/IntersectMBO/ouroboros-network/issues/1298>
    -- Once we do, the ValidateEnvelope constraint can go.
    slot :: SlotNo
    slot :: SlotNo
slot = case LedgerState blk -> WithOrigin SlotNo
forall blk.
UpdateLedger blk =>
LedgerState blk -> WithOrigin SlotNo
ledgerTipSlot LedgerState blk
st of
             WithOrigin SlotNo
Origin      -> Proxy blk -> SlotNo
forall blk. BasicEnvelopeValidation blk => Proxy blk -> SlotNo
minimumPossibleSlotNo (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
-------------------------------------------------------------------------------}

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

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

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

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

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

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

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

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

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

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

-- | Extend 'ValidationResult' with a new transaction (one which we have not
-- previously validated) that may or may not be valid in this ledger state.
--
-- PRECONDITION: 'vrNewValid' is 'Nothing'. In other words: new transactions
-- should be validated one-by-one, not by calling 'extendVRNew' on its result
-- again.
extendVRNew :: (LedgerSupportsMempool blk, HasTxId (GenTx blk))
            => LedgerConfig blk
            -> WhetherToIntervene
            -> GenTx blk
            -> ValidationResult (GenTx blk) blk
            -> Either
                 (ApplyTxErr blk)
                 ( Validated        (GenTx blk)
                 , ValidationResult (GenTx blk) blk
                 )
extendVRNew :: forall blk.
(LedgerSupportsMempool blk, HasTxId (GenTx blk)) =>
LedgerConfig blk
-> WhetherToIntervene
-> GenTx blk
-> ValidationResult (GenTx blk) blk
-> Either
     (ApplyTxErr blk)
     (Validated (GenTx blk), ValidationResult (GenTx blk) blk)
extendVRNew LedgerCfg (LedgerState blk)
cfg WhetherToIntervene
wti GenTx blk
tx ValidationResult (GenTx blk) blk
vr =
    Bool
-> Either
     (ApplyTxErr blk)
     (Validated (GenTx blk), ValidationResult (GenTx blk) blk)
-> Either
     (ApplyTxErr blk)
     (Validated (GenTx blk), ValidationResult (GenTx blk) blk)
forall a. HasCallStack => Bool -> a -> a
assert (Maybe (Validated (GenTx blk)) -> Bool
forall a. Maybe a -> Bool
isNothing Maybe (Validated (GenTx blk))
vrNewValid) (Either
   (ApplyTxErr blk)
   (Validated (GenTx blk), ValidationResult (GenTx blk) blk)
 -> Either
      (ApplyTxErr blk)
      (Validated (GenTx blk), ValidationResult (GenTx blk) blk))
-> Either
     (ApplyTxErr blk)
     (Validated (GenTx blk), ValidationResult (GenTx blk) blk)
-> Either
     (ApplyTxErr blk)
     (Validated (GenTx blk), ValidationResult (GenTx blk) blk)
forall a b. (a -> b) -> a -> b
$ Except
  (ApplyTxErr blk)
  (Validated (GenTx blk), ValidationResult (GenTx blk) blk)
-> Either
     (ApplyTxErr blk)
     (Validated (GenTx blk), ValidationResult (GenTx blk) blk)
forall e a. Except e a -> Either e a
runExcept Except
  (ApplyTxErr blk)
  (Validated (GenTx blk), ValidationResult (GenTx blk) blk)
m
  where
    ValidationResult {
        TxSeq (TxMeasure blk) (Validated (GenTx blk))
vrValid :: forall invalidTx blk.
ValidationResult invalidTx blk
-> TxSeq (TxMeasure blk) (Validated (GenTx blk))
vrValid :: TxSeq (TxMeasure blk) (Validated (GenTx blk))
vrValid
      , Set (TxId (GenTx blk))
vrValidTxIds :: forall invalidTx blk.
ValidationResult invalidTx blk -> Set (GenTxId blk)
vrValidTxIds :: Set (TxId (GenTx blk))
vrValidTxIds
      , Ticked (LedgerState blk)
vrAfter :: forall invalidTx blk.
ValidationResult invalidTx blk -> TickedLedgerState blk
vrAfter :: Ticked (LedgerState blk)
vrAfter
      , TicketNo
vrLastTicketNo :: forall invalidTx blk. ValidationResult invalidTx blk -> TicketNo
vrLastTicketNo :: TicketNo
vrLastTicketNo
      , Maybe (Validated (GenTx blk))
vrNewValid :: forall invalidTx blk.
ValidationResult invalidTx blk -> Maybe (Validated (GenTx blk))
vrNewValid :: Maybe (Validated (GenTx blk))
vrNewValid
      , SlotNo
vrSlotNo :: forall invalidTx blk. ValidationResult invalidTx blk -> SlotNo
vrSlotNo :: SlotNo
vrSlotNo
      } = ValidationResult (GenTx blk) blk
vr

    m :: Except
  (ApplyTxErr blk)
  (Validated (GenTx blk), ValidationResult (GenTx blk) blk)
m = do
      TxMeasure blk
txsz <- LedgerCfg (LedgerState blk)
-> Ticked (LedgerState blk)
-> GenTx blk
-> ExceptT (ApplyTxErr blk) Identity (TxMeasure blk)
forall blk.
TxLimits blk =>
LedgerConfig blk
-> TickedLedgerState blk
-> GenTx blk
-> Except (ApplyTxErr blk) (TxMeasure blk)
txMeasure LedgerCfg (LedgerState blk)
cfg Ticked (LedgerState blk)
vrAfter GenTx blk
tx
      (Ticked (LedgerState blk)
st', Validated (GenTx blk)
vtx) <- LedgerCfg (LedgerState blk)
-> WhetherToIntervene
-> SlotNo
-> GenTx blk
-> Ticked (LedgerState blk)
-> ExceptT
     (ApplyTxErr blk)
     Identity
     (Ticked (LedgerState blk), Validated (GenTx blk))
forall blk.
LedgerSupportsMempool blk =>
LedgerConfig blk
-> WhetherToIntervene
-> SlotNo
-> GenTx blk
-> Ticked (LedgerState blk)
-> Except
     (ApplyTxErr blk) (Ticked (LedgerState blk), Validated (GenTx blk))
applyTx LedgerCfg (LedgerState blk)
cfg WhetherToIntervene
wti SlotNo
vrSlotNo GenTx blk
tx Ticked (LedgerState blk)
vrAfter
      let nextTicketNo :: TicketNo
nextTicketNo = TicketNo -> TicketNo
forall a. Enum a => a -> a
succ TicketNo
vrLastTicketNo
      (Validated (GenTx blk), ValidationResult (GenTx blk) blk)
-> Except
     (ApplyTxErr blk)
     (Validated (GenTx blk), ValidationResult (GenTx blk) blk)
forall a. a -> ExceptT (ApplyTxErr blk) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        ( Validated (GenTx blk)
vtx
        , ValidationResult (GenTx blk) blk
vr { vrValid        = vrValid :> TxTicket vtx nextTicketNo txsz
             , vrValidTxIds   = Set.insert (txId tx) vrValidTxIds
             , vrNewValid     = Just vtx
             , vrAfter        = st'
             , vrLastTicketNo = nextTicketNo
             }
        )

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

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

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

-- | Create a Mempool Snapshot from a given Internal State of the mempool.
snapshotFromIS :: forall blk.
     (HasTxId (GenTx blk), TxLimits blk)
  => InternalState blk
  -> MempoolSnapshot blk
snapshotFromIS :: forall blk.
(HasTxId (GenTx blk), TxLimits blk) =>
InternalState blk -> MempoolSnapshot blk
snapshotFromIS InternalState blk
is = MempoolSnapshot {
      snapshotTxs :: [(Validated (GenTx blk), TicketNo, ByteSize32)]
snapshotTxs         = InternalState blk
-> [(Validated (GenTx blk), TicketNo, ByteSize32)]
implSnapshotGetTxs         InternalState blk
is
    , snapshotTxsAfter :: TicketNo -> [(Validated (GenTx blk), TicketNo, ByteSize32)]
snapshotTxsAfter    = InternalState blk
-> TicketNo -> [(Validated (GenTx blk), TicketNo, ByteSize32)]
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
    , snapshotLedgerState :: TickedLedgerState blk
snapshotLedgerState = InternalState blk -> TickedLedgerState blk
forall blk. InternalState blk -> TickedLedgerState blk
isLedgerState              InternalState blk
is
    , snapshotTake :: TxMeasure blk -> [Validated (GenTx blk)]
snapshotTake        = InternalState blk -> TxMeasure blk -> [Validated (GenTx blk)]
implSnapshotTake           InternalState blk
is
    }
 where
  implSnapshotGetTxs :: InternalState blk
                     -> [(Validated (GenTx blk), TicketNo, ByteSize32)]
  implSnapshotGetTxs :: InternalState blk
-> [(Validated (GenTx blk), TicketNo, ByteSize32)]
implSnapshotGetTxs = (InternalState blk
 -> TicketNo -> [(Validated (GenTx blk), TicketNo, ByteSize32)])
-> TicketNo
-> InternalState blk
-> [(Validated (GenTx blk), TicketNo, ByteSize32)]
forall a b c. (a -> b -> c) -> b -> a -> c
flip InternalState blk
-> TicketNo -> [(Validated (GenTx blk), TicketNo, ByteSize32)]
implSnapshotGetTxsAfter TicketNo
TxSeq.zeroTicketNo

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

  implSnapshotTake :: InternalState blk
                   -> TxMeasure blk
                   -> [Validated (GenTx blk)]
  implSnapshotTake :: InternalState blk -> TxMeasure blk -> [Validated (GenTx blk)]
implSnapshotTake IS{TxSeq (TxMeasure blk) (Validated (GenTx blk))
isTxs :: forall blk.
InternalState blk -> TxSeq (TxMeasure blk) (Validated (GenTx blk))
isTxs :: TxSeq (TxMeasure blk) (Validated (GenTx blk))
isTxs} =
    (TxTicket (TxMeasure blk) (Validated (GenTx blk))
 -> Validated (GenTx blk))
-> [TxTicket (TxMeasure blk) (Validated (GenTx blk))]
-> [Validated (GenTx blk)]
forall a b. (a -> b) -> [a] -> [b]
map TxTicket (TxMeasure blk) (Validated (GenTx blk))
-> Validated (GenTx blk)
forall sz tx. TxTicket sz tx -> tx
TxSeq.txTicketTx ([TxTicket (TxMeasure blk) (Validated (GenTx blk))]
 -> [Validated (GenTx blk)])
-> (TxMeasure blk
    -> [TxTicket (TxMeasure blk) (Validated (GenTx blk))])
-> TxMeasure blk
-> [Validated (GenTx blk)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxSeq (TxMeasure blk) (Validated (GenTx blk))
-> [TxTicket (TxMeasure blk) (Validated (GenTx blk))]
forall sz tx. TxSeq sz tx -> [TxTicket sz tx]
TxSeq.toList (TxSeq (TxMeasure blk) (Validated (GenTx blk))
 -> [TxTicket (TxMeasure blk) (Validated (GenTx blk))])
-> (TxMeasure blk -> TxSeq (TxMeasure blk) (Validated (GenTx blk)))
-> TxMeasure blk
-> [TxTicket (TxMeasure blk) (Validated (GenTx blk))]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TxSeq (TxMeasure blk) (Validated (GenTx blk)),
 TxSeq (TxMeasure blk) (Validated (GenTx blk)))
-> TxSeq (TxMeasure blk) (Validated (GenTx blk))
forall a b. (a, b) -> a
fst ((TxSeq (TxMeasure blk) (Validated (GenTx blk)),
  TxSeq (TxMeasure blk) (Validated (GenTx blk)))
 -> TxSeq (TxMeasure blk) (Validated (GenTx blk)))
-> (TxMeasure blk
    -> (TxSeq (TxMeasure blk) (Validated (GenTx blk)),
        TxSeq (TxMeasure blk) (Validated (GenTx blk))))
-> TxMeasure blk
-> TxSeq (TxMeasure blk) (Validated (GenTx blk))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxSeq (TxMeasure blk) (Validated (GenTx blk))
-> TxMeasure blk
-> (TxSeq (TxMeasure blk) (Validated (GenTx blk)),
    TxSeq (TxMeasure blk) (Validated (GenTx blk)))
forall sz tx.
Measure sz =>
TxSeq sz tx -> sz -> (TxSeq sz tx, TxSeq sz tx)
TxSeq.splitAfterTxSize TxSeq (TxMeasure blk) (Validated (GenTx blk))
isTxs

  implSnapshotGetTx :: InternalState blk
                    -> TicketNo
                    -> Maybe (Validated (GenTx blk))
  implSnapshotGetTx :: InternalState blk -> TicketNo -> Maybe (Validated (GenTx blk))
implSnapshotGetTx IS{TxSeq (TxMeasure blk) (Validated (GenTx blk))
isTxs :: forall blk.
InternalState blk -> TxSeq (TxMeasure blk) (Validated (GenTx blk))
isTxs :: TxSeq (TxMeasure blk) (Validated (GenTx blk))
isTxs} = (TxSeq (TxMeasure blk) (Validated (GenTx blk))
isTxs TxSeq (TxMeasure 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

{-------------------------------------------------------------------------------
  Validating txs or states
-------------------------------------------------------------------------------}

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

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

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

-- | Events traced by the Mempool.
data TraceEventMempool blk
  = TraceMempoolAddedTx
      (Validated (GenTx blk))
      -- ^ New, valid transaction that was added to the Mempool.
      MempoolSize
      -- ^ The size of the Mempool before adding the transaction.
      MempoolSize
      -- ^ The size of the Mempool after adding the transaction.
  | TraceMempoolRejectedTx
      (GenTx blk)
      -- ^ New, invalid transaction thas was rejected and thus not added to
      -- the Mempool.
      (ApplyTxErr blk)
      -- ^ The reason for rejecting the transaction.
      MempoolSize
      -- ^ The current size of the Mempool.
  | TraceMempoolRemoveTxs
      [(Validated (GenTx blk), ApplyTxErr blk)]
      -- ^ 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.
      MempoolSize
      -- ^ The current size of the Mempool.
  | TraceMempoolManuallyRemovedTxs
      [GenTxId blk]
      -- ^ Transactions that have been manually removed from the Mempool.
      [Validated (GenTx 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.
      MempoolSize
      -- ^ The current size of the Mempool.
   | TraceMempoolSynced
      -- ^ Emitted when the mempool is adjusted after the tip has changed.
      EnclosingTimed
      -- ^ How long the sync operation took.

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

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