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

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

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

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

import Cardano.Ledger.BaseTypes (Globals, ShelleyBase, epochInfo, systemStart)
import Cardano.Ledger.Binary (DecCBOR, EncCBOR)
import Cardano.Ledger.Core
import Cardano.Ledger.Rules.ValidationMode (lblStatic)
import Cardano.Ledger.Shelley.Core (EraGov)
import Cardano.Ledger.Shelley.Era (ShelleyEra)
import Cardano.Ledger.Shelley.LedgerState (NewEpochState, curPParamsEpochStateL)
import qualified Cardano.Ledger.Shelley.LedgerState as LedgerState
import Cardano.Ledger.Shelley.Rules.Ledger (LedgerEnv, ShelleyLedgerPredFailure, ledgerPpL)
import qualified Cardano.Ledger.Shelley.Rules.Ledger as Ledger
import Cardano.Ledger.Slot (SlotNo)
import Cardano.Ledger.State (UTxO, utxoG)
import Cardano.Slotting.EpochInfo (EpochInfo)
import Cardano.Slotting.Time (SystemStart)
import Control.DeepSeq (NFData)
import Control.Monad.Except (Except)
import Control.Monad.Trans.Reader (runReader)
import Control.State.Transition.Extended
import Data.Bifunctor (Bifunctor (first))
import Data.Coerce (Coercible, coerce)
import Data.Functor ((<&>))
import Data.List.NonEmpty (NonEmpty)
import Data.Text (Text)
import Data.Typeable (Typeable)
import GHC.Generics (Generic)
import Lens.Micro ((^.))
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
$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
/= :: 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
$cnoThunks :: forall tx.
NoThunks tx =>
Context -> Validated tx -> IO (Maybe ThunkInfo)
noThunks :: Context -> Validated tx -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall tx.
NoThunks tx =>
Context -> Validated tx -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> Validated tx -> IO (Maybe ThunkInfo)
$cshowTypeOf :: forall tx. NoThunks tx => Proxy (Validated tx) -> String
showTypeOf :: Proxy (Validated tx) -> String
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
$cshowsPrec :: forall tx. Show tx => Int -> Validated tx -> ShowS
showsPrec :: Int -> Validated tx -> ShowS
$cshow :: forall tx. Show tx => Validated tx -> String
show :: Validated tx -> String
$cshowList :: forall tx. Show tx => [Validated tx] -> ShowS
showList :: [Validated tx] -> ShowS
Show, Validated tx -> ()
(Validated tx -> ()) -> NFData (Validated tx)
forall tx. NFData tx => Validated tx -> ()
forall a. (a -> ()) -> NFData a
$crnf :: forall tx. NFData tx => Validated tx -> ()
rnf :: Validated tx -> ()
NFData)

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

coerceValidated :: Coercible a b => Validated a -> Validated b
coerceValidated :: forall a b. Coercible a b => 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
forall a b. Coercible a b => a -> b
coerce a
a

-- Don't use this except in Testing to make Arbitrary instances, etc.
unsafeMakeValidated :: tx -> Validated tx
unsafeMakeValidated :: forall tx. 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 :: forall era (f :: * -> *).
TranslateEra era f =>
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)
-> ExceptT (TranslationError era f) Identity (Validated (f era))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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
  ( EraTx era
  , Eq (ApplyTxError era)
  , Show (ApplyTxError era)
  , Typeable (ApplyTxError era)
  , Semigroup (ApplyTxError era)
  , EncCBOR (ApplyTxError era)
  , DecCBOR (ApplyTxError era)
  ) =>
  ApplyTx era
  where
  data ApplyTxError era

  mkStAnnTx ::
    EpochInfo (Either Text) ->
    SystemStart ->
    PParams era ->
    UTxO era ->
    Tx TopTx era ->
    StAnnTx TopTx era

  -- | Validate a state annotated transaction against a mempool state for given STS
  -- options, and return the new mempool state, a "validated" 'TxInBlock' and,
  -- depending on the passed options, the emitted events.
  applyTxValidation ::
    ValidationPolicy ->
    Globals ->
    MempoolEnv era ->
    MempoolState era ->
    StAnnTx TopTx era ->
    Either (ApplyTxError era) (MempoolState era, Validated (Tx TopTx era))

