{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}

-- | Interface to the Shelley ledger for the purposes of managing a Shelley
-- mempool.
module Cardano.Ledger.Shelley.API.Mempool
  ( ApplyTx (..),
    ApplyTxError (..),
    Validated,
    extractTx,
    coerceValidated,
    translateValidated,

    -- * Exports for testing
    MempoolEnv,
    MempoolState,
    applyTxsTransition,
    unsafeMakeValidated,

    -- * Exports for compatibility
    applyTxs,
    mkMempoolEnv,
    mkMempoolState,
    overNewEpochState,
  )
where

import Cardano.Binary (FromCBOR (..), ToCBOR (..))
import Cardano.Ledger.BaseTypes (Globals, ShelleyBase)
import Cardano.Ledger.Core (AnnotatedData, ChainData, SerialisableData)
import qualified Cardano.Ledger.Core as Core
import Cardano.Ledger.Era
  ( Era,
    PreviousEra,
    TranslateEra (translateEra),
    TranslationContext,
    TranslationError,
  )
import Cardano.Ledger.Shelley (ShelleyEra)
import Cardano.Ledger.Shelley.API.Validation (ShelleyEraCrypto)
import Cardano.Ledger.Shelley.LedgerState (NewEpochState)
import qualified Cardano.Ledger.Shelley.LedgerState as LedgerState
import Cardano.Ledger.Shelley.PParams (PParams' (..))
import Cardano.Ledger.Shelley.Rules.Ledger (LedgerEnv, LedgerPredicateFailure)
import qualified Cardano.Ledger.Shelley.Rules.Ledger as Ledger
import Cardano.Ledger.Slot (SlotNo)
import Control.Arrow (ArrowChoice (right), left)
import Control.DeepSeq (NFData)
import Control.Monad.Except
import Control.Monad.Trans.Reader (runReader)
import Control.State.Transition.Extended
  ( BaseM,
    Environment,
    PredicateFailure,
    STS,
    Signal,
    State,
    TRC (..),
    applySTS,
  )
import Data.Coerce (Coercible, coerce)
import Data.Functor ((<&>))
import Data.Sequence (Seq)
import Data.Typeable (Typeable)
import NoThunks.Class (NoThunks)

-- | A newtype which indicates that a transaction has been validated against
-- some chain state.
newtype Validated tx = Validated tx
  deriving (Validated tx -> Validated tx -> Bool
(Validated tx -> Validated tx -> Bool)
-> (Validated tx -> Validated tx -> Bool) -> Eq (Validated tx)
forall tx. Eq tx => Validated tx -> Validated tx -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Validated tx -> Validated tx -> Bool
$c/= :: forall tx. Eq tx => Validated tx -> Validated tx -> Bool
== :: Validated tx -> Validated tx -> Bool
$c== :: forall tx. Eq tx => Validated tx -> Validated tx -> Bool
Eq, Context -> Validated tx -> IO (Maybe ThunkInfo)
Proxy (Validated tx) -> String
(Context -> Validated tx -> IO (Maybe ThunkInfo))
-> (Context -> Validated tx -> IO (Maybe ThunkInfo))
-> (Proxy (Validated tx) -> String)
-> NoThunks (Validated tx)
forall tx.
NoThunks tx =>
Context -> Validated tx -> IO (Maybe ThunkInfo)
forall tx. NoThunks tx => Proxy (Validated tx) -> String
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
showTypeOf :: Proxy (Validated tx) -> String
$cshowTypeOf :: forall tx. NoThunks tx => Proxy (Validated tx) -> String
wNoThunks :: Context -> Validated tx -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall tx.
NoThunks tx =>
Context -> Validated tx -> IO (Maybe ThunkInfo)
noThunks :: Context -> Validated tx -> IO (Maybe ThunkInfo)
$cnoThunks :: forall tx.
NoThunks tx =>
Context -> Validated tx -> IO (Maybe ThunkInfo)
NoThunks, Int -> Validated tx -> ShowS
[Validated tx] -> ShowS
Validated tx -> String
(Int -> Validated tx -> ShowS)
-> (Validated tx -> String)
-> ([Validated tx] -> ShowS)
-> Show (Validated tx)
forall tx. Show tx => Int -> Validated tx -> ShowS
forall tx. Show tx => [Validated tx] -> ShowS
forall tx. Show tx => Validated tx -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Validated tx] -> ShowS
$cshowList :: forall tx. Show tx => [Validated tx] -> ShowS
show :: Validated tx -> String
$cshow :: forall tx. Show tx => Validated tx -> String
showsPrec :: Int -> Validated tx -> ShowS
$cshowsPrec :: forall tx. Show tx => Int -> Validated tx -> ShowS
Show, Validated tx -> ()
(Validated tx -> ()) -> NFData (Validated tx)
forall tx. NFData tx => Validated tx -> ()
forall a. (a -> ()) -> NFData a
rnf :: Validated tx -> ()
$crnf :: forall tx. NFData tx => Validated tx -> ()
NFData)

