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

-- | Types required for implementing the Mempool.

module Ouroboros.Consensus.Mempool.Impl.Types (
    -- * Internal State
    InternalState (..)
  , initInternalState
  , isMempoolSize
    -- * Validation result
  , ValidationResult (..)
  , extendVRNew
  , extendVRPrevApplied
  , revalidateTxsFor
  , validateIS
  , validateStateFor
    -- * Tick ledger state
  , tickLedgerState
    -- * Conversions
  , internalStateFromVR
  , validationResultFromIS
  ) where

import           Control.Exception (assert)
import           Control.Monad.Except
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.SupportsMempool
import           Ouroboros.Consensus.Mempool.API
import           Ouroboros.Consensus.Mempool.TxSeq (TicketNo, TxSeq (..),
                     TxTicket (..))
import qualified Ouroboros.Consensus.Mempool.TxSeq as TxSeq
import           Ouroboros.Consensus.Util (repeatedly)
import           Ouroboros.Consensus.Util.IOLike

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

      -- | The cached IDs of transactions that were found to be valid (oldest to
      -- newest)
    , 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).
    , 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'.
    , ValidationResult invalidTx blk -> TickedLedgerState blk
vrAfter          :: TickedLedgerState blk

      -- | The transactions that were invalid, along with their errors
      --
      -- From oldest to newest.
    , 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.
    , 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 (Validated (GenTx blk))
                    -> ValidationResult (Validated (GenTx blk)) blk
                    -> ValidationResult (Validated (GenTx blk)) blk
extendVRPrevApplied :: LedgerConfig blk
-> TxTicket (Validated (GenTx blk))
-> ValidationResult (Validated (GenTx blk)) blk
-> ValidationResult (Validated (GenTx blk)) blk
extendVRPrevApplied LedgerConfig blk
cfg TxTicket (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)
-> TickedLedgerState blk
-> Except (ApplyTxErr blk) (TickedLedgerState 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 :: [(Validated (GenTx blk), ApplyTxErr blk)]
vrInvalid = (Validated (GenTx blk)
tx, ApplyTxErr blk
err) (Validated (GenTx blk), ApplyTxErr blk)
-> [(Validated (GenTx blk), ApplyTxErr blk)]
-> [(Validated (GenTx blk), ApplyTxErr blk)]
forall a. a -> [a] -> [a]
: [(Validated (GenTx blk), ApplyTxErr blk)]
vrInvalid
                      }
      Right TickedLedgerState blk
