{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE EmptyDataDeriving #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Cardano.Ledger.Conway.Rules.Mempool (
  ConwayMEMPOOL,
) where

import Cardano.Ledger.BaseTypes (ShelleyBase)
import Cardano.Ledger.Conway.Core
import Cardano.Ledger.Conway.Era (
  ConwayLEDGER,
  ConwayMEMPOOL,
  hardforkConwayDisallowUnelectedCommitteeFromVoting,
 )
import Cardano.Ledger.Conway.Governance (
  ConwayEraGov,
  ConwayGovState,
  Proposals,
  committeeGovStateL,
 )
import Cardano.Ledger.Conway.Rules.Certs (CertsEnv)
import Cardano.Ledger.Conway.Rules.Gov (GovEnv, GovSignal, unelectedCommitteeVoters)
import Cardano.Ledger.Conway.Rules.Ledger (ConwayLedgerEvent, ConwayLedgerPredFailure (..))
import Cardano.Ledger.Conway.State
import Cardano.Ledger.Shelley.LedgerState
import Cardano.Ledger.Shelley.Rules (LedgerEnv (..), UtxoEnv, ledgerPpL)
import Control.Monad (unless)
import Control.State.Transition (
  BaseM,
  Environment,
  Event,
  PredicateFailure,
  STS (..),
  Signal,
  State,
  TRC (TRC),
  TransitionRule,
  failOnNonEmpty,
  judgmentContext,
  transitionRules,
  whenFailureFreeDefault,
  (?!),
 )
import Control.State.Transition.Extended (Embed (..), trans)
import qualified Data.List.NonEmpty as NE
import qualified Data.Map.Strict as Map
import Data.Sequence (Seq)
import Data.Text as T (pack)
import Lens.Micro ((^.))

instance
  ( EraTx era
  , ConwayEraTxBody era
  , ConwayEraGov era
  , ConwayEraCertState era
  , EraStake era
  , EraCertState era
  , Embed (EraRule "LEDGER" era) (ConwayMEMPOOL era)
  , State (EraRule "LEDGER" era) ~ LedgerState era
  , Eq (PredicateFailure (EraRule "CERTS" era))
  , Eq (PredicateFailure (EraRule "GOV" era))
  , Eq (PredicateFailure (EraRule "UTXOW" era))
  , Show (PredicateFailure (EraRule "CERTS" era))
  , Show (PredicateFailure (EraRule "GOV" era))
  , Show (PredicateFailure (EraRule "UTXOW" era))
  , Environment (EraRule "LEDGER" era) ~ LedgerEnv era
  , Tx era ~ Signal (EraRule "LEDGER" era)
  ) =>
  STS (ConwayMEMPOOL era)
  where
  type State (ConwayMEMPOOL era) = LedgerState era
  type Signal (ConwayMEMPOOL era) = Tx era
  type Environment (ConwayMEMPOOL era) = LedgerEnv era
  type BaseM (ConwayMEMPOOL era) = ShelleyBase
  type PredicateFailure (ConwayMEMPOOL era) = ConwayLedgerPredFailure era
  type Event (ConwayMEMPOOL era) = ConwayLedgerEvent era

  transitionRules :: [TransitionRule (ConwayMEMPOOL era)]
transitionRules = [forall era.
(EraTx era, ConwayEraTxBody era, ConwayEraGov era,
 ConwayEraCertState era,
 Embed (EraRule "LEDGER" era) (ConwayMEMPOOL era),
 State (EraRule "LEDGER" era) ~ LedgerState era,
 Environment (EraRule "LEDGER" era) ~ LedgerEnv era,
 Tx era ~ Signal (EraRule "LEDGER" era)) =>
TransitionRule (ConwayMEMPOOL era)
mempoolTransition @era]

mempoolTransition ::
  forall era.
  ( EraTx era
  , ConwayEraTxBody era
  , ConwayEraGov era
  , ConwayEraCertState era
  , Embed (EraRule "LEDGER" era) (ConwayMEMPOOL era)
  , State (EraRule "LEDGER" era) ~ LedgerState era
  , Environment (EraRule "LEDGER" era) ~ LedgerEnv era
  , Tx era ~ Signal (EraRule "LEDGER" era)
  ) =>
  TransitionRule (ConwayMEMPOOL era)