-- | Extract the underlying unvalidated Tx.
extractTx :: Validated tx -> tx
extractTx :: Validated tx -> tx
extractTx (Validated tx
tx) = tx
tx

coerceValidated :: Coercible a b => Validated a -> Validated b
coerceValidated :: Validated a -> Validated b
coerceValidated (Validated a
a) = b -> Validated b
forall tx. tx -> Validated tx
Validated (b -> Validated b) -> b -> Validated b
forall a b. (a -> b) -> a -> b
$ a -> b
coerce a
a

-- Don't use this except in Testing to make Arbitrary instances, etc.
unsafeMakeValidated :: tx -> Validated tx
unsafeMakeValidated :: tx -> Validated tx
unsafeMakeValidated = tx -> Validated tx
forall tx. tx -> Validated tx
Validated

-- | Translate a validated transaction across eras.
--
-- This is not a `TranslateEra` instance since `Validated` is not itself
-- era-parametrised.
translateValidated ::
  forall era f.
  (TranslateEra era f) =>
  TranslationContext era ->
  Validated (f (PreviousEra era)) ->
  Except (TranslationError era f) (Validated (f era))
translateValidated :: TranslationContext era
-> Validated (f (PreviousEra era))
-> Except (TranslationError era f) (Validated (f era))
translateValidated TranslationContext era
ctx (Validated f (PreviousEra era)
tx) = f era -> Validated (f era)
forall tx. tx -> Validated tx
Validated (f era -> Validated (f era))
-> ExceptT (TranslationError era f) Identity (f era)
-> Except (TranslationError era f) (Validated (f era))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TranslationContext era
-> f (PreviousEra era)
-> ExceptT (TranslationError era f) Identity (f era)
forall era (f :: * -> *).
TranslateEra era f =>
TranslationContext era
-> f (PreviousEra era) -> Except (TranslationError era f) (f era)
translateEra @era TranslationContext era
ctx f (PreviousEra era)
tx

class
  ( ChainData (Core.Tx era),
    AnnotatedData (Core.Tx era),
    Eq (ApplyTxError era),
    Show (ApplyTxError era),
    Typeable (ApplyTxError era),
    SerialisableData (ApplyTxError era),
    STS (Core.EraRule "LEDGER" era),
    BaseM (Core.EraRule "LEDGER" era) ~ ShelleyBase,
    Environment (Core.EraRule "LEDGER" era) ~ LedgerEnv era,
    State (Core.EraRule "LEDGER" era) ~ MempoolState era,
    Signal (Core.EraRule "LEDGER" era) ~ Core.Tx era,
    PredicateFailure (Core.EraRule "LEDGER" era) ~ LedgerPredicateFailure era
  ) =>
  ApplyTx era
  where
  -- | Validate a transaction against a mempool state, and return both the new
  -- mempool state and a "validated" 'TxInBlock'.
  --
  -- The meaning of being "validated" depends on the era. In general, a
  -- 'TxInBlock' has had all checks run, and can now only fail due to checks
  -- which depend on the state; most notably, that UTxO inputs disappear.
  applyTx ::
    MonadError (ApplyTxError era) m =>
    Globals ->
    MempoolEnv era ->
    MempoolState era ->
    Core.Tx era ->
    m (MempoolState era, Validated (Core.Tx era))
  applyTx Globals
globals MempoolEnv era
env MempoolState era
state Tx era
tx =
    let res :: Either [LedgerPredicateFailure era] (MempoolState era)
res =
          (Reader
   Globals (Either [LedgerPredicateFailure era] (MempoolState era))
 -> Globals
 -> Either [LedgerPredicateFailure era] (MempoolState era))
-> Globals
-> Reader
     Globals (Either [LedgerPredicateFailure era] (MempoolState era))
