{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase                 #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE StandaloneDeriving         #-}
{-# LANGUAGE UndecidableInstances       #-}

-- | Exposes the @'Mempool'@ datatype which captures the public API of the
-- Mempool. Also exposes all the types used to interact with said API.
--
-- The interface is then initialized in "Ouroboros.Consensus.Mempool.Init" with
-- the functions from "Ouroboros.Consensus.Mempool.Update" and
-- "Ouroboros.Consensus.Mempool.Query".
module Ouroboros.Consensus.Mempool.API (
    -- * Mempool
    Mempool (..)
    -- * Transaction adding
  , MempoolAddTxResult (..)
  , addLocalTxs
  , addTxs
  , isMempoolTxAdded
  , isMempoolTxRejected
  , mempoolTxAddedToMaybe
    -- * Ledger state to forge on top of
  , ForgeLedgerState (..)
    -- * Mempool Snapshot
  , MempoolSnapshot (..)
    -- * Re-exports
  , TicketNo
  , TxSizeInBytes
  , zeroTicketNo
    -- * Deprecated re-exports
  , MempoolCapacityBytes
  , MempoolCapacityBytesOverride
  , MempoolSize
  , TraceEventMempool
  , computeMempoolCapacity
  ) where

import           Ouroboros.Network.Protocol.TxSubmission2.Type (TxSizeInBytes)

import           Ouroboros.Consensus.Block (SlotNo)
import           Ouroboros.Consensus.Ledger.Abstract
import           Ouroboros.Consensus.Ledger.SupportsMempool
import           Ouroboros.Consensus.Util.IOLike

import           Ouroboros.Consensus.Mempool.Capacity hiding
                     (MempoolCapacityBytes, MempoolCapacityBytesOverride,
                     MempoolSize, computeMempoolCapacity, (<=))
import qualified Ouroboros.Consensus.Mempool.Capacity as Cap
import           Ouroboros.Consensus.Mempool.TxSeq (TicketNo, zeroTicketNo)

{-------------------------------------------------------------------------------
  Mempool API
-------------------------------------------------------------------------------}

-- | Mempool
--
-- The mempool is the set of transactions that should be included in the next
-- block. In principle this is a /set/ of all the transactions that we receive
-- from our peers. In order to avoid flooding the network with invalid
-- transactions, however, we only want to keep /valid/ transactions in the
-- mempool. That raises the question: valid with respect to which ledger state?
--
-- We opt for a very simple answer to this: the mempool will be interpreted
-- as a /list/ of transactions; which are validated strictly in order, starting
-- from the current ledger state. This has a number of advantages:
--
-- * It's simple to implement and it's efficient. In particular, no search for
--   a valid subset is ever required.
-- * When producing a block, we can simply take the longest possible prefix
--   of transactions that fits in a block.
-- * It supports wallets that submit dependent transactions (where later
--   transaction depends on outputs from earlier ones).
--
-- When only one thread is operating on the mempool, operations that mutate the
-- state based on the input arguments (tryAddTxs and removeTxs) will produce the
-- same result whether they process transactions one by one or all in one go, so
-- this equality holds:
--
-- > void (tryAddTxs wti txs) === forM_ txs (tryAddTxs wti . (:[]))
-- > void (trAddTxs wti [x,y]) === tryAddTxs wti x >> void (tryAddTxs wti y)
--
-- This shows that @'tryAddTxs' wti@ is an homomorphism from '++' and '>>',
-- which informally makes these operations "distributive".
data Mempool m blk = Mempool {
      -- | Add a bunch of transactions (oldest to newest)
      --
      -- As long as we keep the mempool entirely in-memory this could live in
      -- @STM m@; we keep it in @m@ instead to leave open the possibility of
      -- persistence.
      --
      -- The new transactions provided will be validated, /in order/, against
      -- the ledger state obtained by applying all the transactions already in
      -- the Mempool to it. Transactions which are found to be invalid, with
      -- respect to the ledger state, are dropped, whereas valid transactions
      -- are added to the mempool.
      --
      -- Note that transactions that are invalid, with respect to the ledger
      -- state, will /never/ be added to the mempool. However, it is possible
      -- that, at a given point in time, transactions which were once valid
      -- but are now invalid, with respect to the current ledger state, could
      -- exist within the mempool until they are revalidated and dropped from
      -- the mempool via a call to 'syncWithLedger' or by the background
      -- thread that watches the ledger for changes.
      --
      -- This function will return two lists
      --
      -- 1. A list containing the following transactions:
      --
      --    * Those transactions provided which were found to be valid, as a
      --      'MempoolTxAdded' value. These transactions are now in the Mempool.
      --    * Those transactions provided which were found to be invalid, along
      --      with their accompanying validation errors, as a
      --      'MempoolTxRejected' value. These transactions are not in the
      --      Mempool.
      --
      -- 2. A list containing the transactions that have not yet been added, as
      --    the capacity of the Mempool has been reached. I.e., there is no
      --    space in the Mempool to add the first transaction in this list. Note
      --    that we won't try to add smaller transactions after that first
      --    transaction because they might depend on the first transaction.
      --
      -- POSTCONDITION:
      -- > let prj = \case
      -- >       MempoolTxAdded vtx        -> txForgetValidated vtx
      -- >       MempoolTxRejected tx _err -> tx
      -- > (processed, toProcess) <- tryAddTxs wti txs
      -- > map prj processed ++ toProcess == txs
      --
      -- Note that previously valid transaction that are now invalid with
      -- respect to the current ledger state are dropped from the mempool, but
      -- are not part of the first returned list (nor the second).
      --
      -- In principle it is possible that validation errors are transient; for
      -- example, it is possible that a transaction is rejected because one of
      -- its inputs is not /yet/ available in the UTxO (the transaction it
      -- depends on is not yet in the chain, nor in the mempool). In practice
      -- however it is likely that rejected transactions will still be
      -- rejected later, and should just be dropped.
      --
      -- It is important to note one important special case of transactions
      -- being "invalid": a transaction will /also/ be considered invalid if
      -- /that very same transaction/ is already included on the blockchain
      -- (after all, by definition that must mean its inputs have been used).
      -- Rejected transactions are therefore not necessarily a sign of
      -- malicious behaviour. Indeed, we would expect /most/ transactions that
      -- are reported as invalid by 'tryAddTxs' to be invalid precisely
      -- because they have already been included. Distinguishing between these
      -- two cases can be done in theory, but it is expensive unless we have
      -- an index of transaction hashes that have been included on the
      -- blockchain.
      --
      Mempool m blk
-> WhetherToIntervene
-> [GenTx blk]
-> m ([MempoolAddTxResult blk], [GenTx blk])
tryAddTxs      :: WhetherToIntervene
                     -> [GenTx blk]
                     -> m ( [MempoolAddTxResult blk]
                          , [GenTx blk]
                          )

      -- | Manually remove the given transactions from the mempool.
    , Mempool m blk -> [GenTxId blk] -> m ()
removeTxs      :: [GenTxId blk] -> m ()

      -- | Sync the transactions in the mempool with the current ledger state
      --  of the 'ChainDB'.
      --
      -- The transactions that exist within the mempool will be revalidated
      -- against the current ledger state. Transactions which are found to be
      -- invalid with respect to the current ledger state, will be dropped
      -- from the mempool, whereas valid transactions will remain.
      --
      -- We keep this in @m@ instead of @STM m@ to leave open the possibility
      -- of persistence. Additionally, this makes it possible to trace the
      -- removal of invalid transactions.
      --
      -- n.b. in our current implementation, when one opens a mempool, we
      -- spawn a thread which performs this action whenever the 'ChainDB' tip
      -- point changes.
    , Mempool m blk -> m (MempoolSnapshot blk)
syncWithLedger :: m (MempoolSnapshot blk)

      -- | Get a snapshot of the current mempool state. This allows for
      -- further pure queries on the snapshot.
      --
      -- This doesn't look at the ledger state at all.
    , Mempool m blk -> STM m (MempoolSnapshot blk)
getSnapshot    :: STM m (MempoolSnapshot blk)

      -- | Get a snapshot of the mempool state that is valid with respect to
      -- the given ledger state
      --
      -- This does not update the state of the mempool.
    , Mempool m blk
-> ForgeLedgerState blk -> STM m (MempoolSnapshot blk)
getSnapshotFor :: ForgeLedgerState blk -> STM m (MempoolSnapshot blk)

      -- | Get the mempool's capacity in bytes.
      --
      -- Note that the capacity of the Mempool, unless it is overridden with
      -- 'MempoolCapacityBytesOverride', can dynamically change when the
      -- ledger state is updated: it will be set to twice the current ledger's
      -- maximum transaction capacity of a block.
      --
      -- When the capacity happens to shrink at some point, we /do not/ remove
      -- transactions from the Mempool to satisfy this new lower limit.
      -- Instead, we treat it the same way as a Mempool which is /at/
      -- capacity, i.e., we won't admit new transactions until some have been
      -- removed because they have become invalid.
    , Mempool m blk -> STM m MempoolCapacityBytes
getCapacity    :: STM m Cap.MempoolCapacityBytes

      -- | Return the post-serialisation size in bytes of a 'GenTx'.
    , Mempool m blk -> GenTx blk -> TxSizeInBytes
getTxSize      :: GenTx blk -> TxSizeInBytes
    }

{-------------------------------------------------------------------------------
  Result of adding a transaction to the mempool
-------------------------------------------------------------------------------}

-- | The result of attempting to add a transaction to the mempool.
data MempoolAddTxResult blk
  = MempoolTxAdded !(Validated (GenTx blk))
    -- ^ The transaction was added to the mempool.
  | MempoolTxRejected !(GenTx blk) !(ApplyTxErr blk)
    -- ^ The transaction was rejected and could not be added to the mempool
    -- for the specified reason.

deriving instance (Eq (GenTx blk), Eq (Validated (GenTx blk)), Eq (ApplyTxErr blk)) => Eq (MempoolAddTxResult blk)
deriving instance (Show (GenTx blk), Show (Validated (GenTx blk)), Show (ApplyTxErr blk)) => Show (MempoolAddTxResult blk)

mempoolTxAddedToMaybe :: MempoolAddTxResult blk -> Maybe (Validated (GenTx blk))
mempoolTxAddedToMaybe :: MempoolAddTxResult blk -> Maybe (Validated (GenTx blk))
mempoolTxAddedToMaybe (MempoolTxAdded Validated (GenTx blk)
vtx) = Validated (GenTx blk) -> Maybe (Validated (GenTx blk))
forall a. a -> Maybe a
Just Validated (GenTx blk)
vtx
mempoolTxAddedToMaybe MempoolAddTxResult blk
_                    = Maybe (Validated (GenTx blk))
forall a. Maybe a
Nothing

isMempoolTxAdded :: MempoolAddTxResult blk -> Bool
isMempoolTxAdded :: MempoolAddTxResult blk -> Bool
isMempoolTxAdded MempoolTxAdded{} = Bool
True
isMempoolTxAdded MempoolAddTxResult blk
_                = Bool
False

isMempoolTxRejected :: MempoolAddTxResult blk -> Bool
isMempoolTxRejected :: MempoolAddTxResult blk -> Bool
isMempoolTxRejected MempoolTxRejected{} = Bool
True
isMempoolTxRejected MempoolAddTxResult blk
_                   = Bool
False

-- | Wrapper around 'implTryAddTxs' that blocks until all transaction have
-- either been added to the Mempool or rejected.
--
-- This function does not sync the Mempool contents with the ledger state in
-- case the latter changes, it relies on the background thread to do that.
--
-- See the necessary invariants on the Haddock for 'tryAddTxs'.
addTxs
  :: forall m blk. MonadSTM m
  => Mempool m blk
  -> [GenTx blk]
  -> m [MempoolAddTxResult blk]
addTxs :: Mempool m blk -> [GenTx blk] -> m [MempoolAddTxResult blk]
addTxs Mempool m blk
mempool = Mempool m blk
-> WhetherToIntervene -> [GenTx blk] -> m [MempoolAddTxResult blk]
forall (m :: * -> *) blk.
MonadSTM m =>
Mempool m blk
-> WhetherToIntervene -> [GenTx blk] -> m [MempoolAddTxResult blk]
addTxsHelper Mempool m blk
mempool WhetherToIntervene
DoNotIntervene

-- | Variation on 'addTxs' that is more forgiving when possible
--
-- See 'Intervene'.
addLocalTxs
  :: forall m blk. MonadSTM m
  => Mempool m blk
  -> [GenTx blk]
  -> m [MempoolAddTxResult blk]
addLocalTxs :: Mempool m blk -> [GenTx blk] -> m [MempoolAddTxResult blk]
addLocalTxs Mempool m blk
mempool = Mempool m blk
-> WhetherToIntervene -> [GenTx blk] -> m [MempoolAddTxResult blk]
forall (m :: * -> *) blk.
MonadSTM m =>
Mempool m blk
-> WhetherToIntervene -> [GenTx blk] -> m [MempoolAddTxResult blk]
addTxsHelper Mempool m blk
mempool WhetherToIntervene
Intervene

-- | See 'addTxs'
addTxsHelper
  :: forall m blk. MonadSTM m
  => Mempool m blk
  -> WhetherToIntervene
  -> [GenTx blk]
  -> m [MempoolAddTxResult blk]
addTxsHelper :: Mempool m blk
-> WhetherToIntervene -> [GenTx blk] -> m [MempoolAddTxResult blk]
addTxsHelper Mempool m blk
mempool WhetherToIntervene
wti = \[GenTx blk]
txs -> do
    ([MempoolAddTxResult blk]
processed, [GenTx blk]
toAdd) <- Mempool m blk
-> WhetherToIntervene
-> [GenTx blk]
-> m ([MempoolAddTxResult blk], [GenTx blk])
forall (m :: * -> *) blk.
Mempool m blk
-> WhetherToIntervene
-> [GenTx blk]
-> m ([MempoolAddTxResult blk], [GenTx blk])
tryAddTxs Mempool m blk
mempool WhetherToIntervene
wti [GenTx blk]
txs
    case [GenTx blk]
toAdd of
      [] -> [MempoolAddTxResult blk] -> m [MempoolAddTxResult blk]
forall (m :: * -> *) a. Monad m => a -> m a
return [MempoolAddTxResult blk]
processed
      [GenTx blk]
_  -> [[MempoolAddTxResult blk]]
-> [GenTx blk] -> m [MempoolAddTxResult blk]
go [[MempoolAddTxResult blk]
processed] [GenTx blk]
toAdd
  where
    go
      :: [[MempoolAddTxResult blk]]
         -- ^ The outer list is in reverse order, but all the inner lists will
         -- be in the right order.
      -> [GenTx blk]
      -> m [MempoolAddTxResult blk]
    go :: [[MempoolAddTxResult blk]]
-> [GenTx blk] -> m [MempoolAddTxResult blk]
go [[MempoolAddTxResult blk]]
acc []         = [MempoolAddTxResult blk] -> m [MempoolAddTxResult blk]
forall (m :: * -> *) a. Monad m => a -> m a
return ([[MempoolAddTxResult blk]] -> [MempoolAddTxResult blk]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[MempoolAddTxResult blk]] -> [[MempoolAddTxResult blk]]
forall a. [a] -> [a]
reverse [[MempoolAddTxResult blk]]
acc))
    go [[MempoolAddTxResult blk]]
