{-# 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 #-}
module Cardano.Ledger.Shelley.API.Mempool (
applyTx,
ApplyTx (..),
ApplyTxError (..),
Validated,
extractTx,
coerceValidated,
translateValidated,
MempoolEnv,
MempoolState,
applyTxsTransition,
unsafeMakeValidated,
applyTxs,
mkMempoolEnv,
mkMempoolState,
overNewEpochState,
)
where
import Cardano.Ledger.BaseTypes (Globals, ShelleyBase)
import Cardano.Ledger.Binary (
DecCBOR (..),
EncCBOR (..),
FromCBOR (..),
ToCBOR (..),
encodeFoldableAsIndefLenList,
ifEncodingVersionAtLeast,
natVersion,
)
import Cardano.Ledger.Core
import Cardano.Ledger.Keys
import Cardano.Ledger.Shelley (ShelleyEra)
import Cardano.Ledger.Shelley.Core (EraGov)
import Cardano.Ledger.Shelley.LedgerState (NewEpochState, curPParamsEpochStateL)
import qualified Cardano.Ledger.Shelley.LedgerState as LedgerState
import Cardano.Ledger.Shelley.Rules ()
import Cardano.Ledger.Shelley.Rules.Ledger (LedgerEnv)
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 (foldM)
import Control.Monad.Except (Except, MonadError, liftEither)
import Control.Monad.Trans.Reader (runReader)
import Control.State.Transition.Extended
import Data.Coerce (Coercible, coerce)
import Data.Functor ((<&>))
import Data.List.NonEmpty (NonEmpty)
import Data.Sequence (Seq)
import Data.Typeable (Typeable)
import Lens.Micro ((^.))
import NoThunks.Class (NoThunks)
newtype Validated tx = Validated tx
deriving (Validated tx -> Validated tx -> Bool
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
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
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 -> ()
forall tx. NFData tx => Validated tx -> ()
forall a. (a -> ()) -> NFData a
rnf :: Validated tx -> ()
$crnf :: forall tx. NFData tx => Validated tx -> ()
NFData)
extractTx :: Validated tx -> tx
(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) = forall tx. tx -> Validated tx
Validated forall a b. (a -> b) -> a -> b
$ coerce :: forall a b. Coercible a b => a -> b
coerce a
a
unsafeMakeValidated :: tx -> Validated tx
unsafeMakeValidated :: forall tx. tx -> Validated tx
unsafeMakeValidated = forall tx. tx -> Validated tx
Validated
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) = forall tx. tx -> Validated tx
Validated 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)
, STS (EraRule "LEDGER" era)
, BaseM (EraRule "LEDGER" era) ~ ShelleyBase
, Environment (EraRule "LEDGER" era) ~ LedgerEnv era
, State (EraRule "LEDGER" era) ~ MempoolState era
, Signal (EraRule "LEDGER" era) ~ Tx era
) =>
ApplyTx era
where
applyTxOpts ::
forall ep m.
(MonadError (ApplyTxError era) m, EventReturnTypeRep ep) =>
ApplySTSOpts ep ->
Globals ->
MempoolEnv era ->
MempoolState era ->
Tx era ->
m (EventReturnType ep (EraRule "LEDGER" era) (MempoolState era, Validated (Tx era)))
applyTxOpts ApplySTSOpts ep
opts Globals
globals LedgerEnv era
env MempoolState era
state Tx era
tx =
let res :: Either
(NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
(EventReturnType ep (EraRule "LEDGER" era) (MempoolState era))
res =
forall a b c. (a -> b -> c) -> b -> a -> c
flip forall r a. Reader r a -> r -> a
runReader Globals
globals
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 "LEDGER" era) ApplySTSOpts ep
opts
forall a b. (a -> b) -> a -> b
$ forall sts. (Environment sts, State sts, Signal sts) -> TRC sts
TRC (LedgerEnv era
env, MempoolState era
state, Tx era
tx)
in forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either b d) (Either c d)
left forall era.
NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ApplyTxError era
ApplyTxError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either d b) (Either d c)
right
(forall (ep :: EventPolicy) sts a b.
EventReturnTypeRep ep =>
(a -> b) -> EventReturnType ep sts a -> EventReturnType ep sts b
mapEventReturn @ep @(EraRule "LEDGER" era) @(MempoolState era) forall a b. (a -> b) -> a -> b
$ (,forall tx. tx -> Validated tx
Validated Tx era
tx))
forall a b. (a -> b) -> a -> b
$ Either
(NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
(EventReturnType ep (EraRule "LEDGER" era) (MempoolState era))
res
reapplyTx ::
MonadError (ApplyTxError era) m =>
Globals ->
MempoolEnv era ->
MempoolState era ->
Validated (Tx era) ->
m (MempoolState era)
reapplyTx Globals
globals LedgerEnv era
env MempoolState era
state (Validated Tx era
tx) =
let res :: Either
(NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
(MempoolState era)
res =
forall a b c. (a -> b -> c) -> b -> a -> c
flip forall r a. Reader r a -> r -> a
runReader Globals
globals
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 (NonEmpty (PredicateFailure s)) (State s))
applySTS @(EraRule "LEDGER" era)
forall a b. (a -> b) -> a -> b
$ forall sts. (Environment sts, State sts, Signal sts) -> TRC sts
TRC (LedgerEnv era
env, MempoolState era
state, Tx era
tx)
in forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either b d) (Either c d)
left forall era.
NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ApplyTxError era
ApplyTxError
forall a b. (a -> b) -> a -> b
$ Either
(NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
(MempoolState era)
res
instance
( EraPParams (ShelleyEra c)
, DSignable c (Hash c EraIndependentTxBody)
) =>
ApplyTx (ShelleyEra c)
type MempoolEnv era = Ledger.LedgerEnv era
type MempoolState era = LedgerState.LedgerState era
mkMempoolEnv ::
EraGov era =>
NewEpochState era ->
SlotNo ->
MempoolEnv era
mkMempoolEnv :: forall era.
EraGov era =>
NewEpochState era -> SlotNo -> MempoolEnv era
mkMempoolEnv
LedgerState.NewEpochState
{ EpochState era
nesEs :: forall era. NewEpochState era -> EpochState era
nesEs :: EpochState era
LedgerState.nesEs
}
SlotNo
slot =
Ledger.LedgerEnv
{ ledgerSlotNo :: SlotNo
Ledger.ledgerSlotNo = SlotNo
slot
, ledgerIx :: TxIx
Ledger.ledgerIx = forall a. Bounded a => a
minBound
, ledgerPp :: PParams era
Ledger.ledgerPp = EpochState era
nesEs forall s a. s -> Getting a s a -> a
^. forall era. EraGov era => Lens' (EpochState era) (PParams era)
curPParamsEpochStateL
, ledgerAccount :: AccountState
Ledger.ledgerAccount = forall era. EpochState era -> AccountState
LedgerState.esAccountState EpochState era
nesEs
, ledgerMempool :: Bool
Ledger.ledgerMempool = Bool
True
}
mkMempoolState :: NewEpochState era -> MempoolState era
mkMempoolState :: forall era. NewEpochState era -> MempoolState era
mkMempoolState LedgerState.NewEpochState {EpochState era
nesEs :: EpochState era
nesEs :: forall era. NewEpochState era -> EpochState era
LedgerState.nesEs} = forall era. EpochState era -> LedgerState era
LedgerState.esLState EpochState era
nesEs
newtype ApplyTxError era = ApplyTxError (NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
deriving stock instance
Eq (PredicateFailure (EraRule "LEDGER" era)) =>
Eq (ApplyTxError era)
deriving stock instance
Show (PredicateFailure (EraRule "LEDGER" era)) =>
Show (ApplyTxError era)
instance
( Era era
, EncCBOR (PredicateFailure (EraRule "LEDGER" era))
) =>
EncCBOR (ApplyTxError era)
where
encCBOR :: ApplyTxError era -> Encoding
encCBOR (ApplyTxError NonEmpty (PredicateFailure (EraRule "LEDGER" era))
failures) =
Version -> Encoding -> Encoding -> Encoding
ifEncodingVersionAtLeast
(forall (v :: Nat).
(KnownNat v, MinVersion <= v, v <= MaxVersion) =>
Version
natVersion @9)
(forall a. EncCBOR a => a -> Encoding
encCBOR NonEmpty (PredicateFailure (EraRule "LEDGER" era))
failures)
(forall (f :: * -> *) a.
Foldable f =>
(a -> Encoding) -> f a -> Encoding
encodeFoldableAsIndefLenList forall a. EncCBOR a => a -> Encoding
encCBOR NonEmpty (PredicateFailure (EraRule "LEDGER" era))
failures)
deriving newtype instance
( Era era
, DecCBOR (PredicateFailure (EraRule "LEDGER" era))
) =>
DecCBOR (ApplyTxError era)
instance
( Era era
, EncCBOR (PredicateFailure (EraRule "LEDGER" era))
) =>
ToCBOR (ApplyTxError era)
where
toCBOR :: ApplyTxError era -> Encoding
toCBOR = forall era t. (Era era, EncCBOR t) => t -> Encoding
toEraCBOR @era
instance
( Era era
, DecCBOR (PredicateFailure (EraRule "LEDGER" era))
) =>
FromCBOR (ApplyTxError era)
where
fromCBOR :: forall s. Decoder s (ApplyTxError era)
fromCBOR = forall era t s. (Era era, DecCBOR t) => Decoder s t
fromEraCBOR @era
applyTxs ::
(ApplyTx era, MonadError (ApplyTxError era) m, EraGov era) =>
Globals ->
SlotNo ->
Seq (Tx era) ->
NewEpochState era ->
m (NewEpochState era)
applyTxs :: forall era (m :: * -> *).
(ApplyTx era, MonadError (ApplyTxError era) m, EraGov era) =>
Globals
-> SlotNo
-> Seq (Tx era)
-> NewEpochState era
-> m (NewEpochState era)
applyTxs
Globals
globals
SlotNo
slot
Seq (Tx era)
txs
NewEpochState era
state =
forall (f :: * -> *) era.
Functor f =>
(MempoolState era -> f (MempoolState era))
-> NewEpochState era -> f (NewEpochState era)
overNewEpochState (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 = forall era.
EraGov era =>
NewEpochState era -> SlotNo -> MempoolEnv era
mkMempoolEnv NewEpochState era
state SlotNo
slot
{-# DEPRECATED applyTxs "Use `applyTxOpts` and `mkMempoolEnv` instead" #-}
applyTxsTransition ::
forall era m.
( ApplyTx era
, MonadError (ApplyTxError era) m
) =>
Globals ->
MempoolEnv era ->
Seq (Tx era) ->
MempoolState era ->
m (MempoolState era)
applyTxsTransition :: 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
env Seq (Tx era)
txs MempoolState era
state =
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 -> forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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
{-# DEPRECATED applyTxsTransition "Use `applyTxOpts` and `mkMempoolEnv` instead" #-}
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 (forall era. NewEpochState era -> MempoolState era
mkMempoolState NewEpochState era
st)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \MempoolState era
ls ->
NewEpochState era
st
{ nesEs :: EpochState era
LedgerState.nesEs =
(forall era. NewEpochState era -> EpochState era
LedgerState.nesEs NewEpochState era
st)
{ esLState :: MempoolState era
LedgerState.esLState = MempoolState era
ls
}
}
applyTx ::
(ApplyTx era, MonadError (ApplyTxError era) m) =>
Globals ->
MempoolEnv era ->
MempoolState era ->
Tx era ->
m (MempoolState era, Validated (Tx era))
applyTx :: forall era (m :: * -> *).
(ApplyTx era, MonadError (ApplyTxError era) m) =>
Globals
-> MempoolEnv era
-> MempoolState era
-> Tx era
-> m (MempoolState era, Validated (Tx era))
applyTx =
forall era (ep :: EventPolicy) (m :: * -> *).
(ApplyTx era, MonadError (ApplyTxError era) m,
EventReturnTypeRep ep) =>
ApplySTSOpts ep
-> Globals
-> LedgerEnv era
-> MempoolState era
-> Tx era
-> m (EventReturnType
ep (EraRule "LEDGER" era) (MempoolState era, Validated (Tx era)))
applyTxOpts forall a b. (a -> b) -> a -> b
$
ApplySTSOpts
{ asoAssertions :: AssertionPolicy
asoAssertions = AssertionPolicy
globalAssertionPolicy
, asoValidation :: ValidationPolicy
asoValidation = ValidationPolicy
ValidateAll
, asoEvents :: SingEP 'EventPolicyDiscard
asoEvents = SingEP 'EventPolicyDiscard
EPDiscard
}