-> Either [LedgerPredicateFailure era] (MempoolState era)
forall a b c. (a -> b -> c) -> b -> a -> c
flip Reader
  Globals (Either [LedgerPredicateFailure era] (MempoolState era))
-> Globals
-> Either [LedgerPredicateFailure era] (MempoolState era)
forall r a. Reader r a -> r -> a
runReader Globals
globals
            (Reader
   Globals (Either [LedgerPredicateFailure era] (MempoolState era))
 -> Either [LedgerPredicateFailure era] (MempoolState era))
-> (TRC (EraRule "LEDGER" era)
    -> Reader
         Globals (Either [LedgerPredicateFailure era] (MempoolState era)))
-> TRC (EraRule "LEDGER" era)
-> Either [LedgerPredicateFailure era] (MempoolState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *) (rtype :: RuleType).
(STS s, RuleTypeRep rtype, m ~ BaseM s) =>
RuleContext rtype s -> m (Either [PredicateFailure s] (State s))
forall (m :: * -> *) (rtype :: RuleType).
(STS (EraRule "LEDGER" era), RuleTypeRep rtype,
 m ~ BaseM (EraRule "LEDGER" era)) =>
RuleContext rtype (EraRule "LEDGER" era)
-> m (Either
        [PredicateFailure (EraRule "LEDGER" era)]
        (State (EraRule "LEDGER" era)))
applySTS @(Core.EraRule "LEDGER" era)
            (TRC (EraRule "LEDGER" era)
 -> Either [LedgerPredicateFailure era] (MempoolState era))
-> TRC (EraRule "LEDGER" era)
-> Either [LedgerPredicateFailure era] (MempoolState era)
forall a b. (a -> b) -> a -> b
$ (Environment (EraRule "LEDGER" era), State (EraRule "LEDGER" era),
 Signal (EraRule "LEDGER" era))
-> TRC (EraRule "LEDGER" era)
forall sts. (Environment sts, State sts, Signal sts) -> TRC sts
TRC (Environment (EraRule "LEDGER" era)
MempoolEnv era
env, State (EraRule "LEDGER" era)
MempoolState era
state, Tx era
Signal (EraRule "LEDGER" era)
tx)
     in Either (ApplyTxError era) (MempoolState era, Validated (Tx era))
-> m (MempoolState era, Validated (Tx era))
forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither
          (Either (ApplyTxError era) (MempoolState era, Validated (Tx era))
 -> m (MempoolState era, Validated (Tx era)))
-> (Either [LedgerPredicateFailure era] (MempoolState era)
    -> Either
         (ApplyTxError era) (MempoolState era, Validated (Tx era)))
-> Either [LedgerPredicateFailure era] (MempoolState era)
-> m (MempoolState era, Validated (Tx era))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([PredicateFailure (EraRule "LEDGER" era)] -> ApplyTxError era)
-> Either
     [PredicateFailure (EraRule "LEDGER" era)]
     (MempoolState era, Validated (Tx era))
-> Either (ApplyTxError era) (MempoolState era, Validated (Tx era))
forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either b d) (Either c d)
left [PredicateFailure (EraRule "LEDGER" era)] -> ApplyTxError era
forall era.
[PredicateFailure (EraRule "LEDGER" era)] -> ApplyTxError era
ApplyTxError
          (Either
   [PredicateFailure (EraRule "LEDGER" era)]
   (MempoolState era, Validated (Tx era))
 -> Either
      (ApplyTxError era) (MempoolState era, Validated (Tx era)))
-> (Either [LedgerPredicateFailure era] (MempoolState era)
    -> Either
         [PredicateFailure (EraRule "LEDGER" era)]
         (MempoolState era, Validated (Tx era)))
-> Either [LedgerPredicateFailure era] (MempoolState era)
-> Either (ApplyTxError era) (MempoolState era, Validated (Tx era))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MempoolState era -> (MempoolState era, Validated (Tx era)))
-> Either
     [PredicateFailure (EraRule "LEDGER" era)] (MempoolState era)
-> Either
     [PredicateFailure (EraRule "LEDGER" era)]
     (MempoolState era, Validated (Tx era))
forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either d b) (Either d c)
right (,Tx era -> Validated (Tx era)
forall tx. tx -> Validated tx
Validated Tx era
tx)
          (Either [LedgerPredicateFailure era] (MempoolState era)
 -> m (MempoolState era, Validated (Tx era)))