acc txs :: [GenTx blk]
txs@(GenTx blk
tx:[GenTx blk]
_) = do
      let firstTxSize :: TxSizeInBytes
firstTxSize = Mempool m blk -> GenTx blk -> TxSizeInBytes
forall (m :: * -> *) blk.
Mempool m blk -> GenTx blk -> TxSizeInBytes
getTxSize Mempool m blk
mempool GenTx blk
tx
      -- Wait until there's at least room for the first transaction we're
      -- trying to add, otherwise there's no point in trying to add it.
      STM m () -> m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m () -> m ()) -> STM m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
        TxSizeInBytes
curSize <- MempoolSize -> TxSizeInBytes
msNumBytes (MempoolSize -> TxSizeInBytes)
-> (MempoolSnapshot blk -> MempoolSize)
-> MempoolSnapshot blk
-> TxSizeInBytes
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MempoolSnapshot blk -> MempoolSize
forall blk. MempoolSnapshot blk -> MempoolSize
snapshotMempoolSize (MempoolSnapshot blk -> TxSizeInBytes)
-> STM m (MempoolSnapshot blk) -> STM m TxSizeInBytes
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Mempool m blk -> STM m (MempoolSnapshot blk)
forall (m :: * -> *) blk.
Mempool m blk -> STM m (MempoolSnapshot blk)
getSnapshot Mempool m blk
mempool
        Cap.MempoolCapacityBytes TxSizeInBytes
