{-# 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.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
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)
  ) =>
  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 =
        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 rule era) ApplySTSOpts 'EventPolicyDiscard
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 (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap forall era.
NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ApplyTxError era
ApplyTxError (,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 :: 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
      }

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

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 (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 =>
  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 = 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) =
  forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 (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