{-# 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,
  ApplyTx (..),
  ApplyTxError (..),
  Validated,
  extractTx,
  coerceValidated,
  translateValidated,

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

  -- * Exports for compatibility
  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.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.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.Typeable (Typeable)
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
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)

-- | 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) = 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

-- Don't use this except in Testing to make Arbitrary instances, etc.
unsafeMakeValidated :: tx -> Validated tx
unsafeMakeValidated :: forall tx. tx -> Validated tx
unsafeMakeValidated = 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) = 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
  -- | Validate a transaction against a mempool state and for given STS options,
  -- and return the new mempool state, a "validated" 'TxInBlock' and,
  -- depending on the passed options, the emitted events.
  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 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

  -- | Reapply a previously validated 'Tx'.
  --
  --   This applies the (validated) transaction to a new mempool state. It may
  --   fail due to the mempool state changing (for example, a needed output
  --   having already been spent). It should not fail due to any static check
  --   (such as cryptographic checks).
  --
  --   Implementations of this function may optionally skip the performance of
  --   any static checks. This is not required, but strongly encouraged since
  --   this function will be called each time the mempool revalidates
  --   transactions against a new mempool state.
  reapplyTx ::
    MonadError (ApplyTxError era) m =>
    Globals ->
    MempoolEnv era ->
    MempoolState era ->
    Validated (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 ApplyTx ShelleyEra

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 :: forall era. NewEpochState era -> EpochState era
nesEs :: EpochState era
LedgerState.nesEs
    }
  SlotNo
slot =
    Ledger.LedgerEnv
      { ledgerSlotNo :: SlotNo
Ledger.ledgerSlotNo = SlotNo
slot
      , ledgerEpochNo :: Maybe EpochNo
Ledger.ledgerEpochNo = forall a. Maybe a
Nothing
      , 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
      }

-- | 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 :: 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)

-- TODO: This instance can be switched back to a derived version, once we are officially
-- in the Conway era:
--
-- deriving newtype instance
--   ( Era era
--   , EncCBOR (PredicateFailure (EraRule "LEDGER" era))
--   ) =>
--   EncCBOR (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

-- | 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 (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
              }
        }

-- | 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, 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
      }