st' -> ValidationResult (Validated (GenTx blk)) blk
vr { vrValid :: TxSeq (Validated (GenTx blk))
vrValid      = TxSeq (Validated (GenTx blk))
vrValid TxSeq (Validated (GenTx blk))
-> TxTicket (Validated (GenTx blk))
-> TxSeq (Validated (GenTx blk))
forall tx. TxSeq tx -> TxTicket tx -> TxSeq tx
:> TxTicket (Validated (GenTx blk))
txTicket
                      , vrValidTxIds :: Set (GenTxId blk)
vrValidTxIds = GenTxId blk -> Set (GenTxId blk) -> Set (GenTxId blk)
forall a. Ord a => a -> Set a -> Set a
Set.insert (GenTx blk -> GenTxId blk
forall tx. HasTxId tx => tx -> TxId tx
txId (Validated (GenTx blk) -> GenTx blk
forall blk.
LedgerSupportsMempool blk =>
Validated (GenTx blk) -> GenTx blk
txForgetValidated Validated (GenTx blk)
tx)) Set (GenTxId blk)
vrValidTxIds
                      , vrAfter :: TickedLedgerState blk
vrAfter      = TickedLedgerState blk
st'
                      }
  where
    TxTicket { txTicketTx :: forall tx. TxTicket tx -> tx
txTicketTx = Validated (GenTx blk)
tx } = TxTicket (Validated (GenTx blk))
txTicket
    ValidationResult { TxSeq (Validated (GenTx blk))
vrValid :: TxSeq (Validated (GenTx blk))
vrValid :: forall invalidTx blk.
ValidationResult invalidTx blk -> TxSeq (Validated (GenTx blk))
vrValid, SlotNo
vrSlotNo :: SlotNo
vrSlotNo :: forall invalidTx blk. ValidationResult invalidTx blk -> SlotNo
vrSlotNo, Set (GenTxId blk)
vrValidTxIds :: Set (GenTxId blk)
vrValidTxIds :: forall invalidTx blk.
ValidationResult invalidTx blk -> Set (GenTxId blk)
vrValidTxIds, TickedLedgerState blk
vrAfter :: TickedLedgerState blk
vrAfter :: forall invalidTx blk.
ValidationResult invalidTx blk -> TickedLedgerState blk
vrAfter, [(Validated (GenTx blk), ApplyTxErr blk)]
vrInvalid :: [(Validated (GenTx blk), ApplyTxErr blk)]
vrInvalid :: forall invalidTx blk.
ValidationResult invalidTx blk -> [(invalidTx, 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
            -> (GenTx blk -> TxSizeInBytes)
            -> WhetherToIntervene
            -> GenTx blk
            -> ValidationResult (GenTx blk) blk
            -> ( Either (ApplyTxErr blk) (Validated (GenTx blk))
               , ValidationResult (GenTx blk) blk
               )
extendVRNew :: LedgerConfig blk
-> (GenTx blk -> TxSizeInBytes)
-> WhetherToIntervene
-> GenTx blk
-> ValidationResult (GenTx blk) blk
-> (Either (ApplyTxErr blk) (Validated (GenTx blk)),
    ValidationResult (GenTx blk) blk)
extendVRNew LedgerConfig blk
cfg GenTx blk -> TxSizeInBytes
txSize 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
$
    case Except
  (ApplyTxErr blk) (TickedLedgerState blk, Validated (GenTx blk))
-> Either
     (ApplyTxErr blk) (TickedLedgerState blk, Validated (GenTx blk))
forall e a. Except e a -> Either e a
runExcept (LedgerConfig blk
-> WhetherToIntervene
-> SlotNo
-> GenTx blk
-> TickedLedgerState blk
-> Except
     (ApplyTxErr blk) (TickedLedgerState blk, Validated (GenTx blk))
forall blk.
LedgerSupportsMempool blk =>
LedgerConfig blk
-> WhetherToIntervene
-> SlotNo
-> GenTx blk
-> TickedLedgerState blk
-> Except
     (ApplyTxErr blk) (TickedLedgerState blk, Validated (GenTx blk))
applyTx LedgerConfig blk
cfg WhetherToIntervene
wti SlotNo
vrSlotNo GenTx blk
tx TickedLedgerState blk
vrAfter) of
      Left ApplyTxErr blk
err         ->
        ( ApplyTxErr blk -> Either (ApplyTxErr blk) (Validated (GenTx blk))
forall a b. a -> Either a b
Left ApplyTxErr blk
err
        , ValidationResult (GenTx blk) blk
vr { vrInvalid :: [(GenTx blk, ApplyTxErr blk)]
vrInvalid      = (GenTx blk
tx, ApplyTxErr blk
err) (GenTx blk, ApplyTxErr blk)
-> [(GenTx blk, ApplyTxErr blk)] -> [(GenTx blk, ApplyTxErr blk)]
forall a. a -> [a] -> [a]
: [(GenTx blk, ApplyTxErr blk)]
vrInvalid
             }
        )
      Right (TickedLedgerState blk
st', Validated (GenTx blk)
vtx) ->
        ( Validated (GenTx blk)
-> Either (ApplyTxErr blk) (Validated (GenTx blk))
forall a b. b -> Either a b
Right Validated (GenTx blk)
vtx
        , ValidationResult (GenTx blk) blk
vr { vrValid :: TxSeq (Validated (GenTx blk))
vrValid        = TxSeq (Validated (GenTx blk))
vrValid TxSeq (Validated (GenTx blk))
-> TxTicket (Validated (GenTx blk))
-> TxSeq (Validated (GenTx blk))
forall tx. TxSeq tx -> TxTicket tx -> TxSeq tx
:> Validated (GenTx blk)
-> TicketNo -> TxSizeInBytes -> TxTicket (Validated (GenTx blk))
forall tx. tx -> TicketNo -> TxSizeInBytes -> TxTicket tx
TxTicket Validated (GenTx blk)
vtx TicketNo
nextTicketNo (GenTx blk -> TxSizeInBytes
txSize GenTx blk
tx)
             , vrValidTxIds :: Set (GenTxId blk)
vrValidTxIds   = GenTxId blk -> Set (GenTxId blk) -> Set (GenTxId blk)
forall a. Ord a => a -> Set a -> Set a
Set.insert (GenTx blk -> GenTxId blk
forall tx. HasTxId tx => tx -> TxId tx
txId GenTx blk
tx) Set (GenTxId blk)
vrValidTxIds
             , vrNewValid :: Maybe (Validated (GenTx blk))
vrNewValid     = Validated (GenTx blk) -> Maybe (Validated (GenTx blk))
forall a. a -> Maybe a
Just Validated (GenTx blk)
vtx
             , vrAfter :: TickedLedgerState blk
vrAfter        = TickedLedgerState blk
st'
             , vrLastTicketNo :: TicketNo
vrLastTicketNo = TicketNo
nextTicketNo
             }
        )
  where
    ValidationResult {
        TxSeq (Validated (GenTx blk))
vrValid :: TxSeq (Validated (GenTx blk))
vrValid :: forall invalidTx blk.
ValidationResult invalidTx blk -> TxSeq (Validated (GenTx blk))
vrValid
      , Set (GenTxId blk)
vrValidTxIds :: Set (GenTxId blk)
vrValidTxIds :: forall invalidTx blk.
ValidationResult invalidTx blk -> Set (GenTxId blk)
vrValidTxIds
      , TickedLedgerState blk
vrAfter :: TickedLedgerState blk
vrAfter :: forall invalidTx blk.
ValidationResult invalidTx blk -> TickedLedgerState blk
vrAfter
      , [(GenTx blk, ApplyTxErr blk)]
vrInvalid :: [(GenTx blk, ApplyTxErr blk)]
vrInvalid :: forall invalidTx blk.
ValidationResult invalidTx blk -> [(invalidTx, ApplyTxErr blk)]
vrInvalid
      , TicketNo
vrLastTicketNo :: TicketNo
vrLastTicketNo :: forall invalidTx blk. ValidationResult invalidTx blk -> TicketNo
vrLastTicketNo
      , Maybe (Validated (GenTx blk))
vrNewValid :: Maybe (Validated (GenTx blk))
vrNewValid :: forall invalidTx blk.
ValidationResult invalidTx blk -> Maybe (Validated (GenTx blk))
vrNewValid
      , SlotNo
vrSlotNo :: SlotNo
vrSlotNo :: forall invalidTx blk. ValidationResult invalidTx blk -> SlotNo
vrSlotNo
      } = ValidationResult (GenTx blk) blk
vr

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

-- | Validate the internal state against the current ledger state and the
-- given 'BlockSlot', revalidating if necessary.
validateIS
  :: (LedgerSupportsMempool blk, HasTxId (GenTx blk), ValidateEnvelope blk)
  => InternalState blk
  -> LedgerState blk
  -> LedgerConfig blk
  -> MempoolCapacityBytesOverride
  -> ValidationResult (Validated (GenTx blk)) blk
validateIS :: InternalState blk
-> LedgerState blk
-> LedgerConfig blk
-> MempoolCapacityBytesOverride
-> ValidationResult (Validated (GenTx blk)) blk
validateIS InternalState blk
istate LedgerState blk
lstate LedgerConfig blk
lconfig MempoolCapacityBytesOverride
capacityOverride =
    MempoolCapacityBytesOverride
-> LedgerConfig blk
-> ForgeLedgerState blk
-> InternalState blk
-> ValidationResult (Validated (GenTx blk)) blk
forall blk.
(LedgerSupportsMempool blk, HasTxId (GenTx blk),
 ValidateEnvelope blk) =>
MempoolCapacityBytesOverride
-> LedgerConfig blk
-> ForgeLedgerState blk
-> InternalState blk
-> ValidationResult (Validated (GenTx blk)) blk
validateStateFor MempoolCapacityBytesOverride
capacityOverride LedgerConfig blk
lconfig (LedgerState blk -> ForgeLedgerState blk
forall blk. LedgerState blk -> ForgeLedgerState blk
ForgeInUnknownSlot LedgerState blk
lstate) InternalState blk
istate

-- | 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 :: MempoolCapacityBytesOverride
-> LedgerConfig blk
-> ForgeLedgerState blk
-> InternalState blk
-> ValidationResult (Validated (GenTx blk)) blk
validateStateFor MempoolCapacityBytesOverride
capacityOverride LedgerConfig blk
cfg ForgeLedgerState blk
blockLedgerState InternalState blk
is
    | ChainHash blk
isTip    ChainHash blk -> ChainHash blk -> Bool
forall a. Eq a => a -> a -> Bool
== ChainHash (TickedLedgerState blk) -> ChainHash blk
forall b b'.
Coercible (HeaderHash b) (HeaderHash b') =>
ChainHash b -> ChainHash b'
castHash (TickedLedgerState blk -> ChainHash (TickedLedgerState blk)
forall l. GetTip l => l -> ChainHash l
getTipHash TickedLedgerState blk
st')
    , SlotNo
isSlotNo SlotNo -> SlotNo -> Bool
forall a. Eq a => a -> a -> Bool
== SlotNo
slot
    = InternalState blk -> ValidationResult (Validated (GenTx blk)) blk
forall blk invalidTx.
InternalState blk -> ValidationResult invalidTx blk
validationResultFromIS InternalState blk
is
    | Bool
otherwise
    = MempoolCapacityBytesOverride
-> LedgerConfig blk
-> SlotNo
-> TickedLedgerState blk
-> TicketNo
-> [TxTicket (Validated (GenTx blk))]
-> ValidationResult (Validated (GenTx blk)) blk
forall blk.
(LedgerSupportsMempool blk, HasTxId (GenTx blk)) =>
MempoolCapacityBytesOverride
-> LedgerConfig blk
-> SlotNo
-> TickedLedgerState blk
-> TicketNo
-> [TxTicket (Validated (GenTx blk))]
-> ValidationResult (Validated (GenTx blk)) blk
revalidateTxsFor
        MempoolCapacityBytesOverride
capacityOverride
        LedgerConfig blk
cfg
        SlotNo
slot
        TickedLedgerState blk
st'
        TicketNo
isLastTicketNo
        (TxSeq (Validated (GenTx blk)) -> [TxTicket (Validated (GenTx blk))]
forall tx. TxSeq tx -> [TxTicket tx]
TxSeq.toList TxSeq (Validated (GenTx blk))
isTxs)
  where
    IS { TxSeq (Validated (GenTx blk))
isTxs :: TxSeq (Validated (GenTx blk))
isTxs :: forall blk. InternalState blk -> TxSeq (Validated (GenTx blk))
isTxs, ChainHash blk
isTip :: ChainHash blk
isTip :: forall blk. InternalState blk -> ChainHash blk
isTip, SlotNo
isSlotNo :: SlotNo
isSlotNo :: forall blk. InternalState blk -> SlotNo
isSlotNo, TicketNo
isLastTicketNo :: TicketNo
isLastTicketNo :: forall blk. InternalState blk -> TicketNo
isLastTicketNo } = InternalState blk
is
    (SlotNo
slot, TickedLedgerState blk
st') = LedgerConfig blk
-> ForgeLedgerState blk -> (SlotNo, TickedLedgerState blk)
forall blk.
(UpdateLedger blk, ValidateEnvelope blk) =>
LedgerConfig blk
-> ForgeLedgerState blk -> (SlotNo, TickedLedgerState blk)
tickLedgerState LedgerConfig blk
cfg ForgeLedgerState blk
blockLedgerState

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

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

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

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

-- | Construct a 'ValidationResult' from internal state.
validationResultFromIS :: InternalState blk -> ValidationResult invalidTx blk
validationResultFromIS :: InternalState blk -> ValidationResult invalidTx blk
validationResultFromIS InternalState blk
is = ValidationResult :: forall invalidTx blk.
ChainHash blk
-> SlotNo
-> MempoolCapacityBytes
-> TxSeq (Validated (GenTx blk))
-> Set (GenTxId blk)
-> Maybe (Validated (GenTx blk))
-> TickedLedgerState blk
-> [(invalidTx, ApplyTxErr blk)]
-> TicketNo
-> ValidationResult invalidTx blk
ValidationResult {
      vrBeforeTip :: ChainHash blk
vrBeforeTip      = ChainHash blk
isTip
    , vrSlotNo :: SlotNo
vrSlotNo         = SlotNo
isSlotNo
    , vrBeforeCapacity :: MempoolCapacityBytes
vrBeforeCapacity = MempoolCapacityBytes
isCapacity
    , vrValid :: TxSeq (Validated (GenTx blk))
vrValid          = TxSeq (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 (Validated (GenTx blk))
isTxs :: TxSeq (Validated (GenTx blk))
isTxs :: forall blk. InternalState blk -> TxSeq (Validated (GenTx blk))
isTxs
      , Set (GenTxId blk)
isTxIds :: Set (GenTxId blk)
isTxIds :: forall blk. InternalState blk -> Set (GenTxId blk)
isTxIds
      , TickedLedgerState blk
isLedgerState :: TickedLedgerState blk
isLedgerState :: forall blk. InternalState blk -> TickedLedgerState blk
isLedgerState
      , ChainHash blk
isTip :: ChainHash blk
isTip :: forall blk. InternalState blk -> ChainHash blk
isTip
      , SlotNo
isSlotNo :: SlotNo
isSlotNo :: forall blk. InternalState blk -> SlotNo
isSlotNo
      , TicketNo
isLastTicketNo :: TicketNo
isLastTicketNo :: forall blk. InternalState blk -> TicketNo
isLastTicketNo
      , MempoolCapacityBytes
isCapacity :: MempoolCapacityBytes
isCapacity :: forall blk. InternalState blk -> MempoolCapacityBytes
isCapacity
      } = InternalState blk
is