{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}

module Test.Cardano.Ledger.Conway.Imp.MempoolSpec (spec) where

import Cardano.Ledger.BaseTypes
import Cardano.Ledger.Coin (Coin (..))
import Cardano.Ledger.Conway (hardforkConwayDisallowUnelectedCommitteeFromVoting)
import Cardano.Ledger.Conway.Core
import Cardano.Ledger.Conway.Governance
import Cardano.Ledger.Conway.Rules (
  ConwayGovPredFailure (UnelectedCommitteeVoters),
  ConwayLedgerPredFailure (..),
  ConwayUtxoPredFailure (BadInputsUTxO),
  PredicateFailure,
 )
import Cardano.Ledger.Credential (Credential (..))
import Cardano.Ledger.Shelley.LedgerState (nesELL)
import Data.List.NonEmpty (NonEmpty)
import qualified Data.Map.Strict as Map
import qualified Data.Set.NonEmpty as NES
import qualified Data.Text as T
import GHC.Exts (fromList)
import Lens.Micro ((&), (.~))
import Test.Cardano.Ledger.Conway.ImpTest
import Test.Cardano.Ledger.Core.Rational (IsRatio (..))
import Test.Cardano.Ledger.Imp.Common

spec :: forall era. ConwayEraImp era => SpecWith (ImpInit (LedgerSpec era))
spec :: forall era. ConwayEraImp era => SpecWith (ImpInit (LedgerSpec era))
spec = String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"MEMPOOL" (SpecWith (ImpInit (LedgerSpec era))
 -> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
  String -> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Duplicate transactions" (ImpTestM era () -> SpecWith (Arg (ImpTestM era ())))
-> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a b. (a -> b) -> a -> b
$ forall (v :: Natural) era.
(EraGov era, KnownNat v, MinVersion <= v, v <= MaxVersion) =>
ImpTestM era () -> ImpTestM era ()
whenMajorVersionAtMost @11 (ImpTestM era () -> ImpTestM era ())
-> ImpTestM era () -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ do
    inputsCommon <- Int -> ImpM (LedgerSpec era) TxIn -> ImpM (LedgerSpec era) [TxIn]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
5 ImpM (LedgerSpec era) TxIn
forall era. (ShelleyEraImp era, HasCallStack) => ImpTestM era TxIn
freshFundedTxIn
    inputsCommonNES <- expectJust $ NES.fromFoldable inputsCommon
    inputs1 <- replicateM 2 freshFundedTxIn
    inputs2 <- replicateM 3 freshFundedTxIn

    txFinal <-
      submitTx . mkBasicTx $
        mkBasicTxBody & inputsTxBodyL .~ fromList (inputsCommon <> inputs1)

    impAnn "Identical transaction" $
      withNoFixup $
        submitFailingMempoolTx
          txFinal
          [ injectFailure . ConwayMempoolFailure $
              "All inputs are spent. Transaction has probably already been included"
          ]

    impAnn "Overlapping transaction" $
      submitFailingMempoolTx
        (mkBasicTx $ mkBasicTxBody & inputsTxBodyL .~ fromList (inputsCommon <> inputs2))
        [injectFailure $ BadInputsUTxO inputsCommonNES]

  String -> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Unelected Committee voting" (ImpTestM era () -> SpecWith (Arg (ImpTestM era ())))
-> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a b. (a -> b) -> a -> b
$ ImpTestM era () -> ImpTestM era ()
forall era. EraGov era => ImpTestM era () -> ImpTestM era ()
whenPostBootstrap (ImpTestM era () -> ImpTestM era ())
-> ImpTestM era () -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ do
    _ <- ImpTestM era (NonEmpty (Credential HotCommitteeRole))
forall era.
(HasCallStack, ConwayEraImp era) =>
ImpTestM era (NonEmpty (Credential HotCommitteeRole))
registerInitialCommittee
    ccCold <- KeyHashObj <$> freshKeyHash
    curEpochNo <- getsNES nesELL
    let action =
          StrictMaybe (GovPurposeId 'CommitteePurpose)
-> Set (Credential ColdCommitteeRole)
-> Map (Credential ColdCommitteeRole) EpochNo
-> UnitInterval
-> GovAction era
forall era.
StrictMaybe (GovPurposeId 'CommitteePurpose)
-> Set (Credential ColdCommitteeRole)
-> Map (Credential ColdCommitteeRole) EpochNo
-> UnitInterval
-> GovAction era
UpdateCommittee
            StrictMaybe (GovPurposeId 'CommitteePurpose)
forall a. StrictMaybe a
SNothing
            Set (Credential ColdCommitteeRole)
forall a. Monoid a => a
mempty
            (Credential ColdCommitteeRole
-> EpochNo -> Map (Credential ColdCommitteeRole) EpochNo
forall k a. k -> a -> Map k a
Map.singleton Credential ColdCommitteeRole
ccCold (EpochNo -> EpochInterval -> EpochNo
addEpochInterval EpochNo
curEpochNo (Word32 -> EpochInterval
EpochInterval Word32
7)))
            (Integer
1 Integer -> Integer -> UnitInterval
forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
1)
    proposal <- mkProposal action
    submitTx_ $ mkBasicTx (mkBasicTxBody & proposalProceduresTxBodyL .~ [proposal])
    ccHot <- registerCommitteeHotKey ccCold
    govActionId <- do
      accountAddress <- registerAccountAddress
      submitTreasuryWithdrawals [(accountAddress, Coin 1)]

    let tx =
          TxBody TopTx era -> Tx TopTx era
forall era (l :: TxLevel). EraTx era => TxBody l era -> Tx l era
forall (l :: TxLevel). TxBody l era -> Tx l era
mkBasicTx (TxBody TopTx era -> Tx TopTx era)
-> TxBody TopTx era -> Tx TopTx era
forall a b. (a -> b) -> a -> b
$
            TxBody TopTx era
forall era (l :: TxLevel).
(EraTxBody era, Typeable l) =>
TxBody l era
forall (l :: TxLevel). Typeable l => TxBody l era
mkBasicTxBody
              TxBody TopTx era
-> (TxBody TopTx era -> TxBody TopTx era) -> TxBody TopTx era
forall a b. a -> (a -> b) -> b
& (VotingProcedures era -> Identity (VotingProcedures era))
-> TxBody TopTx era -> Identity (TxBody TopTx era)
forall era (l :: TxLevel).
ConwayEraTxBody era =>
Lens' (TxBody l era) (VotingProcedures era)
forall (l :: TxLevel). Lens' (TxBody l era) (VotingProcedures era)
votingProceduresTxBodyL
                ((VotingProcedures era -> Identity (VotingProcedures era))
 -> TxBody TopTx era -> Identity (TxBody TopTx era))
-> VotingProcedures era -> TxBody TopTx era -> TxBody TopTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Map Voter (Map GovActionId (VotingProcedure era))
-> VotingProcedures era
forall era.
Map Voter (Map GovActionId (VotingProcedure era))
-> VotingProcedures era
VotingProcedures
                  ( Voter
-> Map GovActionId (VotingProcedure era)
-> Map Voter (Map GovActionId (VotingProcedure era))
forall k a. k -> a -> Map k a
Map.singleton
                      (Credential HotCommitteeRole -> Voter
CommitteeVoter Credential HotCommitteeRole
ccHot)
                      (GovActionId
-> VotingProcedure era -> Map GovActionId (VotingProcedure era)
forall k a. k -> a -> Map k a
Map.singleton GovActionId
govActionId (Vote -> StrictMaybe Anchor -> VotingProcedure era
forall era. Vote -> StrictMaybe Anchor -> VotingProcedure era
VotingProcedure Vote
VoteYes StrictMaybe Anchor
forall a. StrictMaybe a
SNothing))
                  )
    pv <- getProtVer
    if hardforkConwayDisallowUnelectedCommitteeFromVoting pv
      then submitFailingTx tx [injectFailure $ UnelectedCommitteeVoters [ccHot]]
      else do
        txFixed <- fixupTx tx
        withNoFixup $ do
          submitFailingMempoolTx
            txFixed
            [ injectFailure . ConwayMempoolFailure $
                "Unelected committee members are not allowed to cast votes: "
                  <> T.pack (show (pure @[] ccHot))
            ]
          submitTx_ txFixed

submitFailingMempoolTx ::
  (HasCallStack, ConwayEraImp era) =>
  Tx TopTx era ->
  NonEmpty (PredicateFailure (EraRule "LEDGER" era)) ->
  ImpTestM era ()
submitFailingMempoolTx :: forall era.
(HasCallStack, ConwayEraImp era) =>
Tx TopTx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingMempoolTx Tx TopTx era
tx NonEmpty (PredicateFailure (EraRule "LEDGER" era))
expectedFailures = do
  result <- Tx TopTx era
-> ImpTestM
     era (Either (ApplyTxError era) (MempoolState era, ValidatedTx era))
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx TopTx era
-> ImpTestM
     era (Either (ApplyTxError era) (MempoolState era, ValidatedTx era))
trySubmitMempoolTx Tx TopTx era
tx
  case result of
    Left ApplyTxError era
applyTxError -> ApplyTxError era
applyTxError ApplyTxError era -> ApplyTxError era -> ImpM (LedgerSpec era) ()
forall a (m :: * -> *).
(HasCallStack, ToExpr a, Eq a, MonadIO m) =>
a -> a -> m ()
`shouldBeExpr` NonEmpty (EraRuleFailure "LEDGER" era) -> ApplyTxError era
forall t s. Inject t s => t -> s
inject NonEmpty (PredicateFailure (EraRule "LEDGER" era))
NonEmpty (EraRuleFailure "LEDGER" era)
expectedFailures
    Right (MempoolState era, ValidatedTx era)
_ -> String -> ImpM (LedgerSpec era) ()
forall (m :: * -> *) a. (HasCallStack, MonadIO m) => String -> m a
assertFailure (String -> ImpM (LedgerSpec era) ())
-> String -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$ String
"Expected a mempool rejection with: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> NonEmpty (EraRuleFailure "LEDGER" era) -> String
forall a. Show a => a -> String
show NonEmpty (PredicateFailure (EraRule "LEDGER" era))
NonEmpty (EraRuleFailure "LEDGER" era)
expectedFailures