capacity <- Mempool m blk -> STM m MempoolCapacityBytes
forall (m :: * -> *) blk.
Mempool m blk -> STM m MempoolCapacityBytes
getCapacity Mempool m blk
mempool
        Bool -> STM m ()
forall (m :: * -> *). MonadSTM m => Bool -> STM m ()
check (TxSizeInBytes
curSize TxSizeInBytes -> TxSizeInBytes -> TxSizeInBytes
forall a. Num a => a -> a -> a
+ TxSizeInBytes
firstTxSize TxSizeInBytes -> TxSizeInBytes -> Bool
forall a. Ord a => a -> a -> Bool
<= TxSizeInBytes
capacity)
      -- It is possible that between the check above and the call below, other
      -- transactions are added, stealing our spot, but that's fine, we'll
      -- just recurse again without progress.
      ([MempoolAddTxResult blk]
added, [GenTx blk]
toAdd) <- Mempool m blk
-> WhetherToIntervene
-> [GenTx blk]
-> m ([MempoolAddTxResult blk], [GenTx blk])
forall (m :: * -> *) blk.
Mempool m blk
-> WhetherToIntervene
-> [GenTx blk]
-> m ([MempoolAddTxResult blk], [GenTx blk])
tryAddTxs Mempool m blk
mempool WhetherToIntervene
wti [GenTx blk]
txs
      [[MempoolAddTxResult blk]]