-> Either [LedgerPredicateFailure era] (MempoolState era)
-> m (MempoolState era, Validated (Tx era))
forall a b. (a -> b) -> a -> b
$ Either [LedgerPredicateFailure era] (MempoolState era)
res

  -- | Reapply a previously validated 'Tx'.
  --
  --   This applies the (validated) transaction to a new mempool state. It may
  --   fail due to the mempool state changing (for example, a needed output
  --   having already been spent). It should not fail due to any static check
  --   (such as cryptographic checks).
  --
  --   Implementations of this function may optionally skip the performance of
  --   any static checks. This is not required, but strongly encouraged since
  --   this function will be called each time the mempool revalidates
  --   transactions against a new mempool state.
  reapplyTx ::
    MonadError (ApplyTxError era) m =>
    Globals ->
    MempoolEnv era ->
    MempoolState era ->
    Validated (Core.Tx era) ->
    m (MempoolState era)
  reapplyTx Globals
globals MempoolEnv era
env MempoolState era
state (Validated Tx era
tx) =
    let res :: Either [LedgerPredicateFailure era] (MempoolState era)
res =
          (Reader
   Globals (Either [LedgerPredicateFailure era] (MempoolState era))
 -> Globals
 -> Either [LedgerPredicateFailure era] (MempoolState era))
-> Globals
-> Reader
     Globals (Either [LedgerPredicateFailure era] (MempoolState era))
-> Either [LedgerPredicateFailure era] (MempoolState era)
forall a b c. (a -> b -> c) -> b -> a -> c
flip Reader
  Globals (Either [LedgerPredicateFailure era] (MempoolState era))
-> Globals
-> Either [LedgerPredicateFailure era] (MempoolState era)
forall r a. Reader r a -> r -> a
runReader Globals
globals
            (Reader
   Globals (Either [LedgerPredicateFailure era] (MempoolState era))
 -> Either [LedgerPredicateFailure era] (MempoolState era))
-> (TRC (EraRule "LEDGER" era)
    -> Reader
         Globals (Either [LedgerPredicateFailure era] (MempoolState era)))
-> TRC (EraRule "LEDGER" era)
-> Either [LedgerPredicateFailure era] (MempoolState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *) (rtype :: RuleType).
(STS s, RuleTypeRep rtype, m ~ BaseM s) =>
RuleContext rtype s -> m (Either [PredicateFailure s] (State s))
forall (m :: * -> *) (rtype :: RuleType).
(STS (EraRule "LEDGER" era), RuleTypeRep rtype,
 m ~ BaseM (EraRule "LEDGER" era)) =>
RuleContext rtype (EraRule "LEDGER" era)
-> m (Either
        [PredicateFailure (EraRule "LEDGER" era)]
        (State (EraRule "LEDGER" era)))
applySTS @(Core.EraRule "LEDGER" era)
            (TRC (EraRule "LEDGER" era)
 -> Either [LedgerPredicateFailure era] (MempoolState era))
-> TRC (EraRule "LEDGER" era)
-> Either [LedgerPredicateFailure era] (MempoolState era)
forall a b. (a -> b) -> a -> b
$ (Environment (EraRule "LEDGER" era), State (EraRule "LEDGER" era),
 Signal (EraRule "LEDGER" era))
-> TRC (EraRule "LEDGER" era)
forall sts. (Environment sts, State sts, Signal sts) -> TRC sts
TRC (Environment (EraRule "LEDGER" era)
MempoolEnv era
env, State (EraRule "LEDGER" era)
MempoolState era
state, Tx era
Signal (EraRule "LEDGER" era)
tx)
     in Either (ApplyTxError era) (MempoolState era)
-> m (MempoolState era)
forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither
          (Either (ApplyTxError era) (MempoolState era)
 -> m (MempoolState era))
-> (Either [LedgerPredicateFailure era] (MempoolState era)
    -> Either (ApplyTxError era) (MempoolState era))
-> Either [LedgerPredicateFailure era] (MempoolState era)
-> m (MempoolState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([PredicateFailure (EraRule "LEDGER" era)] -> ApplyTxError era)
-> Either
     [PredicateFailure (EraRule "LEDGER" era)] (MempoolState era)
-> Either (ApplyTxError era) (MempoolState era)
forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either b d) (Either c d)
left [PredicateFailure (EraRule "LEDGER" era)] -> ApplyTxError era
forall era.
[PredicateFailure (EraRule "LEDGER" era)] -> ApplyTxError era
ApplyTxError
          (Either [LedgerPredicateFailure era] (MempoolState era)
 -> m (MempoolState era))