mempoolTransition :: forall era.
(EraTx era, ConwayEraTxBody era, ConwayEraGov era,
 ConwayEraCertState era,
 Embed (EraRule "LEDGER" era) (ConwayMEMPOOL era),
 State (EraRule "LEDGER" era) ~ LedgerState era,
 Environment (EraRule "LEDGER" era) ~ LedgerEnv era,
 Tx era ~ Signal (EraRule "LEDGER" era)) =>
TransitionRule (ConwayMEMPOOL era)
mempoolTransition = do
  TRC trc :: (Environment (ConwayMEMPOOL era), State (ConwayMEMPOOL era),
 Signal (ConwayMEMPOOL era))
trc@(Environment (ConwayMEMPOOL era)
ledgerEnv, State (ConwayMEMPOOL era)
ledgerState, Signal (ConwayMEMPOOL era)
tx) <-
    Rule
  (ConwayMEMPOOL era)
  'Transition
  (RuleContext 'Transition (ConwayMEMPOOL era))
F (Clause (ConwayMEMPOOL era) 'Transition)
  (TRC (ConwayMEMPOOL era))
forall sts (rtype :: RuleType).
Rule sts rtype (RuleContext rtype sts)
judgmentContext

  -- This rule only gets invoked on transactions within the mempool.
  -- Add checks here that sanitize undesired transactions.

  -- Detect whether the transaction is probably a duplicate
  let
    inputs :: Set TxIn
inputs = Signal (EraRule "LEDGER" era)
Signal (ConwayMEMPOOL era)
tx Signal (EraRule "LEDGER" era)
-> Getting (Set TxIn) (Signal (EraRule "LEDGER" era)) (Set TxIn)
-> Set TxIn
forall s a. s -> Getting a s a -> a
^. (TxBody era -> Const (Set TxIn) (TxBody era))
-> Tx era -> Const (Set TxIn) (Tx era)
(TxBody era -> Const (Set TxIn) (TxBody era))
-> Signal (EraRule "LEDGER" era)
-> Const (Set TxIn) (Signal (EraRule "LEDGER" era))
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx era) (TxBody era)
bodyTxL ((TxBody era -> Const (Set TxIn) (TxBody era))
 -> Signal (EraRule "LEDGER" era)
 -> Const (Set TxIn) (Signal (EraRule "LEDGER" era)))
-> ((Set TxIn -> Const (Set TxIn) (Set TxIn))
    -> TxBody era -> Const (Set TxIn) (TxBody era))
-> Getting (Set TxIn) (Signal (EraRule "LEDGER" era)) (Set TxIn)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set TxIn -> Const (Set TxIn) (Set TxIn))
-> TxBody era -> Const (Set TxIn) (TxBody era)
forall era. EraTxBody era => Lens' (TxBody era) (Set TxIn)
Lens' (TxBody era) (Set TxIn)
inputsTxBodyL
    UTxO Map TxIn (TxOut era)
utxo = State (ConwayMEMPOOL era)
LedgerState era
ledgerState LedgerState era
-> Getting (UTxO era) (LedgerState era) (UTxO era) -> UTxO era
forall s a. s -> Getting a s a -> a
^. Getting (UTxO era) (LedgerState era) (UTxO era)
forall era. SimpleGetter (LedgerState era) (UTxO era)
forall (t :: * -> *) era.
CanGetUTxO t =>
SimpleGetter (t era) (UTxO era)
utxoG
    notAllSpent :: Bool
notAllSpent = (TxIn -> Bool) -> Set TxIn -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (TxIn -> Map TxIn (TxOut era) -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`Map.member` Map TxIn (TxOut era)
utxo) Set TxIn
inputs
  Bool
notAllSpent
    Bool
-> PredicateFailure (ConwayMEMPOOL era)
-> Rule (ConwayMEMPOOL era) 'Transition ()
forall sts (ctx :: RuleType).
Bool -> PredicateFailure sts -> Rule sts ctx ()
?! Text -> ConwayLedgerPredFailure era
forall era. Text -> ConwayLedgerPredFailure era
ConwayMempoolFailure
      Text
"All inputs are spent. Transaction has probably already been included"

  -- Skip all other checks if the transaction is probably a duplicate
  LedgerState era