-> [GenTx blk] -> m [MempoolAddTxResult blk]
go ([MempoolAddTxResult blk]
added[MempoolAddTxResult blk]
-> [[MempoolAddTxResult blk]] -> [[MempoolAddTxResult blk]]
forall a. a -> [a] -> [a]
:[[MempoolAddTxResult blk]]
acc) [GenTx blk]
toAdd

{-------------------------------------------------------------------------------
  Ledger state considered for forging
-------------------------------------------------------------------------------}

-- | The ledger state wrt to which we should produce a block
--
-- The transactions in the mempool will be part of the body of a block, but a
-- block consists of a header and a body, and the full validation of a block
-- consists of first processing its header and only then processing the body.
-- This is important, because processing the header may change the state of the
-- ledger: the update system might be updated, scheduled delegations might be
-- applied, etc., and such changes should take effect before we validate any
-- transactions.
data ForgeLedgerState blk =
    -- | The slot number of the block is known
    --
    -- This will only be the case when we realized that we are the slot leader
    -- and we are actually producing a block. It is the caller's responsibility
    -- to call 'applyChainTick' and produce the ticked ledger state.
    ForgeInKnownSlot SlotNo (TickedLedgerState blk)

    -- | The slot number of the block is not yet known
    --
    -- When we are validating transactions before we know in which block they
    -- will end up, we have to make an assumption about which slot number to use
    -- for 'applyChainTick' to prepare the ledger state; we will assume that
    -- they will end up in the slot after the slot at the tip of the ledger.
  | ForgeInUnknownSlot (LedgerState blk)