-> Either [LedgerPredicateFailure era] (MempoolState era)
-> m (MempoolState era)
forall a b. (a -> b) -> a -> b
$ Either [LedgerPredicateFailure era] (MempoolState era)
res

instance ShelleyEraCrypto c => ApplyTx (ShelleyEra c)

type MempoolEnv era = Ledger.LedgerEnv era

type MempoolState era = LedgerState.LedgerState era

-- | Construct the environment used to validate transactions from the full
-- ledger state.
--
-- Note that this function also takes a slot. During slot validation, the slot
-- given here is the slot of the block containing the transactions. This slot is
-- used for quite a number of things, but in general these do not determine the
-- validity of the transaction. There are two exceptions:
--
-- - Each transaction has a ttl (time-to-live) value. If the slot is beyond this
--   value, then the transaction is invalid.
-- - If the transaction contains a protocol update proposal, then it may only be
--   included until a certain number of slots before the end of the epoch. A
--   protocol update proposal submitted after this is considered invalid.
mkMempoolEnv ::
  NewEpochState era ->
  SlotNo ->
  MempoolEnv era
mkMempoolEnv :: NewEpochState era -> SlotNo -> MempoolEnv era
mkMempoolEnv
  LedgerState.NewEpochState
    { EpochState era
nesEs :: forall era. NewEpochState era -> EpochState era
nesEs :: EpochState era
LedgerState.nesEs
    }
  SlotNo
slot =
    LedgerEnv :: forall era.
SlotNo -> TxIx -> PParams era -> AccountState -> LedgerEnv era
Ledger.LedgerEnv
      { ledgerSlotNo :: SlotNo
Ledger.ledgerSlotNo = SlotNo
slot,
        ledgerIx :: TxIx
Ledger.ledgerIx = TxIx
forall a. Bounded a => a
minBound,
        ledgerPp :: PParams era
Ledger.ledgerPp = EpochState era -> PParams era
forall era. EpochState era -> PParams era
LedgerState.esPp EpochState era
nesEs,
        ledgerAccount :: AccountState
Ledger.ledgerAccount = EpochState era -> AccountState
forall era. EpochState era -> AccountState
LedgerState.esAccountState EpochState era
nesEs
      }

-- | Construct a mempool state from the wider ledger state.
--
--   The given mempool state may then be evolved using 'applyTxs', but should be
--   regenerated when the ledger state gets updated (e.g. through application of
--   a new block).
mkMempoolState :: NewEpochState era -> MempoolState era
mkMempoolState :: NewEpochState era -> MempoolState era
mkMempoolState LedgerState.NewEpochState {EpochState era
nesEs :: EpochState era
nesEs :: forall era. NewEpochState era -> EpochState era
LedgerState.nesEs} = EpochState era -> MempoolState era
forall era. EpochState era -> LedgerState era
LedgerState.esLState EpochState era
nesEs

newtype ApplyTxError era = ApplyTxError [PredicateFailure (Core.EraRule "LEDGER" era)]

deriving stock instance
  (Eq (PredicateFailure (Core.EraRule "LEDGER" era))) =>
  Eq (ApplyTxError era)

deriving stock instance
  (Show (PredicateFailure (Core.EraRule "LEDGER" era))) =>
  Show (ApplyTxError era)

instance
  ( Era era,
    ToCBOR (PredicateFailure (Core.EraRule "LEDGER" era))
  ) =>
  ToCBOR (ApplyTxError era)
  where
  toCBOR :: ApplyTxError era -> Encoding
toCBOR (ApplyTxError [PredicateFailure (EraRule "LEDGER" era)]
es) = [PredicateFailure (EraRule "LEDGER" era)] -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR [PredicateFailure (EraRule "LEDGER" era)]
es

instance
  ( Era era,
    FromCBOR (PredicateFailure (Core.EraRule "LEDGER" era))
  ) =>
  FromCBOR (ApplyTxError era)
  where
  fromCBOR :: Decoder s (ApplyTxError era)