ruleApplyTxValidation ::
  forall rule era.
  ( EraTx era
  , STS (EraRule rule era)
  , BaseM (EraRule rule era) ~ ShelleyBase
  , Environment (EraRule rule era) ~ LedgerEnv era
  , State (EraRule rule era) ~ MempoolState era
  , Signal (EraRule rule era) ~ StAnnTx TopTx era
  ) =>
  ValidationPolicy ->
  Globals ->
  MempoolEnv era ->
  MempoolState era ->
  StAnnTx TopTx era ->
  Either (NonEmpty (PredicateFailure (EraRule rule era))) (MempoolState era, Validated (Tx TopTx era))
ruleApplyTxValidation :: forall (rule :: Symbol) era.
(EraTx era, STS (EraRule rule era),
 BaseM (EraRule rule era) ~ ShelleyBase,
 Environment (EraRule rule era) ~ LedgerEnv era,
 State (EraRule rule era) ~ MempoolState era,
 Signal (EraRule rule era) ~ StAnnTx TopTx era) =>
ValidationPolicy
-> Globals
-> LedgerEnv era
-> MempoolState era
-> StAnnTx TopTx era
-> Either
     (NonEmpty (PredicateFailure (EraRule rule era)))
     (MempoolState era, Validated (Tx TopTx era))
ruleApplyTxValidation ValidationPolicy
validationPolicy Globals
globals LedgerEnv era
env MempoolState era
state StAnnTx TopTx era
stAnnTx =
  let opts :: ApplySTSOpts 'EventPolicyDiscard
opts =
        ApplySTSOpts
          { asoAssertions :: AssertionPolicy
asoAssertions = AssertionPolicy
globalAssertionPolicy
          , asoValidation :: ValidationPolicy
asoValidation = ValidationPolicy
validationPolicy
          , asoEvents :: SingEP 'EventPolicyDiscard
asoEvents = SingEP 'EventPolicyDiscard
EPDiscard
          }
      result :: Either
  (NonEmpty (PredicateFailure (EraRule rule era))) (MempoolState era)
result =
        (Reader
   Globals
   (Either
      (NonEmpty (PredicateFailure (EraRule rule era)))
      (MempoolState era))
 -> Globals
 -> Either
      (NonEmpty (PredicateFailure (EraRule rule era)))
      (MempoolState era))
-> Globals
-> Reader
     Globals
     (Either
        (NonEmpty (PredicateFailure (EraRule rule era)))
        (MempoolState era))
-> Either
     (NonEmpty (PredicateFailure (EraRule rule era))) (MempoolState era)
forall a b c. (a -> b -> c) -> b -> a -> c
flip Reader
  Globals
  (Either
     (NonEmpty (PredicateFailure (EraRule rule era)))
     (MempoolState era))
-> Globals
-> Either
     (NonEmpty (PredicateFailure (EraRule rule era))) (MempoolState era)
forall r a. Reader r a -> r -> a
runReader Globals
globals
          (Reader
   Globals
   (Either
      (NonEmpty (PredicateFailure (EraRule rule era)))
      (MempoolState era))
 -> Either
      (NonEmpty (PredicateFailure (EraRule rule era)))
      (MempoolState era))
-> (TRC (EraRule rule era)
    -> Reader
         Globals
         (Either
            (NonEmpty (PredicateFailure (EraRule rule era)))
            (MempoolState era)))
-> TRC (EraRule rule era)
-> Either
     (NonEmpty (PredicateFailure (EraRule rule era))) (MempoolState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *) (rtype :: RuleType) (ep :: EventPolicy).
(STS s, RuleTypeRep rtype, m ~ BaseM s) =>
ApplySTSOpts ep
-> RuleContext rtype s
-> m (Either
        (NonEmpty (PredicateFailure s)) (EventReturnType ep s (State s)))
