{-# 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)
import Cardano.Ledger.Binary (
  DecCBOR (..),
  EncCBOR (..),
  FromCBOR (..),
  ToCBOR (..),
 )
import Cardano.Ledger.Core
import Cardano.Ledger.Rules.ValidationMode (lblStatic)
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.Shelley.State ()
import Cardano.Ledger.Slot (SlotNo)
import Control.DeepSeq (NFData)
import Control.Monad.Except (Except)
import Control.Monad.Trans.Reader (runReader)
import Control.State.Transition.Extended
import Data.Bifunctor (bimap)
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
(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)
  ) =>
  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.
  applyTxValidation ::
    ValidationPolicy ->
    Globals ->
    MempoolEnv era ->
    MempoolState era ->
    Tx era ->
    Either (ApplyTxError era) (MempoolState era, Validated (Tx era))

ruleApplyTxValidation ::
  forall rule 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) ~ Tx era
  , PredicateFailure (EraRule rule era) ~ PredicateFailure (EraRule "LEDGER" era)
  ) =>
  ValidationPolicy ->
  Globals ->
  MempoolEnv era ->
  MempoolState era ->
  Tx era ->
  Either (ApplyTxError era) (MempoolState era, Validated (Tx era))
ruleApplyTxValidation :: forall (rule :: Symbol) 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) ~ Tx era,
 PredicateFailure (EraRule rule era)
 ~ PredicateFailure (EraRule "LEDGER" era)) =>
ValidationPolicy
-> Globals
-> LedgerEnv era
-> MempoolState era
-> Tx era
-> Either (ApplyTxError era) (MempoolState era, Validated (Tx era))
ruleApplyTxValidation ValidationPolicy
validationPolicy Globals
globals LedgerEnv era
env MempoolState era
state Tx era
tx =
  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 "LEDGER" era)))
  (MempoolState era)
result =
        (Reader
   Globals
   (Either
      (NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
      (MempoolState era))
 -> Globals
 -> Either
      (NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
      (MempoolState era))
-> Globals
-> Reader
     Globals
     (Either
        (NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
        (MempoolState era))
-> Either
     (NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
     (MempoolState era)
forall a b c. (a -> b -> c) -> b -> a -> c
flip Reader
  Globals
  (Either
     (NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
     (MempoolState era))
-> Globals
-> Either
     (NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
     (MempoolState era)
forall r a. Reader r a -> r -> a
runReader Globals
globals
          (Reader
   Globals
   (Either
      (NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
      (MempoolState era))
 -> Either
      (NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
      (MempoolState era))
-> (TRC (EraRule rule era)
    -> Reader
         Globals
         (Either
            (NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
            (MempoolState era)))
-> TRC (EraRule rule era)
-> Either
     (NonEmpty (PredicateFailure (EraRule "LEDGER" 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 "LEDGER" era)))
      (MempoolState era))
-> TRC (EraRule rule era)
-> Either
     (NonEmpty (PredicateFailure (EraRule "LEDGER" 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, Tx era
Signal (EraRule rule era)
tx)
   in (NonEmpty (PredicateFailure (EraRule "LEDGER" era))
 -> ApplyTxError era)
-> (MempoolState era -> (MempoolState era, Validated (Tx era)))
-> Either
     (NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
     (MempoolState era)
-> Either (ApplyTxError era) (MempoolState era, Validated (Tx era))
forall a b c d. (a -> b) -> (c -> d) -> Either a c -> Either b d
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ApplyTxError era
forall era.
NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ApplyTxError era
ApplyTxError (,Tx era -> Validated (Tx era)
forall tx. tx -> Validated tx
Validated Tx era
tx) Either
  (NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
  (MempoolState era)
result

instance ApplyTx ShelleyEra where
  applyTxValidation :: ValidationPolicy
-> Globals
-> MempoolEnv ShelleyEra
-> MempoolState ShelleyEra
-> Tx ShelleyEra
-> Either
     (ApplyTxError ShelleyEra)
     (MempoolState ShelleyEra, Validated (Tx ShelleyEra))
applyTxValidation = forall (rule :: Symbol) 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) ~ Tx era,
 PredicateFailure (EraRule rule era)
 ~ PredicateFailure (EraRule "LEDGER" era)) =>
ValidationPolicy
-> Globals
-> LedgerEnv era
-> MempoolState era
-> Tx era
-> Either (ApplyTxError era) (MempoolState era, Validated (Tx era))
ruleApplyTxValidation @"LEDGER"

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

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)

deriving newtype instance
  ( Era era
  , EncCBOR (PredicateFailure (EraRule "LEDGER" era))
  ) =>
  EncCBOR (ApplyTxError era)

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 (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 era ->
  Either (ApplyTxError era) (MempoolState era, Validated (Tx era))
applyTx :: forall era.
ApplyTx era =>
Globals
-> MempoolEnv era
-> MempoolState era
-> Tx era
-> Either (ApplyTxError era) (MempoolState era, Validated (Tx era))
applyTx = ValidationPolicy
-> Globals
-> LedgerEnv era
-> LedgerState era
-> Tx era
-> Either (ApplyTxError era) (LedgerState era, Validated (Tx era))
forall era.
ApplyTx era =>
ValidationPolicy
-> Globals
-> MempoolEnv era
-> MempoolState era
-> Tx era
-> Either (ApplyTxError era) (MempoolState era, Validated (Tx era))
applyTxValidation ValidationPolicy
ValidateAll

-- | 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 era) ->
  Either (ApplyTxError era) (MempoolState era)
reapplyTx :: forall era.
ApplyTx era =>
Globals
-> MempoolEnv era
-> MempoolState era
-> Validated (Tx era)
-> Either (ApplyTxError era) (MempoolState era)
reapplyTx Globals
globals MempoolEnv era
env MempoolState era
state (Validated Tx era
tx) =
  (MempoolState era, Validated (Tx era)) -> MempoolState era
forall a b. (a, b) -> a
fst ((MempoolState era, Validated (Tx era)) -> MempoolState era)
-> Either (ApplyTxError era) (MempoolState era, Validated (Tx 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 era
-> Either (ApplyTxError era) (MempoolState era, Validated (Tx era))
forall era.
ApplyTx era =>
ValidationPolicy
-> Globals
-> MempoolEnv era
-> MempoolState era
-> Tx era
-> Either (ApplyTxError era) (MempoolState era, Validated (Tx 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 Tx era
tx