{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# 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,
  applyTxWithFullValidation,
  reapplyValidatedTx,
  reapplyTx,
  ApplyTx (..),
  ApplyTxError (..),
  Validated,
  ValidatedTx,
  getValidatedTxStAnnTx,
  getValidatedTxProtocolVersion,
  getValidatedTxSlotNo,
  extractTx,
  extractValidatedTx,
  coerceValidated,
  translateValidated,
  ruleApplyTxValidation,
  defaultApplyTxWithValidation,
  defaultReapplyValidatedTx,

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

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

import Cardano.Ledger.BaseTypes
import Cardano.Ledger.Binary (DecCBOR, EncCBOR)
import Cardano.Ledger.Core
import Cardano.Ledger.Rules.ValidationMode (lblStatic)
import Cardano.Ledger.Shelley.Era (ShelleyEra)
import Cardano.Ledger.Shelley.LedgerState
import Cardano.Ledger.Shelley.Rules.Ledger (
  LedgerEnv (..),
  ShelleyLedgerPredFailure,
  ledgerPpL,
  ledgerSlotNoL,
 )
import Cardano.Ledger.State
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 transaction that has been validated against some chain state.
data ValidatedTx era = ValidatedTx
  { forall era. ValidatedTx era -> StAnnTx TopTx era
vtStAnnTx :: !(StAnnTx TopTx era)
  -- ^ The transaction paired with the state-derived annotation produced during validation
  , forall era. ValidatedTx era -> ProtVer
vtProtocolVersion :: !ProtVer
  -- ^ Protocol version under which the validation took place
  , forall era. ValidatedTx era -> SlotNo
vtSlotNo :: !SlotNo
  -- ^ Slot number under which the validation took place
  }
  deriving ((forall x. ValidatedTx era -> Rep (ValidatedTx era) x)
-> (forall x. Rep (ValidatedTx era) x -> ValidatedTx era)
-> Generic (ValidatedTx era)
forall x. Rep (ValidatedTx era) x -> ValidatedTx era
forall x. ValidatedTx era -> Rep (ValidatedTx era) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall era x. Rep (ValidatedTx era) x -> ValidatedTx era
forall era x. ValidatedTx era -> Rep (ValidatedTx era) x
$cfrom :: forall era x. ValidatedTx era -> Rep (ValidatedTx era) x
from :: forall x. ValidatedTx era -> Rep (ValidatedTx era) x
$cto :: forall era x. Rep (ValidatedTx era) x -> ValidatedTx era
to :: forall x. Rep (ValidatedTx era) x -> ValidatedTx era
Generic)

deriving instance Eq (StAnnTx TopTx era) => Eq (ValidatedTx era)

deriving instance Show (StAnnTx TopTx era) => Show (ValidatedTx era)

instance NFData (StAnnTx TopTx era) => NFData (ValidatedTx era)

instance NoThunks (StAnnTx TopTx era) => NoThunks (ValidatedTx era)

getValidatedTxStAnnTx :: ValidatedTx era -> StAnnTx TopTx era
getValidatedTxStAnnTx :: forall era. ValidatedTx era -> StAnnTx TopTx era
getValidatedTxStAnnTx = ValidatedTx era -> StAnnTx TopTx era
forall era. ValidatedTx era -> StAnnTx TopTx era
vtStAnnTx

getValidatedTxProtocolVersion :: ValidatedTx era -> ProtVer
getValidatedTxProtocolVersion :: forall era. ValidatedTx era -> ProtVer
getValidatedTxProtocolVersion = ValidatedTx era -> ProtVer
forall era. ValidatedTx era -> ProtVer
vtProtocolVersion

getValidatedTxSlotNo :: ValidatedTx era -> SlotNo
getValidatedTxSlotNo :: forall era. ValidatedTx era -> SlotNo
getValidatedTxSlotNo = ValidatedTx era -> SlotNo
forall era. ValidatedTx era -> SlotNo
vtSlotNo

extractValidatedTx :: EraTx era => ValidatedTx era -> Tx TopTx era
extractValidatedTx :: forall era. EraTx era => ValidatedTx era -> Tx TopTx era
extractValidatedTx ValidatedTx era
validatedTx = ValidatedTx era -> StAnnTx TopTx era
forall era. ValidatedTx era -> StAnnTx TopTx era
getValidatedTxStAnnTx ValidatedTx era
validatedTx 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

-- | 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)
{-# DEPRECATED Validated "Use 'ValidatedTx' instead." #-}

-- | Extract the underlying unvalidated Tx.
extractTx :: Validated tx -> tx
extractTx :: forall tx. Validated tx -> tx
extractTx (Validated tx
tx) = tx
tx
{-# DEPRECATED extractTx "Use 'extractValidatedTx'" #-}

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
{-# DEPRECATED coerceValidated "'Validated' is deprecated; switch to 'ValidatedTx'." #-}

-- 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
{-# DEPRECATED unsafeMakeValidated "Use 'unsafeMakeValidatedTx' instead." #-}

-- | Build a 'ValidatedTx' without running the LEDGER rule - should only be used for testing.
unsafeMakeValidatedTx ::
  ApplyTx era =>
  Globals ->
  MempoolEnv era ->
  MempoolState era ->
  Tx TopTx era ->
  ValidatedTx era
unsafeMakeValidatedTx :: forall era.
ApplyTx era =>
Globals
-> MempoolEnv era
-> MempoolState era
-> Tx TopTx era
-> ValidatedTx era
unsafeMakeValidatedTx Globals
globals MempoolEnv era
env MempoolState era
state Tx TopTx era
tx =
  ValidatedTx
    { vtStAnnTx :: StAnnTx TopTx era
vtStAnnTx =
        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
    , vtProtocolVersion :: ProtVer
vtProtocolVersion = MempoolEnv era
env MempoolEnv era
-> Getting ProtVer (MempoolEnv era) ProtVer -> ProtVer
forall s a. s -> Getting a s a -> a
^. (PParams era -> Const ProtVer (PParams era))
-> MempoolEnv era -> Const ProtVer (MempoolEnv era)
forall era (f :: * -> *).
Functor f =>
(PParams era -> f (PParams era))
-> LedgerEnv era -> f (LedgerEnv era)
ledgerPpL ((PParams era -> Const ProtVer (PParams era))
 -> MempoolEnv era -> Const ProtVer (MempoolEnv era))
-> ((ProtVer -> Const ProtVer ProtVer)
    -> PParams era -> Const ProtVer (PParams era))
-> Getting ProtVer (MempoolEnv era) ProtVer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ProtVer -> Const ProtVer ProtVer)
-> PParams era -> Const ProtVer (PParams era)
forall era. EraPParams era => Lens' (PParams era) ProtVer
Lens' (PParams era) ProtVer
ppProtocolVersionL
    , vtSlotNo :: SlotNo
vtSlotNo = MempoolEnv era
env MempoolEnv era -> Getting SlotNo (MempoolEnv era) SlotNo -> SlotNo
forall s a. s -> Getting a s a -> a
^. Getting SlotNo (MempoolEnv era) SlotNo
forall era (f :: * -> *).
Functor f =>
(SlotNo -> f SlotNo) -> LedgerEnv era -> f (LedgerEnv era)
ledgerSlotNoL
    }

-- | 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
{-# DEPRECATED
  translateValidated
  "Translation of `Validated` does not make sense. It must be fully re-validated in a new era"
  #-}

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 transaction against a mempool state for given STS options.
  --
  -- /Warning/ - This function is only safe when `ValidateAll` policy is supplied,
  -- otherwise invariant for `ValidatedTx` could be violated.
  -- It will always be safer to use `applyTxWithFullValidation` instead.
  internalApplyTxWithValidation ::
    ValidationPolicy ->
    Globals ->
    MempoolEnv era ->
    MempoolState era ->
    Tx TopTx era ->
    Either (ApplyTxError era) (MempoolState era, ValidatedTx era)

  -- | Reapply a previously validated transaction.
  --
  -- /Warning/ - Should not be used directly. `reapplyValidatedTx` should be used instead.
  internalReapplyValidatedTx ::
    Globals ->
    MempoolEnv era ->
    MempoolState era ->
    ValidatedTx era ->
    Either (ApplyTxError era) (MempoolState era)

  -- | Validate a transaction against a mempool state for given STS
  -- options, and return the new mempool state, a "validated" 'TxInBlock
  applyTxValidation ::
    ValidationPolicy ->
    Globals ->
    MempoolEnv era ->
    MempoolState era ->
    StAnnTx TopTx era ->
    Either (ApplyTxError era) (MempoolState era, Validated (Tx TopTx era))
  applyTxValidation ValidationPolicy
policy Globals
globals MempoolEnv era
env MempoolState era
state StAnnTx TopTx era
stAnnTx =
    (ValidatedTx era -> Validated (Tx TopTx era))
-> (MempoolState era, ValidatedTx era)
-> (MempoolState era, Validated (Tx TopTx era))
forall a b.
(a -> b) -> (MempoolState era, a) -> (MempoolState era, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\ValidatedTx era
vtx -> Tx TopTx era -> Validated (Tx TopTx era)
forall tx. tx -> Validated tx
Validated (ValidatedTx era -> StAnnTx TopTx era
forall era. ValidatedTx era -> StAnnTx TopTx era
vtStAnnTx ValidatedTx era
vtx 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))
      ((MempoolState era, ValidatedTx era)
 -> (MempoolState era, Validated (Tx TopTx era)))
-> Either (ApplyTxError era) (MempoolState era, ValidatedTx era)
-> Either
     (ApplyTxError era) (MempoolState era, Validated (Tx TopTx era))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ValidationPolicy
-> Globals
-> MempoolEnv era
-> MempoolState era
-> Tx TopTx era
-> Either (ApplyTxError era) (MempoolState era, ValidatedTx era)
forall era.
ApplyTx era =>
ValidationPolicy
-> Globals
-> MempoolEnv era
-> MempoolState era
-> Tx TopTx era
-> Either (ApplyTxError era) (MempoolState era, ValidatedTx era)
internalApplyTxWithValidation ValidationPolicy
policy Globals
globals MempoolEnv era
env MempoolState era
state (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)

{-# DEPRECATED applyTxValidation "Use 'internalApplyTxWithValidation' instead." #-}

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, ValidatedTx 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, ValidatedTx 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)
      validatedTx :: ValidatedTx era
validatedTx =
        ValidatedTx
          { vtStAnnTx :: StAnnTx TopTx era
vtStAnnTx = StAnnTx TopTx era
stAnnTx
          , vtProtocolVersion :: ProtVer
vtProtocolVersion = LedgerEnv era
env LedgerEnv era -> Getting ProtVer (LedgerEnv era) ProtVer -> ProtVer
forall s a. s -> Getting a s a -> a
^. (PParams era -> Const ProtVer (PParams era))
-> LedgerEnv era -> Const ProtVer (LedgerEnv era)
forall era (f :: * -> *).
Functor f =>
(PParams era -> f (PParams era))
-> LedgerEnv era -> f (LedgerEnv era)
ledgerPpL ((PParams era -> Const ProtVer (PParams era))
 -> LedgerEnv era -> Const ProtVer (LedgerEnv era))
-> ((ProtVer -> Const ProtVer ProtVer)
    -> PParams era -> Const ProtVer (PParams era))
-> Getting ProtVer (LedgerEnv era) ProtVer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ProtVer -> Const ProtVer ProtVer)
-> PParams era -> Const ProtVer (PParams era)
forall era. EraPParams era => Lens' (PParams era) ProtVer
Lens' (PParams era) ProtVer
ppProtocolVersionL
          , vtSlotNo :: SlotNo
vtSlotNo = LedgerEnv era
env LedgerEnv era -> Getting SlotNo (LedgerEnv era) SlotNo -> SlotNo
forall s a. s -> Getting a s a -> a
^. Getting SlotNo (LedgerEnv era) SlotNo
forall era (f :: * -> *).
Functor f =>
(SlotNo -> f SlotNo) -> LedgerEnv era -> f (LedgerEnv era)
ledgerSlotNoL
          }
   in (MempoolState era -> (MempoolState era, ValidatedTx era))
-> Either
     (NonEmpty (PredicateFailure (EraRule rule era))) (MempoolState era)
-> Either
     (NonEmpty (PredicateFailure (EraRule rule era)))
     (MempoolState era, ValidatedTx 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 (,ValidatedTx era
validatedTx) Either
  (NonEmpty (PredicateFailure (EraRule rule era))) (MempoolState era)
result

-- | A default implementation for 'internalApplyTxWithValidation', parameterised by the
-- STS rule to run and a wrapper that lifts predicate failures into the era's
-- 'ApplyTxError'.
defaultApplyTxWithValidation ::
  forall rule era.
  ( ApplyTx 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
  ) =>
  (NonEmpty (PredicateFailure (EraRule rule era)) -> ApplyTxError era) ->
  ValidationPolicy ->
  Globals ->
  MempoolEnv era ->
  MempoolState era ->
  Tx TopTx era ->
  Either (ApplyTxError era) (MempoolState era, ValidatedTx era)
defaultApplyTxWithValidation :: forall (rule :: Symbol) era.
(ApplyTx 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) =>
(NonEmpty (PredicateFailure (EraRule rule era))
 -> ApplyTxError era)
-> ValidationPolicy
-> Globals
-> LedgerEnv era
-> MempoolState era
-> Tx TopTx era
-> Either (ApplyTxError era) (MempoolState era, ValidatedTx era)
defaultApplyTxWithValidation NonEmpty (PredicateFailure (EraRule rule era)) -> ApplyTxError era
wrap ValidationPolicy
validationPolicy Globals
globals LedgerEnv 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)
          (LedgerEnv era
env LedgerEnv era
-> Getting (PParams era) (LedgerEnv era) (PParams era)
-> PParams era
forall s a. s -> Getting a s a -> a
^. Getting (PParams era) (LedgerEnv 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 (NonEmpty (PredicateFailure (EraRule rule era))
 -> ApplyTxError era)
-> Either
     (NonEmpty (PredicateFailure (EraRule rule era)))
     (MempoolState era, ValidatedTx era)
-> Either (ApplyTxError era) (MempoolState era, ValidatedTx era)
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 (PredicateFailure (EraRule rule era)) -> ApplyTxError era
wrap (Either
   (NonEmpty (PredicateFailure (EraRule rule era)))
   (MempoolState era, ValidatedTx era)
 -> Either (ApplyTxError era) (MempoolState era, ValidatedTx era))
-> Either
     (NonEmpty (PredicateFailure (EraRule rule era)))
     (MempoolState era, ValidatedTx era)
-> Either (ApplyTxError era) (MempoolState era, ValidatedTx era)
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, ValidatedTx era)
ruleApplyTxValidation @rule ValidationPolicy
validationPolicy Globals
globals LedgerEnv era
env MempoolState era
state StAnnTx TopTx era
stAnnTx

-- | A default implementation for 'internalReapplyValidatedTx', parameterised by the
-- STS rule to run and a wrapper that lifts predicate failures into the era's
-- 'ApplyTxError'.
defaultReapplyValidatedTx ::
  forall rule era.
  ( ApplyTx 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
  ) =>
  (NonEmpty (PredicateFailure (EraRule rule era)) -> ApplyTxError era) ->
  Globals ->
  MempoolEnv era ->
  MempoolState era ->
  ValidatedTx era ->
  Either (ApplyTxError era) (MempoolState era)
defaultReapplyValidatedTx :: forall (rule :: Symbol) era.
(ApplyTx 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) =>
(NonEmpty (PredicateFailure (EraRule rule era))
 -> ApplyTxError era)
-> Globals
-> LedgerEnv era
-> MempoolState era
-> ValidatedTx era
-> Either (ApplyTxError era) (MempoolState era)
defaultReapplyValidatedTx NonEmpty (PredicateFailure (EraRule rule era)) -> ApplyTxError era
wrap Globals
globals LedgerEnv era
env MempoolState era
state ValidatedTx era
vtx =
  (MempoolState era, ValidatedTx era) -> MempoolState era
forall a b. (a, b) -> a
fst
    ((MempoolState era, ValidatedTx era) -> MempoolState era)
-> Either (ApplyTxError era) (MempoolState era, ValidatedTx era)
-> Either (ApplyTxError era) (MempoolState era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (NonEmpty (PredicateFailure (EraRule rule era))
 -> ApplyTxError era)
-> Either
     (NonEmpty (PredicateFailure (EraRule rule era)))
     (MempoolState era, ValidatedTx era)
-> Either (ApplyTxError era) (MempoolState era, ValidatedTx era)
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 (PredicateFailure (EraRule rule era)) -> ApplyTxError era
wrap
      ( 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, ValidatedTx era)
ruleApplyTxValidation @rule
          ((Context -> Bool) -> ValidationPolicy
ValidateSuchThat (String -> Context -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
notElem String
lblStatic))
          Globals
globals
          LedgerEnv era
env
          MempoolState era
state
          (ValidatedTx era -> StAnnTx TopTx era
forall era. ValidatedTx era -> StAnnTx TopTx era
vtStAnnTx ValidatedTx era
vtx)
      )

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

  internalApplyTxWithValidation :: ValidationPolicy
-> Globals
-> MempoolEnv ShelleyEra
-> MempoolState ShelleyEra
-> Tx TopTx ShelleyEra
-> Either
     (ApplyTxError ShelleyEra)
     (MempoolState ShelleyEra, ValidatedTx ShelleyEra)
internalApplyTxWithValidation ValidationPolicy
validationPolicy Globals
globals MempoolEnv ShelleyEra
env MempoolState ShelleyEra
state Tx TopTx ShelleyEra
tx =
    let stAnnTx :: StAnnTx TopTx ShelleyEra
stAnnTx =
          EpochInfo (Either Text)
-> SystemStart
-> PParams ShelleyEra
-> UTxO ShelleyEra
-> Tx TopTx ShelleyEra
-> StAnnTx TopTx ShelleyEra
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 ShelleyEra
env MempoolEnv ShelleyEra
-> Getting
     (PParams ShelleyEra) (MempoolEnv ShelleyEra) (PParams ShelleyEra)
-> PParams ShelleyEra
forall s a. s -> Getting a s a -> a
^. Getting
  (PParams ShelleyEra) (MempoolEnv ShelleyEra) (PParams ShelleyEra)
forall era (f :: * -> *).
Functor f =>
(PParams era -> f (PParams era))
-> LedgerEnv era -> f (LedgerEnv era)
ledgerPpL)
            (MempoolState ShelleyEra
state MempoolState ShelleyEra
-> Getting
     (UTxO ShelleyEra) (MempoolState ShelleyEra) (UTxO ShelleyEra)
-> UTxO ShelleyEra
forall s a. s -> Getting a s a -> a
^. Getting
  (UTxO ShelleyEra) (MempoolState ShelleyEra) (UTxO ShelleyEra)
forall era. SimpleGetter (LedgerState era) (UTxO era)
forall (t :: * -> *) era.
CanGetUTxO t =>
SimpleGetter (t era) (UTxO era)
utxoG)
            Tx TopTx ShelleyEra
tx
     in (NonEmpty (ShelleyLedgerPredFailure ShelleyEra)
 -> ApplyTxError ShelleyEra)
-> Either
     (NonEmpty (ShelleyLedgerPredFailure ShelleyEra))
     (MempoolState ShelleyEra, ValidatedTx ShelleyEra)
-> Either
     (ApplyTxError ShelleyEra)
     (MempoolState ShelleyEra, ValidatedTx 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, ValidatedTx ShelleyEra)
 -> Either
      (ApplyTxError ShelleyEra)
      (MempoolState ShelleyEra, ValidatedTx ShelleyEra))
-> Either
     (NonEmpty (ShelleyLedgerPredFailure ShelleyEra))
     (MempoolState ShelleyEra, ValidatedTx ShelleyEra)
-> Either
     (ApplyTxError ShelleyEra)
     (MempoolState ShelleyEra, ValidatedTx 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, ValidatedTx era)
ruleApplyTxValidation @"LEDGER" ValidationPolicy
validationPolicy Globals
globals MempoolEnv ShelleyEra
env MempoolState ShelleyEra
state StAnnTx TopTx ShelleyEra
stAnnTx

  internalReapplyValidatedTx :: Globals
-> MempoolEnv ShelleyEra
-> MempoolState ShelleyEra
-> ValidatedTx ShelleyEra
-> Either (ApplyTxError ShelleyEra) (MempoolState ShelleyEra)
internalReapplyValidatedTx = forall (rule :: Symbol) era.
(ApplyTx 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) =>
(NonEmpty (PredicateFailure (EraRule rule era))
 -> ApplyTxError era)
-> Globals
-> LedgerEnv era
-> MempoolState era
-> ValidatedTx era
-> Either (ApplyTxError era) (MempoolState era)
defaultReapplyValidatedTx @"LEDGER" NonEmpty (PredicateFailure (EraRule "LEDGER" ShelleyEra))
-> ApplyTxError ShelleyEra
NonEmpty (ShelleyLedgerPredFailure ShelleyEra)
-> ApplyTxError ShelleyEra
ShelleyApplyTxError

type MempoolEnv era = LedgerEnv era

type MempoolState era = 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
  NewEpochState {EpochState era
nesEs :: EpochState era
nesEs :: forall era. NewEpochState era -> EpochState era
nesEs}
  SlotNo
slot =
    LedgerEnv
      { ledgerSlotNo :: SlotNo
ledgerSlotNo = SlotNo
slot
      , ledgerEpochNo :: Maybe EpochNo
ledgerEpochNo = Maybe EpochNo
forall a. Maybe a
Nothing
      , ledgerIx :: TxIx
ledgerIx = TxIx
forall a. Bounded a => a
minBound
      , ledgerPp :: PParams era
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
ledgerAccount = EpochState era -> ChainAccountState
forall era. EpochState era -> ChainAccountState
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 NewEpochState {EpochState era
nesEs :: forall era. NewEpochState era -> EpochState era
nesEs :: EpochState era
nesEs} = EpochState era -> LedgerState era
forall era. EpochState era -> LedgerState era
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
        { nesEs =
            (nesEs st)
              { esLState = ls
              }
        }

-- | Validate a transaction against a mempool state and return the new
-- mempool state together with a 'ValidatedTx'
applyTxWithFullValidation ::
  ApplyTx era =>
  Globals ->
  MempoolEnv era ->
  MempoolState era ->
  Tx TopTx era ->
  Either (ApplyTxError era) (MempoolState era, ValidatedTx era)
applyTxWithFullValidation :: forall era.
ApplyTx era =>
Globals
-> MempoolEnv era
-> MempoolState era
-> Tx TopTx era
-> Either (ApplyTxError era) (MempoolState era, ValidatedTx era)
applyTxWithFullValidation = ValidationPolicy
-> Globals
-> MempoolEnv era
-> MempoolState era
-> Tx TopTx era
-> Either (ApplyTxError era) (MempoolState era, ValidatedTx era)
forall era.
ApplyTx era =>
ValidationPolicy
-> Globals
-> MempoolEnv era
-> MempoolState era
-> Tx TopTx era
-> Either (ApplyTxError era) (MempoolState era, ValidatedTx era)
internalApplyTxWithValidation ValidationPolicy
ValidateAll

-- | Reapply a previously validated transaction, skipping static checks.
-- Use the state-derived annotations in `StAnnTx` if the current protocol version
-- matches the one in `ValidatedTx`, otherwise reconstruct `StAnnTx.
-- If major protocol version has changed from when `ValidatedTx`
-- was constructed, then full validation is triggered again.
reapplyValidatedTx ::
  (ApplyTx era, EraGov era) =>
  Globals ->
  MempoolEnv era ->
  MempoolState era ->
  ValidatedTx era ->
  Either (ApplyTxError era) (MempoolState era)
reapplyValidatedTx :: forall era.
(ApplyTx era, EraGov era) =>
Globals
-> MempoolEnv era
-> MempoolState era
-> ValidatedTx era
-> Either (ApplyTxError era) (MempoolState era)
reapplyValidatedTx Globals
globals MempoolEnv era
env MempoolState era
ledgerState ValidatedTx era
vtx
  | ProtVer -> Version
pvMajor (ValidatedTx era -> ProtVer
forall era. ValidatedTx era -> ProtVer
vtProtocolVersion ValidatedTx era
vtx) Version -> Version -> Bool
forall a. Eq a => a -> a -> Bool
== ProtVer -> Version
pvMajor ProtVer
currentPv =
      Globals
-> MempoolEnv era
-> MempoolState era
-> ValidatedTx era
-> Either (ApplyTxError era) (MempoolState era)
forall era.
ApplyTx era =>
Globals
-> MempoolEnv era
-> MempoolState era
-> ValidatedTx era
-> Either (ApplyTxError era) (MempoolState era)
internalReapplyValidatedTx Globals
globals MempoolEnv era
env MempoolState era
ledgerState ValidatedTx era
vtx
  | Bool
otherwise =
      (MempoolState era, ValidatedTx era) -> MempoolState era
forall a b. (a, b) -> a
fst
        ((MempoolState era, ValidatedTx era) -> MempoolState era)
-> Either (ApplyTxError era) (MempoolState era, ValidatedTx era)
-> Either (ApplyTxError era) (MempoolState era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ValidationPolicy
-> Globals
-> MempoolEnv era
-> MempoolState era
-> Tx TopTx era
-> Either (ApplyTxError era) (MempoolState era, ValidatedTx era)
forall era.
ApplyTx era =>
ValidationPolicy
-> Globals
-> MempoolEnv era
-> MempoolState era
-> Tx TopTx era
-> Either (ApplyTxError era) (MempoolState era, ValidatedTx era)
internalApplyTxWithValidation
          ValidationPolicy
ValidateAll
          Globals
globals
          MempoolEnv era
env
          MempoolState era
ledgerState
          (ValidatedTx era -> StAnnTx TopTx era
forall era. ValidatedTx era -> StAnnTx TopTx era
vtStAnnTx ValidatedTx era
vtx 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)
  where
    currentPv :: ProtVer
currentPv = MempoolState era
ledgerState MempoolState era
-> Getting ProtVer (MempoolState era) ProtVer -> ProtVer
forall s a. s -> Getting a s a -> a
^. (UTxOState era -> Const ProtVer (UTxOState era))
-> MempoolState era -> Const ProtVer (MempoolState era)
forall era (f :: * -> *).
Functor f =>
(UTxOState era -> f (UTxOState era))
-> LedgerState era -> f (LedgerState era)
lsUTxOStateL ((UTxOState era -> Const ProtVer (UTxOState era))
 -> MempoolState era -> Const ProtVer (MempoolState era))
-> ((ProtVer -> Const ProtVer ProtVer)
    -> UTxOState era -> Const ProtVer (UTxOState era))
-> Getting ProtVer (MempoolState era) ProtVer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GovState era -> Const ProtVer (GovState era))
-> UTxOState era -> Const ProtVer (UTxOState era)
forall era (f :: * -> *).
Functor f =>
(GovState era -> f (GovState era))
-> UTxOState era -> f (UTxOState era)
utxosGovStateL ((GovState era -> Const ProtVer (GovState era))
 -> UTxOState era -> Const ProtVer (UTxOState era))
-> ((ProtVer -> Const ProtVer ProtVer)
    -> GovState era -> Const ProtVer (GovState era))
-> (ProtVer -> Const ProtVer ProtVer)
-> UTxOState era
-> Const ProtVer (UTxOState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PParams era -> Const ProtVer (PParams era))
-> GovState era -> Const ProtVer (GovState era)
forall era. EraGov era => Lens' (GovState era) (PParams era)
Lens' (GovState era) (PParams era)
curPParamsGovStateL ((PParams era -> Const ProtVer (PParams era))
 -> GovState era -> Const ProtVer (GovState era))
-> ((ProtVer -> Const ProtVer ProtVer)
    -> PParams era -> Const ProtVer (PParams era))
-> (ProtVer -> Const ProtVer ProtVer)
-> GovState era
-> Const ProtVer (GovState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ProtVer -> Const ProtVer ProtVer)
-> PParams era -> Const ProtVer (PParams era)
forall era. EraPParams era => Lens' (PParams era) ProtVer
Lens' (PParams era) ProtVer
ppProtocolVersionL

-- | 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 = do
  (mempoolState, vtx) <- ValidationPolicy
-> Globals
-> MempoolEnv era
-> MempoolState era
-> Tx TopTx era
-> Either (ApplyTxError era) (MempoolState era, ValidatedTx era)
forall era.
ApplyTx era =>
ValidationPolicy
-> Globals
-> MempoolEnv era
-> MempoolState era
-> Tx TopTx era
-> Either (ApplyTxError era) (MempoolState era, ValidatedTx era)
internalApplyTxWithValidation ValidationPolicy
ValidateAll Globals
globals MempoolEnv era
env MempoolState era
state Tx TopTx era
tx
  pure (mempoolState, Validated (vtStAnnTx vtx ^. txStAnnTxG))
{-# DEPRECATED applyTx "Use 'applyTxWithFullValidation' instead." #-}

-- | 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 ->
  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) =
  (MempoolState era, ValidatedTx era) -> MempoolState era
forall a b. (a, b) -> a
fst ((MempoolState era, ValidatedTx era) -> MempoolState era)
-> Either (ApplyTxError era) (MempoolState era, ValidatedTx era)
-> Either (ApplyTxError era) (MempoolState era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ValidationPolicy
-> Globals
-> MempoolEnv era
-> MempoolState era
-> Tx TopTx era
-> Either (ApplyTxError era) (MempoolState era, ValidatedTx era)
forall era.
ApplyTx era =>
ValidationPolicy
-> Globals
-> MempoolEnv era
-> MempoolState era
-> Tx TopTx era
-> Either (ApplyTxError era) (MempoolState era, ValidatedTx era)
internalApplyTxWithValidation ((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 Tx TopTx era
tx
{-# DEPRECATED reapplyTx "Use 'reapplyValidatedTx' instead." #-}