{-------------------------------------------------------------------------------
  Snapshot of the mempool
-------------------------------------------------------------------------------}

-- | A pure snapshot of the contents of the mempool. It allows fetching
-- information about transactions in the mempool, and fetching individual
-- transactions.
--
-- This uses a transaction sequence number type for identifying transactions
-- within the mempool sequence. The sequence number is local to this mempool,
-- unlike the transaction hash. This allows us to ask for all transactions
-- after a known sequence number, to get new transactions. It is also used to
-- look up individual transactions.
--
-- Note that it is expected that 'getTx' will often return 'Nothing'
-- even for tx sequence numbers returned in previous snapshots. This happens
-- when the transaction has been removed from the mempool between snapshots.
--
data MempoolSnapshot blk = MempoolSnapshot {
    -- | Get all transactions (oldest to newest) in the mempool snapshot along
    -- with their ticket number.
    MempoolSnapshot blk -> [(Validated (GenTx blk), TicketNo)]
snapshotTxs         :: [(Validated (GenTx blk), TicketNo)]

    -- | Get all transactions (oldest to newest) in the mempool snapshot,
    -- along with their ticket number, which are associated with a ticket
    -- number greater than the one provided.
  , MempoolSnapshot blk
-> TicketNo -> [(Validated (GenTx blk), TicketNo)]
snapshotTxsAfter    :: TicketNo -> [(Validated (GenTx blk), TicketNo)]

    -- | Get a specific transaction from the mempool snapshot by its ticket
    -- number, if it exists.
  , MempoolSnapshot blk -> TicketNo -> Maybe (Validated (GenTx blk))
snapshotLookupTx    :: TicketNo -> Maybe (Validated (GenTx blk))

    -- | Determine whether a specific transaction exists within the mempool
    -- snapshot.
  , MempoolSnapshot blk -> GenTxId blk -> Bool
snapshotHasTx       :: GenTxId blk -> Bool

    -- | Get the size of the mempool snapshot.
  , MempoolSnapshot blk -> MempoolSize
snapshotMempoolSize :: Cap.MempoolSize

    -- | The block number of the "virtual block" under construction
  , MempoolSnapshot blk -> SlotNo
snapshotSlotNo      :: SlotNo

    -- | The ledger state after all transactions in the snapshot
  , MempoolSnapshot blk -> TickedLedgerState blk
snapshotLedgerState :: TickedLedgerState blk
  }