applySTSOptsEither @(EraRule rule era) ApplySTSOpts 'EventPolicyDiscard
opts
          (TRC (EraRule rule era)
 -> Either
      (NonEmpty (PredicateFailure (EraRule rule era)))
      (MempoolState era))
-> TRC (EraRule rule era)
-> Either
     (NonEmpty (PredicateFailure (EraRule rule era))) (MempoolState era)
forall a b. (a -> b) -> a -> b
$ (Environment (EraRule rule era), State (EraRule rule era),
 Signal (EraRule rule era))
-> TRC (EraRule rule era)
forall sts. (Environment sts, State sts, Signal sts) -> TRC sts
TRC (Environment (EraRule rule era)
LedgerEnv era
env, State (EraRule rule era)
MempoolState era
state, StAnnTx TopTx era
Signal (EraRule rule era)
stAnnTx)
   in (MempoolState era -> (MempoolState era, Validated (Tx TopTx era)))
-> Either
     (NonEmpty (PredicateFailure (EraRule rule era))) (MempoolState era)
-> Either
     (NonEmpty (PredicateFailure (EraRule rule era)))
     (MempoolState era, Validated (Tx TopTx era))
forall a b.
(a -> b)
-> Either (NonEmpty (PredicateFailure (EraRule rule era))) a
-> Either (NonEmpty (PredicateFailure (EraRule rule era))) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (,Tx TopTx era -> Validated (Tx TopTx era)
forall tx. tx -> Validated tx
Validated (StAnnTx TopTx era
stAnnTx StAnnTx TopTx era
-> Getting (Tx TopTx era) (StAnnTx TopTx era) (Tx TopTx era)
-> Tx TopTx era
forall s a. s -> Getting a s a -> a
^. Getting (Tx TopTx era) (StAnnTx TopTx era) (Tx TopTx era)
forall era (l :: TxLevel).
EraTx era =>
SimpleGetter (StAnnTx l era) (Tx l era)
forall (l :: TxLevel). SimpleGetter (StAnnTx l era) (Tx l era)
txStAnnTxG)) Either
  (NonEmpty (PredicateFailure (EraRule rule era))) (MempoolState era)
result