-> Rule (ConwayMEMPOOL era) 'Transition (LedgerState era)
-> Rule (ConwayMEMPOOL era) 'Transition (LedgerState era)
forall a sts (rtype :: RuleType).
a -> Rule sts rtype a -> Rule sts rtype a
whenFailureFreeDefault State (ConwayMEMPOOL era)
LedgerState era
ledgerState (Rule (ConwayMEMPOOL era) 'Transition (LedgerState era)
 -> Rule (ConwayMEMPOOL era) 'Transition (LedgerState era))
-> Rule (ConwayMEMPOOL era) 'Transition (LedgerState era)
-> Rule (ConwayMEMPOOL era) 'Transition (LedgerState era)
forall a b. (a -> b) -> a -> b
$ do
    let protVer :: ProtVer
protVer = LedgerEnv era
Environment (ConwayMEMPOOL era)
ledgerEnv 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
    Bool
-> Rule (ConwayMEMPOOL era) 'Transition ()
-> Rule (ConwayMEMPOOL era) 'Transition ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ProtVer -> Bool
hardforkConwayDisallowUnelectedCommitteeFromVoting ProtVer
protVer) (Rule (ConwayMEMPOOL era) 'Transition ()
 -> Rule (ConwayMEMPOOL era) 'Transition ())
-> Rule (ConwayMEMPOOL era) 'Transition ()
-> Rule (ConwayMEMPOOL era) 'Transition ()
forall a b. (a -> b) -> a -> b
$
      -- This check can completely be removed once mainnet switches to protocol
      -- version 11, since the same check has been implemented in the GOV rule.
      --
      -- Disallow votes by unelected committee members
      let addPrefix :: Text -> Text
addPrefix = (Text
"Unelected committee members are not allowed to cast votes: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>)
       in Set (Credential 'HotCommitteeRole)
-> (NonEmpty (Credential 'HotCommitteeRole)
    -> PredicateFailure (ConwayMEMPOOL era))
-> Rule (ConwayMEMPOOL era) 'Transition ()
forall (f :: * -> *) a sts (ctx :: RuleType).
Foldable f =>
f a -> (NonEmpty a -> PredicateFailure sts) -> Rule sts ctx ()
failOnNonEmpty
            ( StrictMaybe (Committee era)
-> CommitteeState era
-> VotingProcedures era
-> Set (Credential 'HotCommitteeRole)
forall era.
StrictMaybe (Committee era)
-> CommitteeState era
-> VotingProcedures era
-> Set (Credential 'HotCommitteeRole)
unelectedCommitteeVoters
                (State (ConwayMEMPOOL era)
LedgerState era
ledgerState LedgerState era
-> Getting
     (StrictMaybe (Committee era))
     (LedgerState era)
     (StrictMaybe (Committee era))
-> StrictMaybe (Committee era)
forall s a. s -> Getting a s a -> a
^. (UTxOState era
 -> Const (StrictMaybe (Committee era)) (UTxOState era))
-> LedgerState era
-> Const (StrictMaybe (Committee era)) (LedgerState era)
forall era (f :: * -> *).
Functor f =>
(UTxOState era -> f (UTxOState era))
-> LedgerState era -> f (LedgerState era)
lsUTxOStateL ((UTxOState era
  -> Const (StrictMaybe (Committee era)) (UTxOState era))
 -> LedgerState era
 -> Const (StrictMaybe (Committee era)) (LedgerState era))
-> ((StrictMaybe (Committee era)
     -> Const
          (StrictMaybe (Committee era)) (StrictMaybe (Committee era)))
    -> UTxOState era
    -> Const (StrictMaybe (Committee era)) (UTxOState era))
-> Getting
     (StrictMaybe (Committee era))
     (LedgerState era)
     (StrictMaybe (Committee era))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GovState era
 -> Const (StrictMaybe (Committee era)) (GovState era))
-> UTxOState era
-> Const (StrictMaybe (Committee era)) (UTxOState era)
forall era (f :: * -> *).
Functor f =>
(GovState era -> f (GovState era))
-> UTxOState era -> f (UTxOState era)
utxosGovStateL ((GovState era
  -> Const (StrictMaybe (Committee era)) (GovState era))
 -> UTxOState era
 -> Const (StrictMaybe (Committee era)) (UTxOState era))
-> ((StrictMaybe (Committee era)
     -> Const
          (StrictMaybe (Committee era)) (StrictMaybe (Committee era)))
    -> GovState era
    -> Const (StrictMaybe (Committee era)) (GovState era))
-> (StrictMaybe (Committee era)
    -> Const
         (StrictMaybe (Committee era)) (StrictMaybe (Committee era)))
-> UTxOState era
-> Const (StrictMaybe (Committee era)) (UTxOState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictMaybe (Committee era)
 -> Const
      (StrictMaybe (Committee era)) (StrictMaybe (Committee era)))
-> GovState era
-> Const (StrictMaybe (Committee era)) (GovState era)
forall era.
ConwayEraGov era =>
Lens' (GovState era) (StrictMaybe (Committee era))
Lens' (GovState era) (StrictMaybe (Committee era))
committeeGovStateL)
                (State (ConwayMEMPOOL era)
LedgerState era
ledgerState LedgerState era
-> Getting
     (CommitteeState era) (LedgerState era) (CommitteeState era)
-> CommitteeState era
forall s a. s -> Getting a s a -> a
^. (CertState era -> Const (CommitteeState era) (CertState era))
-> LedgerState era -> Const (CommitteeState era) (LedgerState era)
forall era (f :: * -> *).
Functor f =>
(CertState era -> f (CertState era))
-> LedgerState era -> f (LedgerState era)
lsCertStateL ((CertState era -> Const (CommitteeState era) (CertState era))
 -> LedgerState era -> Const (CommitteeState era) (LedgerState era))
-> ((CommitteeState era
     -> Const (CommitteeState era) (CommitteeState era))
    -> CertState era -> Const (CommitteeState era) (CertState era))
-> Getting
     (CommitteeState era) (LedgerState era) (CommitteeState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (VState era -> Const (CommitteeState era) (VState era))
-> CertState era -> Const (CommitteeState era) (CertState era)
forall era.
ConwayEraCertState era =>
Lens' (CertState era) (VState era)
Lens' (CertState era) (VState era)
certVStateL ((VState era -> Const (CommitteeState era) (VState era))
 -> CertState era -> Const (CommitteeState era) (CertState era))
-> ((CommitteeState era
     -> Const (CommitteeState era) (CommitteeState era))
    -> VState era -> Const (CommitteeState era) (VState era))
-> (CommitteeState era
    -> Const (CommitteeState era) (CommitteeState era))
-> CertState era
-> Const (CommitteeState era) (CertState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CommitteeState era
 -> Const (CommitteeState era) (CommitteeState era))
-> VState era -> Const (CommitteeState era) (VState era)
forall era (f :: * -> *).
Functor f =>
(CommitteeState era -> f (CommitteeState era))
-> VState era -> f (VState era)
vsCommitteeStateL)
                (Signal (EraRule "LEDGER" era)
Signal (ConwayMEMPOOL era)
tx Signal (EraRule "LEDGER" era)
-> Getting
     (VotingProcedures era)
     (Signal (EraRule "LEDGER" era))
     (VotingProcedures era)
-> VotingProcedures era
forall s a. s -> Getting a s a -> a
^. (TxBody era -> Const (VotingProcedures era) (TxBody era))
-> Tx era -> Const (VotingProcedures era) (Tx era)
(TxBody era -> Const (VotingProcedures era) (TxBody era))
-> Signal (EraRule "LEDGER" era)
-> Const (VotingProcedures era) (Signal (EraRule "LEDGER" era))
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx era) (TxBody era)
bodyTxL ((TxBody era -> Const (VotingProcedures era) (TxBody era))
 -> Signal (EraRule "LEDGER" era)
 -> Const (VotingProcedures era) (Signal (EraRule "LEDGER" era)))
-> ((VotingProcedures era
     -> Const (VotingProcedures era) (VotingProcedures era))
    -> TxBody era -> Const (VotingProcedures era) (TxBody era))
-> Getting
     (VotingProcedures era)
     (Signal (EraRule "LEDGER" era))
     (VotingProcedures era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (VotingProcedures era
 -> Const (VotingProcedures era) (VotingProcedures era))
-> TxBody era -> Const (VotingProcedures era) (TxBody era)
forall era.
ConwayEraTxBody era =>
Lens' (TxBody era) (VotingProcedures era)
Lens' (TxBody era) (VotingProcedures era)
votingProceduresTxBodyL)
            )
            (Text -> ConwayLedgerPredFailure era
forall era. Text -> ConwayLedgerPredFailure era
ConwayMempoolFailure (Text -> ConwayLedgerPredFailure era)
-> (NonEmpty (Credential 'HotCommitteeRole) -> Text)
-> NonEmpty (Credential 'HotCommitteeRole)
-> ConwayLedgerPredFailure era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
addPrefix (Text -> Text)
-> (NonEmpty (Credential 'HotCommitteeRole) -> Text)
-> NonEmpty (Credential 'HotCommitteeRole)
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> Text)
-> (NonEmpty (Credential 'HotCommitteeRole) -> String)
-> NonEmpty (Credential 'HotCommitteeRole)
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Credential 'HotCommitteeRole] -> String
forall a. Show a => a -> String
show ([Credential 'HotCommitteeRole] -> String)
-> (NonEmpty (Credential 'HotCommitteeRole)
    -> [Credential 'HotCommitteeRole])
-> NonEmpty (Credential 'HotCommitteeRole)
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty (Credential 'HotCommitteeRole)
-> [Credential 'HotCommitteeRole]
forall a. NonEmpty a -> [a]
NE.toList)

    -- Continue with LEDGER rules
    forall sub super (rtype :: RuleType).
Embed sub super =>
RuleContext rtype sub -> Rule super rtype (State sub)
trans @(EraRule "LEDGER" era) (RuleContext 'Transition (EraRule "LEDGER" era)
 -> Rule
      (ConwayMEMPOOL era) 'Transition (State (EraRule "LEDGER" era)))
-> RuleContext 'Transition (EraRule "LEDGER" era)
-> Rule
     (ConwayMEMPOOL era) 'Transition (State (EraRule "LEDGER" era))
forall a b. (a -> b) -> a -> b
$ (Environment (EraRule "LEDGER" era), State (EraRule "LEDGER" era),
 Signal (EraRule "LEDGER" era))
-> TRC (EraRule "LEDGER" era)
forall sts. (Environment sts, State sts, Signal sts) -> TRC sts
TRC (Environment (EraRule "LEDGER" era), State (EraRule "LEDGER" era),
 Signal (EraRule "LEDGER" era))
(Environment (ConwayMEMPOOL era), State (ConwayMEMPOOL era),
 Signal (ConwayMEMPOOL era))
trc

instance
  ( AlonzoEraTx era
  , ConwayEraTxBody era
  , ConwayEraGov era
  , BaseM (EraRule "CERTS" era) ~ ShelleyBase
  , BaseM (EraRule "GOV" era) ~ ShelleyBase
  , BaseM (EraRule "UTXOW" era) ~ ShelleyBase
  , Embed (EraRule "CERTS" era) (ConwayLEDGER era)
  , Embed (EraRule "GOV" era) (ConwayLEDGER era)
  , Embed (EraRule "UTXOW" era) (ConwayLEDGER era)
  , Environment (EraRule "CERTS" era) ~ CertsEnv era
  , Environment (EraRule "GOV" era) ~ GovEnv era
  , Environment (EraRule "UTXOW" era) ~ UtxoEnv era
  , State (EraRule "CERTS" era) ~ CertState era
  , State (EraRule "GOV" era) ~ Proposals era
  , State (EraRule "UTXOW" era) ~ UTxOState era
  , GovState era ~ ConwayGovState era
  , Signal (EraRule "CERTS" era) ~ Seq (TxCert era)
  , Signal (EraRule "GOV" era) ~ GovSignal era
  , Signal (EraRule "UTXOW" era) ~ Tx era
  , EraCertState era
  ) =>
  Embed (ConwayLEDGER era) (ConwayMEMPOOL era)
  where
  wrapFailed :: PredicateFailure (ConwayLEDGER era)
-> PredicateFailure (ConwayMEMPOOL era)
wrapFailed = PredicateFailure (ConwayLEDGER era)
-> PredicateFailure (ConwayMEMPOOL era)
ConwayLedgerPredFailure era -> ConwayLedgerPredFailure era
forall a. a -> a
id
  wrapEvent :: Event (ConwayLEDGER era) -> Event (ConwayMEMPOOL era)
wrapEvent = Event (ConwayLEDGER era) -> Event (ConwayMEMPOOL era)
ConwayLedgerEvent era -> ConwayLedgerEvent era
forall a. a -> a
id