{-------------------------------------------------------------------------------
  Deprecations
-------------------------------------------------------------------------------}

{-# DEPRECATED MempoolCapacityBytes "Use Ouroboros.Consensus.Mempool (MempoolCapacityBytes)" #-}
type MempoolCapacityBytes = Cap.MempoolCapacityBytes

{-# DEPRECATED MempoolSize "Use Ouroboros.Consensus.Mempool (MempoolSize)" #-}
type MempoolSize = Cap.MempoolSize

{-# DEPRECATED MempoolCapacityBytesOverride "Use Ouroboros.Consensus.Mempool (MempoolCapacityBytesOverride)" #-}
type MempoolCapacityBytesOverride = Cap.MempoolCapacityBytesOverride

{-# DEPRECATED computeMempoolCapacity "Use Ouroboros.Consensus.Mempool (computeMempoolCapacity)" #-}
computeMempoolCapacity
  :: LedgerSupportsMempool blk
  => TickedLedgerState blk
  -> MempoolCapacityBytesOverride
  -> MempoolCapacityBytes
computeMempoolCapacity :: TickedLedgerState blk
-> MempoolCapacityBytesOverride -> MempoolCapacityBytes
computeMempoolCapacity = TickedLedgerState blk
-> MempoolCapacityBytesOverride -> MempoolCapacityBytes
forall blk.
LedgerSupportsMempool blk =>
TickedLedgerState blk
-> MempoolCapacityBytesOverride -> MempoolCapacityBytes
Cap.computeMempoolCapacity

{-# DEPRECATED TraceEventMempool "Use Ouroboros.Consensus.Mempool (TraceEventMempool)" #-}
data TraceEventMempool