instance ApplyTx ShelleyEra where
  newtype ApplyTxError ShelleyEra = ShelleyApplyTxError (NonEmpty (ShelleyLedgerPredFailure ShelleyEra))
    deriving (ApplyTxError ShelleyEra -> ApplyTxError ShelleyEra -> Bool
(ApplyTxError ShelleyEra -> ApplyTxError ShelleyEra -> Bool)
-> (ApplyTxError ShelleyEra -> ApplyTxError ShelleyEra -> Bool)
-> Eq (ApplyTxError ShelleyEra)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ApplyTxError ShelleyEra -> ApplyTxError ShelleyEra -> Bool
== :: ApplyTxError ShelleyEra -> ApplyTxError ShelleyEra -> Bool
$c/= :: ApplyTxError ShelleyEra -> ApplyTxError ShelleyEra -> Bool
/= :: ApplyTxError ShelleyEra -> ApplyTxError ShelleyEra -> Bool
Eq, Int -> ApplyTxError ShelleyEra -> ShowS
[ApplyTxError ShelleyEra] -> ShowS
ApplyTxError ShelleyEra -> String
(Int -> ApplyTxError ShelleyEra -> ShowS)
-> (ApplyTxError ShelleyEra -> String)
-> ([ApplyTxError ShelleyEra] -> ShowS)
-> Show (ApplyTxError ShelleyEra)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ApplyTxError ShelleyEra -> ShowS
showsPrec :: Int -> ApplyTxError ShelleyEra -> ShowS
$cshow :: ApplyTxError ShelleyEra -> String
show :: ApplyTxError ShelleyEra -> String
$cshowList :: [ApplyTxError ShelleyEra] -> ShowS
showList :: [ApplyTxError ShelleyEra] -> ShowS
Show)
    deriving newtype (ApplyTxError ShelleyEra -> Encoding
(ApplyTxError ShelleyEra -> Encoding)
-> EncCBOR (ApplyTxError ShelleyEra)
forall a. (a -> Encoding) -> EncCBOR a
$cencCBOR :: ApplyTxError ShelleyEra -> Encoding
encCBOR :: ApplyTxError ShelleyEra -> Encoding
EncCBOR, Typeable (ApplyTxError ShelleyEra)
Typeable (ApplyTxError ShelleyEra) =>
(forall s. Decoder s (ApplyTxError ShelleyEra))
-> (forall s. Proxy (ApplyTxError ShelleyEra) -> Decoder s ())
-> (Proxy (ApplyTxError ShelleyEra) -> Text)
-> DecCBOR (ApplyTxError ShelleyEra)
Proxy (ApplyTxError ShelleyEra) -> Text
forall s. Decoder s (ApplyTxError ShelleyEra)
forall a.
Typeable a =>
(forall s. Decoder s a)
-> (forall s. Proxy a -> Decoder s ())
-> (Proxy a -> Text)
-> DecCBOR a
forall s. Proxy (ApplyTxError ShelleyEra) -> Decoder s ()
$cdecCBOR :: forall s. Decoder s (ApplyTxError ShelleyEra)
decCBOR :: forall s. Decoder s (ApplyTxError ShelleyEra)
$cdropCBOR :: forall s. Proxy (ApplyTxError ShelleyEra) -> Decoder s ()
dropCBOR :: forall s. Proxy (ApplyTxError ShelleyEra) -> Decoder s ()
$clabel :: Proxy (ApplyTxError ShelleyEra) -> Text
label :: Proxy (ApplyTxError ShelleyEra) -> Text
DecCBOR, NonEmpty (ApplyTxError ShelleyEra) -> ApplyTxError ShelleyEra
ApplyTxError ShelleyEra
-> ApplyTxError ShelleyEra -> ApplyTxError ShelleyEra
(ApplyTxError ShelleyEra
 -> ApplyTxError ShelleyEra -> ApplyTxError ShelleyEra)
-> (NonEmpty (ApplyTxError ShelleyEra) -> ApplyTxError ShelleyEra)
-> (forall b.
    Integral b =>
    b -> ApplyTxError ShelleyEra -> ApplyTxError ShelleyEra)
-> Semigroup (ApplyTxError ShelleyEra)
forall b.
Integral b =>
b -> ApplyTxError ShelleyEra -> ApplyTxError ShelleyEra
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
$c<> :: ApplyTxError ShelleyEra
-> ApplyTxError ShelleyEra -> ApplyTxError ShelleyEra
<> :: ApplyTxError ShelleyEra
-> ApplyTxError ShelleyEra -> ApplyTxError ShelleyEra
$csconcat :: NonEmpty (ApplyTxError ShelleyEra) -> ApplyTxError ShelleyEra
sconcat :: NonEmpty (ApplyTxError ShelleyEra) -> ApplyTxError ShelleyEra
$cstimes :: forall b.
Integral b =>
b -> ApplyTxError ShelleyEra -> ApplyTxError ShelleyEra
stimes :: forall b.
Integral b =>
b -> ApplyTxError ShelleyEra -> ApplyTxError ShelleyEra
Semigroup, (forall x.
 ApplyTxError ShelleyEra -> Rep (ApplyTxError ShelleyEra) x)
-> (forall x.
    Rep (ApplyTxError ShelleyEra) x -> ApplyTxError ShelleyEra)
-> Generic (ApplyTxError ShelleyEra)
forall x.
Rep (ApplyTxError ShelleyEra) x -> ApplyTxError ShelleyEra
forall x.
ApplyTxError ShelleyEra -> Rep (ApplyTxError ShelleyEra) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x.
ApplyTxError ShelleyEra -> Rep (ApplyTxError ShelleyEra) x
from :: forall x.
ApplyTxError ShelleyEra -> Rep (ApplyTxError ShelleyEra) x
$cto :: forall x.
Rep (ApplyTxError ShelleyEra) x -> ApplyTxError ShelleyEra
to :: forall x.
Rep (ApplyTxError ShelleyEra) x -> ApplyTxError ShelleyEra
Generic)

  mkStAnnTx :: EpochInfo (Either Text)
