{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE EmptyDataDeriving #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# 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)
import Cardano.Ledger.Conway.Governance (
  ConwayEraGov,
  ConwayGovState,
  Proposals,
  Voter (..),
  authorizedElectedHotCommitteeCredentials,
  unVotingProcedures,
 )
import Cardano.Ledger.Conway.Rules.Certs (CertsEnv)
import Cardano.Ledger.Conway.Rules.Gov (GovEnv, GovSignal)
import Cardano.Ledger.Conway.Rules.Ledger (ConwayLedgerEvent, ConwayLedgerPredFailure (..))
import Cardano.Ledger.Shelley.LedgerState
import Cardano.Ledger.Shelley.Rules (LedgerEnv (..), UtxoEnv)
import Control.State.Transition (
  BaseM,
  Environment,
  Event,
  PredicateFailure,
  STS (..),
  Signal,
  State,
  TRC (TRC),
  TransitionRule,
  failOnNonEmpty,
  judgmentContext,
  transitionRules,
 )
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 qualified Data.Set as Set
import Data.Text as T (pack)
import Lens.Micro ((^.))

instance
  ( EraTx era
  , ConwayEraTxBody era
  , ConwayEraGov 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)
  , EraCertState 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,
 Embed (EraRule "LEDGER" era) (ConwayMEMPOOL era),
 State (EraRule "LEDGER" era) ~ LedgerState era,
 Environment (EraRule "LEDGER" era) ~ LedgerEnv era,
 Tx era ~ Signal (EraRule "LEDGER" era), EraCertState era) =>
TransitionRule (ConwayMEMPOOL era)
mempoolTransition @era]

mempoolTransition ::
  forall era.
  ( EraTx era
  , ConwayEraTxBody era
  , ConwayEraGov 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)
  , EraCertState era
  ) =>
  TransitionRule (ConwayMEMPOOL era)
mempoolTransition :: forall era.
(EraTx era, ConwayEraTxBody era, ConwayEraGov 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), EraCertState 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) <-
    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.
  let
    authorizedElectedHotCreds :: Set (Credential 'HotCommitteeRole)
authorizedElectedHotCreds = forall era.
(ConwayEraGov era, EraCertState era) =>
LedgerState era -> Set (Credential 'HotCommitteeRole)
authorizedElectedHotCommitteeCredentials State (ConwayMEMPOOL era)
ledgerState
    collectUnelectedCommitteeVotes :: Set (Credential 'HotCommitteeRole)
-> Voter
-> Map GovActionId (VotingProcedure era)
-> Set (Credential 'HotCommitteeRole)
collectUnelectedCommitteeVotes !Set (Credential 'HotCommitteeRole)
unelectedHotCreds Voter
voter Map GovActionId (VotingProcedure era)
_ =
      case Voter
voter of
        CommitteeVoter Credential 'HotCommitteeRole
hotCred
          | Credential 'HotCommitteeRole
hotCred forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set (Credential 'HotCommitteeRole)
authorizedElectedHotCreds ->
              forall a. Ord a => a -> Set a -> Set a
Set.insert Credential 'HotCommitteeRole
hotCred Set (Credential 'HotCommitteeRole)
unelectedHotCreds
        Voter
_ -> Set (Credential 'HotCommitteeRole)
unelectedHotCreds
    unelectedCommitteeVoters :: Set (Credential 'HotCommitteeRole)
unelectedCommitteeVoters =
      forall a k b. (a -> k -> b -> a) -> a -> Map k b -> a
Map.foldlWithKey' Set (Credential 'HotCommitteeRole)
-> Voter
-> Map GovActionId (VotingProcedure era)
-> Set (Credential 'HotCommitteeRole)
collectUnelectedCommitteeVotes forall a. Set a
Set.empty forall a b. (a -> b) -> a -> b
$
        forall era.
VotingProcedures era
-> Map Voter (Map GovActionId (VotingProcedure era))
unVotingProcedures (Signal (ConwayMEMPOOL era)
tx forall s a. s -> Getting a s a -> a
^. forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
ConwayEraTxBody era =>
Lens' (TxBody era) (VotingProcedures era)
votingProceduresTxBodyL)
    addPrefix :: Text -> Text
addPrefix =
      (Text
"Unelected committee members are not allowed to cast votes: " forall a. Semigroup a => a -> a -> a
<>)
  forall (f :: * -> *) a sts (ctx :: RuleType).
Foldable f =>
f a -> (NonEmpty a -> PredicateFailure sts) -> Rule sts ctx ()
failOnNonEmpty Set (Credential 'HotCommitteeRole)
unelectedCommitteeVoters forall a b. (a -> b) -> a -> b
$
    forall era. Text -> ConwayLedgerPredFailure era
ConwayMempoolFailure forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
addPrefix forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. NonEmpty a -> [a]
NE.toList
  forall sub super (rtype :: RuleType).
Embed sub super =>
RuleContext rtype sub -> Rule super rtype (State sub)
trans @(EraRule "LEDGER" era) forall a b. (a -> b) -> a -> b
$ forall sts. (Environment sts, State sts, Signal sts) -> TRC sts
TRC (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 = forall a. a -> a
id
  wrapEvent :: Event (ConwayLEDGER era) -> Event (ConwayMEMPOOL era)
wrapEvent = forall a. a -> a
id