fromCBOR = [PredicateFailure (EraRule "LEDGER" era)] -> ApplyTxError era
forall era.
[PredicateFailure (EraRule "LEDGER" era)] -> ApplyTxError era
ApplyTxError ([PredicateFailure (EraRule "LEDGER" era)] -> ApplyTxError era)
-> Decoder s [PredicateFailure (EraRule "LEDGER" era)]
-> Decoder s (ApplyTxError era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s [PredicateFailure (EraRule "LEDGER" era)]
forall a s. FromCBOR a => Decoder s a
fromCBOR

-- | Old 'applyTxs'
applyTxs ::
  (ApplyTx era, MonadError (ApplyTxError era) m) =>
  Globals ->
  SlotNo ->
  Seq (Core.Tx era) ->
  NewEpochState era ->
  m (NewEpochState era)
applyTxs :: Globals
-> SlotNo
-> Seq (Tx era)
-> NewEpochState era
-> m (NewEpochState era)
applyTxs
  Globals
globals
  SlotNo
slot
  Seq (Tx era)
txs
  NewEpochState era
state =
    (MempoolState era -> m (MempoolState era))
-> NewEpochState era -> m (NewEpochState era)
forall (f :: * -> *) era.
Functor f =>
(MempoolState era -> f (MempoolState era))
-> NewEpochState era -> f (NewEpochState era)
overNewEpochState (Globals
-> MempoolEnv era
-> Seq (Tx era)
-> MempoolState era
-> m (MempoolState era)
forall era (m :: * -> *).
(ApplyTx era, MonadError (ApplyTxError era) m) =>
Globals
-> MempoolEnv era
-> Seq (Tx era)
-> MempoolState era
-> m (MempoolState era)
applyTxsTransition Globals
globals MempoolEnv era
mempoolEnv Seq (Tx era)
txs) NewEpochState era
state
    where
      mempoolEnv :: MempoolEnv era
mempoolEnv = NewEpochState era -> SlotNo -> MempoolEnv era
forall era. NewEpochState era -> SlotNo -> MempoolEnv era
mkMempoolEnv NewEpochState era
state SlotNo
slot

applyTxsTransition ::
  forall era m.
  ( ApplyTx era,
    MonadError (ApplyTxError era) m
  ) =>
  Globals ->
  MempoolEnv era ->
  Seq (Core.Tx era) ->
  MempoolState era ->
  m (MempoolState era)
applyTxsTransition :: Globals
-> MempoolEnv era
-> Seq (Tx era)
-> MempoolState era
-> m (MempoolState era)
applyTxsTransition Globals
globals MempoolEnv era
env Seq (Tx era)
txs MempoolState era
state =
  (MempoolState era -> Tx era -> m (MempoolState era))
-> MempoolState era -> Seq (Tx era) -> m (MempoolState era)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM
    (\MempoolState era
st Tx era
tx -> (MempoolState era, Validated (Tx era)) -> MempoolState era
forall a b. (a, b) -> a
fst ((MempoolState era, Validated (Tx era)) -> MempoolState era)
-> m (MempoolState era, Validated (Tx era)) -> m (MempoolState era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Globals
-> MempoolEnv era
-> MempoolState era
-> Tx era
-> m (MempoolState era, Validated (Tx era))
forall era (m :: * -> *).
(ApplyTx era, MonadError (ApplyTxError era) m) =>
Globals
-> MempoolEnv era
-> MempoolState era
-> Tx era
-> m (MempoolState era, Validated (Tx era))
applyTx Globals
globals MempoolEnv era
env MempoolState era
st Tx era
tx)
    MempoolState era
state
    Seq (Tx era)
txs

-- | Transform a function over mempool states to one over the full
-- 'NewEpochState'.
overNewEpochState ::
  Functor f =>
  (MempoolState era -> f (MempoolState era)) ->
  NewEpochState era ->
  f (NewEpochState era)
overNewEpochState :: (MempoolState era -> f (MempoolState era))
-> NewEpochState era -> f (NewEpochState era)
overNewEpochState MempoolState era -> f (MempoolState era)
f NewEpochState era
st = do
  MempoolState era -> f (MempoolState era)
f (NewEpochState era -> MempoolState era
forall era. NewEpochState era -> MempoolState era
mkMempoolState NewEpochState era
st)
    f (MempoolState era)
-> (MempoolState era -> NewEpochState era) -> f (NewEpochState era)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \MempoolState era
ls ->
      NewEpochState era
st
        { nesEs :: EpochState era
LedgerState.nesEs =
            (NewEpochState era -> EpochState era
forall era. NewEpochState era -> EpochState era
LedgerState.nesEs NewEpochState era
st)
              { esLState :: MempoolState era
LedgerState.esLState = MempoolState era
ls
              }
        }