-> SystemStart
-> PParams ShelleyEra
-> UTxO ShelleyEra
-> Tx TopTx ShelleyEra
-> StAnnTx TopTx ShelleyEra
mkStAnnTx EpochInfo (Either Text)
_ SystemStart
_ PParams ShelleyEra
_ UTxO ShelleyEra
_ = Tx TopTx ShelleyEra -> Tx TopTx ShelleyEra
Tx TopTx ShelleyEra -> StAnnTx TopTx ShelleyEra
forall a. a -> a
id

  applyTxValidation :: ValidationPolicy
-> Globals
-> MempoolEnv ShelleyEra
-> MempoolState ShelleyEra
-> StAnnTx TopTx ShelleyEra
-> Either
     (ApplyTxError ShelleyEra)
     (MempoolState ShelleyEra, Validated (Tx TopTx ShelleyEra))
applyTxValidation ValidationPolicy
validationPolicy Globals
globals MempoolEnv ShelleyEra
env MempoolState ShelleyEra
state StAnnTx TopTx ShelleyEra
stAnnTx =
    (NonEmpty (ShelleyLedgerPredFailure ShelleyEra)
 -> ApplyTxError ShelleyEra)
-> Either
     (NonEmpty (ShelleyLedgerPredFailure ShelleyEra))
     (MempoolState ShelleyEra, Validated (Tx TopTx ShelleyEra))
-> Either
     (ApplyTxError ShelleyEra)
     (MempoolState ShelleyEra, Validated (Tx TopTx ShelleyEra))
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first NonEmpty (ShelleyLedgerPredFailure ShelleyEra)
-> ApplyTxError ShelleyEra
ShelleyApplyTxError (Either
   (NonEmpty (ShelleyLedgerPredFailure ShelleyEra))
   (MempoolState ShelleyEra, Validated (Tx TopTx ShelleyEra))
 -> Either
      (ApplyTxError ShelleyEra)
      (MempoolState ShelleyEra, Validated (Tx TopTx ShelleyEra)))
-> Either
     (NonEmpty (ShelleyLedgerPredFailure ShelleyEra))
     (MempoolState ShelleyEra, Validated (Tx TopTx ShelleyEra))
-> Either
     (ApplyTxError ShelleyEra)
     (MempoolState ShelleyEra, Validated (Tx TopTx ShelleyEra))
forall a b. (a -> b) -> a -> b
$
      forall (rule :: Symbol) era.
(EraTx era, STS (EraRule rule era),
 BaseM (EraRule rule era) ~ ShelleyBase,
 Environment (EraRule rule era) ~ LedgerEnv era,
 State (EraRule rule era) ~ MempoolState era,
 Signal (EraRule rule era) ~ StAnnTx TopTx era) =>
ValidationPolicy
-> Globals
-> LedgerEnv era
-> MempoolState era
-> StAnnTx TopTx era
-> Either
     (NonEmpty (PredicateFailure (EraRule rule era)))
     (MempoolState era, Validated (Tx TopTx era))
ruleApplyTxValidation @"LEDGER" ValidationPolicy
validationPolicy Globals
globals MempoolEnv ShelleyEra
env MempoolState ShelleyEra
state StAnnTx TopTx ShelleyEra
stAnnTx

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 ::
  EraGov era =>
  NewEpochState era ->
  SlotNo ->
  MempoolEnv era
mkMempoolEnv :: forall era.
EraGov era =>
NewEpochState era -> SlotNo -> MempoolEnv era
mkMempoolEnv
  LedgerState.NewEpochState
    { EpochState era
nesEs :: EpochState era
nesEs :: forall era. NewEpochState era -> EpochState era
LedgerState.nesEs
    }
  SlotNo
slot =
    Ledger.LedgerEnv
      { ledgerSlotNo :: SlotNo
Ledger.ledgerSlotNo = SlotNo
slot
      , ledgerEpochNo :: Maybe EpochNo
Ledger.ledgerEpochNo = Maybe EpochNo
forall a. Maybe a
Nothing
      , ledgerIx :: TxIx
Ledger.ledgerIx = TxIx
forall a. Bounded a => a
minBound
      , ledgerPp :: PParams era
Ledger.ledgerPp = EpochState era
nesEs EpochState era
-> Getting (PParams era) (EpochState era) (PParams era)
-> PParams era
forall s a. s -> Getting a s a -> a
^. Getting (PParams era) (EpochState era) (PParams era)
forall era. EraGov era => Lens' (EpochState era) (PParams era)
Lens' (EpochState era) (PParams era)
curPParamsEpochStateL
      , ledgerAccount :: ChainAccountState
Ledger.ledgerAccount = EpochState era -> ChainAccountState
forall era. EpochState era -> ChainAccountState
LedgerState.esChainAccountState 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 :: forall era. NewEpochState era -> MempoolState era
mkMempoolState LedgerState.NewEpochState {EpochState era
nesEs :: forall era. NewEpochState era -> EpochState era
nesEs :: EpochState era
LedgerState.nesEs} = EpochState era -> LedgerState era
forall era. EpochState era -> LedgerState era
LedgerState.esLState EpochState era
nesEs

-- | 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 :: forall (f :: * -> *) era.
Functor f =>
(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
        { LedgerState.nesEs =
            (LedgerState.nesEs st)
              { LedgerState.esLState = ls
              }
        }

-- | Validate a transaction against a mempool state using default STS options
-- 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 ::
  ApplyTx era =>
  Globals ->
  MempoolEnv era ->
  MempoolState era ->
  Tx TopTx era ->
  Either (ApplyTxError era) (MempoolState era, Validated (Tx TopTx era))
applyTx :: forall era.
ApplyTx era =>
Globals
-> MempoolEnv era
-> MempoolState era
-> Tx TopTx era
-> Either
     (ApplyTxError era) (MempoolState era, Validated (Tx TopTx era))
applyTx Globals
globals MempoolEnv era
env MempoolState era
state Tx TopTx era
tx =
  let stAnnTx :: StAnnTx TopTx era
stAnnTx =
        EpochInfo (Either Text)
-> SystemStart
-> PParams era
-> UTxO era
-> Tx TopTx era
-> StAnnTx TopTx era
forall era.
ApplyTx era =>
EpochInfo (Either Text)
-> SystemStart
-> PParams era
-> UTxO era
-> Tx TopTx era
-> StAnnTx TopTx era
mkStAnnTx
          (Globals -> EpochInfo (Either Text)
epochInfo Globals
globals)
          (Globals -> SystemStart
systemStart Globals
globals)
          (MempoolEnv era
env MempoolEnv era
-> Getting (PParams era) (MempoolEnv era) (PParams era)
-> PParams era
forall s a. s -> Getting a s a -> a
^. Getting (PParams era) (MempoolEnv era) (PParams era)
forall era (f :: * -> *).
Functor f =>
(PParams era -> f (PParams era))
-> LedgerEnv era -> f (LedgerEnv era)
ledgerPpL)
          (MempoolState era
state MempoolState era
-> Getting (UTxO era) (MempoolState era) (UTxO era) -> UTxO era
forall s a. s -> Getting a s a -> a
^. Getting (UTxO era) (MempoolState era) (UTxO era)
forall era. SimpleGetter (LedgerState era) (UTxO era)
forall (t :: * -> *) era.
CanGetUTxO t =>
SimpleGetter (t era) (UTxO era)
utxoG)
          Tx TopTx era
tx
   in ValidationPolicy
-> Globals
-> MempoolEnv era
-> MempoolState era
-> StAnnTx TopTx era
-> Either
     (ApplyTxError era) (MempoolState era, Validated (Tx TopTx era))
forall era.
ApplyTx era =>
ValidationPolicy
-> Globals
-> MempoolEnv era
-> MempoolState era
-> StAnnTx TopTx era
-> Either
     (ApplyTxError era) (MempoolState era, Validated (Tx TopTx era))
applyTxValidation ValidationPolicy
ValidateAll Globals
globals MempoolEnv era
env MempoolState era
state StAnnTx TopTx era
stAnnTx

-- | 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 does not fail due to any static check
--   (such as cryptographic checks).
reapplyTx ::
  ApplyTx era =>
  Globals ->
  MempoolEnv era ->
  MempoolState era ->
  -- TODO: change to `Validated (StAnnTx TopTx era)` once we return this from `applyTx`
  Validated (Tx TopTx era) ->
  Either (ApplyTxError era) (MempoolState era)
reapplyTx :: forall era.
ApplyTx era =>
Globals
-> MempoolEnv era
-> MempoolState era
-> Validated (Tx TopTx era)
-> Either (ApplyTxError era) (MempoolState era)
reapplyTx Globals
globals MempoolEnv era
env MempoolState era
state (Validated Tx TopTx era
tx) =
  -- TODO: replace `stAnnTx` creation with the argument,
  -- once the signature is changed to take `Validated (StAnnTx TopTx era)`
  let stAnnTx :: StAnnTx TopTx era
stAnnTx =
        EpochInfo (Either Text)
-> SystemStart
-> PParams era
-> UTxO era
-> Tx TopTx era
-> StAnnTx TopTx era
forall era.
ApplyTx era =>
EpochInfo (Either Text)
-> SystemStart
-> PParams era
-> UTxO era
-> Tx TopTx era
-> StAnnTx TopTx era
mkStAnnTx
          (Globals -> EpochInfo (Either Text)
epochInfo Globals
globals)
          (Globals -> SystemStart
systemStart Globals
globals)
          (MempoolEnv era
env MempoolEnv era
-> Getting (PParams era) (MempoolEnv era) (PParams era)
-> PParams era
forall s a. s -> Getting a s a -> a
^. Getting (PParams era) (MempoolEnv era) (PParams era)
forall era (f :: * -> *).
Functor f =>
(PParams era -> f (PParams era))
-> LedgerEnv era -> f (LedgerEnv era)
ledgerPpL)
          (MempoolState era
state MempoolState era
-> Getting (UTxO era) (MempoolState era) (UTxO era) -> UTxO era
forall s a. s -> Getting a s a -> a
^. Getting (UTxO era) (MempoolState era) (UTxO era)
forall era. SimpleGetter (LedgerState era) (UTxO era)
forall (t :: * -> *) era.
CanGetUTxO t =>
SimpleGetter (t era) (UTxO era)
utxoG)
          Tx TopTx era
tx
   in (MempoolState era, Validated (Tx TopTx era)) -> MempoolState era
forall a b. (a, b) -> a
fst ((MempoolState era, Validated (Tx TopTx era)) -> MempoolState era)
-> Either
     (ApplyTxError era) (MempoolState era, Validated (Tx TopTx era))
-> Either (ApplyTxError era) (MempoolState era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ValidationPolicy
-> Globals
-> MempoolEnv era
-> MempoolState era
-> StAnnTx TopTx era
-> Either
     (ApplyTxError era) (MempoolState era, Validated (Tx TopTx era))
forall era.
ApplyTx era =>
ValidationPolicy
-> Globals
-> MempoolEnv era
-> MempoolState era
-> StAnnTx TopTx era
-> Either
     (ApplyTxError era) (MempoolState era, Validated (Tx TopTx era))
applyTxValidation ((Context -> Bool) -> ValidationPolicy
ValidateSuchThat (String -> Context -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
notElem String
lblStatic)) Globals
globals MempoolEnv era
env MempoolState era
state StAnnTx TopTx era
stAnnTx