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

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

import Cardano.Ledger.BaseTypes
import Cardano.Ledger.Coin (Coin (..))
import Cardano.Ledger.Conway.Core
import Cardano.Ledger.Conway.Governance
import Cardano.Ledger.Conway.Rules (
  ConwayLedgerPredFailure (..),
  ConwayUtxoPredFailure (BadInputsUTxO),
  maxRefScriptSizePerTx,
 )
import Cardano.Ledger.Credential (Credential (..))
import Cardano.Ledger.DRep
import Cardano.Ledger.Plutus (SLanguage (..), hashPlutusScript)
import Cardano.Ledger.Shelley.API.Mempool (ApplyTx (..), ApplyTxError (..), applyTx, mkMempoolEnv)
import qualified Cardano.Ledger.Shelley.HardForks as HF (bootstrapPhase)
import Cardano.Ledger.Shelley.LedgerState
import Control.Monad.Reader (asks)
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import qualified Data.Text as T
import GHC.Exts (fromList)
import Lens.Micro ((&), (.~), (<>~), (^.))
import Lens.Micro.Mtl (use)
import Test.Cardano.Ledger.Conway.ImpTest
import Test.Cardano.Ledger.Core.Rational (IsRatio (..))
import Test.Cardano.Ledger.Imp.Common
import Test.Cardano.Ledger.Plutus.Examples (
  alwaysSucceedsNoDatum,
  purposeIsWellformedNoDatum,
 )

spec ::
  forall era.
  ( ConwayEraImp era
  , InjectRuleFailure "LEDGER" ConwayLedgerPredFailure era
  , InjectRuleFailure "LEDGER" ConwayUtxoPredFailure era
  , ApplyTx era
  ) =>
  SpecWith (ImpInit (LedgerSpec era))
spec :: forall era.
(ConwayEraImp era,
 InjectRuleFailure "LEDGER" ConwayLedgerPredFailure era,
 InjectRuleFailure "LEDGER" ConwayUtxoPredFailure era,
 ApplyTx era) =>
SpecWith (ImpInit (LedgerSpec era))
spec = do
  forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"TxRefScriptsSizeTooBig" forall a b. (a -> b) -> a -> b
$ do
    -- we use here the largest script we currently have as many times as necessary to
    -- trigger the predicate failure
    Just PlutusScript era
plutusScript <- forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall era (l :: Language).
(AlonzoEraScript era, PlutusLanguage l) =>
Plutus l -> Maybe (PlutusScript era)
mkPlutusScript @era forall a b. (a -> b) -> a -> b
$ forall (l :: Language). SLanguage l -> Plutus l
purposeIsWellformedNoDatum SLanguage 'PlutusV3
SPlutusV3
    let script :: Script era
        script :: Script era
script = forall era. AlonzoEraScript era => PlutusScript era -> Script era
fromPlutusScript PlutusScript era
plutusScript
        size :: Int
size = forall t. SafeToHash t => t -> Int
originalBytesSize Script era
script
        n :: Int
n = Int
maxRefScriptSizePerTx forall a. Integral a => a -> a -> a
`div` Int
size forall a. Num a => a -> a -> a
+ Int
1
    [TxIn]
txIns <- forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
n (forall era.
(ShelleyEraImp era, BabbageEraTxOut era) =>
Script era -> ImpTestM era TxIn
produceRefScript Script era
script)
    let tx :: Tx era
        tx :: Tx era
tx = forall era. EraTx era => TxBody era -> Tx era
mkBasicTx (forall era. EraTxBody era => TxBody era
mkBasicTxBody forall a b. a -> (a -> b) -> b
& forall era. BabbageEraTxBody era => Lens' (TxBody era) (Set TxIn)
referenceInputsTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. Ord a => [a] -> Set a
Set.fromList [TxIn]
txIns)
    forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingTx
      Tx era
tx
      [ forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure forall a b. (a -> b) -> a -> b
$
          forall era. Mismatch 'RelLTEQ Int -> ConwayLedgerPredFailure era
ConwayTxRefScriptsSizeTooBig forall a b. (a -> b) -> a -> b
$
            Mismatch
              { mismatchSupplied :: Int
mismatchSupplied = Int
size forall a. Num a => a -> a -> a
* Int
n
              , mismatchExpected :: Int
mismatchExpected = Int
maxRefScriptSizePerTx
              }
      ]

  forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Withdraw from delegated and non-delegated staking key" forall a b. (a -> b) -> a -> b
$ do
    forall era.
ShelleyEraImp era =>
(PParams era -> PParams era) -> ImpTestM era ()
modifyPParams forall a b. (a -> b) -> a -> b
$ forall era.
ConwayEraPParams era =>
Lens' (PParams era) EpochInterval
ppGovActionLifetimeL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Word32 -> EpochInterval
EpochInterval Word32
2
    KeyHash 'Staking
kh <- forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
    let cred :: Credential 'Staking
cred = forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj KeyHash 'Staking
kh
    RewardAccount
ra <- forall era.
(HasCallStack, ShelleyEraImp era) =>
Credential 'Staking -> ImpTestM era RewardAccount
registerStakeCredential Credential 'Staking
cred
    forall era.
ConwayEraImp era =>
Credential 'Staking -> ImpTestM era ()
submitAndExpireProposalToMakeReward Credential 'Staking
cred
    Coin
reward <- forall era.
(HasCallStack, EraCertState era) =>
Credential 'Staking -> ImpTestM era Coin
getReward Credential 'Staking
cred

    let tx :: Tx era
tx = forall era. EraTx era => TxBody era -> Tx era
mkBasicTx forall a b. (a -> b) -> a -> b
$ forall era. EraTxBody era => TxBody era
mkBasicTxBody forall a b. a -> (a -> b) -> b
& forall era. EraTxBody era => Lens' (TxBody era) Withdrawals
withdrawalsTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Map RewardAccount Coin -> Withdrawals
Withdrawals [(RewardAccount
ra, Coin
reward)]

    ProtVer
pv <- forall era. EraGov era => ImpTestM era ProtVer
getProtVer
    if ProtVer -> Bool
HF.bootstrapPhase ProtVer
pv
      then forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era ()
submitTx_ Tx era
tx
      else
        forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingTx
          Tx era
tx
          [forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure forall a b. (a -> b) -> a -> b
$ forall era.
NonEmpty (KeyHash 'Staking) -> ConwayLedgerPredFailure era
ConwayWdrlNotDelegatedToDRep [KeyHash 'Staking
kh]]
    KeyPair 'Payment
_ <- forall era.
ConwayEraImp era =>
Credential 'Staking
-> Coin -> DRep -> ImpTestM era (KeyPair 'Payment)
delegateToDRep Credential 'Staking
cred (Integer -> Coin
Coin Integer
1_000_000) DRep
DRepAlwaysAbstain
    forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era ()
submitTx_ forall a b. (a -> b) -> a -> b
$
      forall era. EraTx era => TxBody era -> Tx era
mkBasicTx forall a b. (a -> b) -> a -> b
$
        forall era. EraTxBody era => TxBody era
mkBasicTxBody
          forall a b. a -> (a -> b) -> b
& forall era. EraTxBody era => Lens' (TxBody era) Withdrawals
withdrawalsTxBodyL
            forall s t a b. ASetter s t a b -> b -> s -> t
.~ Map RewardAccount Coin -> Withdrawals
Withdrawals
              [(RewardAccount
ra, if ProtVer -> Bool
HF.bootstrapPhase ProtVer
pv then forall a. Monoid a => a
mempty else Coin
reward)]

  forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Withdraw from a key delegated to an unregistered DRep" forall a b. (a -> b) -> a -> b
$ do
    forall era.
ShelleyEraImp era =>
(PParams era -> PParams era) -> ImpTestM era ()
modifyPParams forall a b. (a -> b) -> a -> b
$ forall era.
ConwayEraPParams era =>
Lens' (PParams era) EpochInterval
ppGovActionLifetimeL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Word32 -> EpochInterval
EpochInterval Word32
2
    KeyHash 'Staking
kh <- forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
    let cred :: Credential 'Staking
cred = forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj KeyHash 'Staking
kh
    RewardAccount
ra <- forall era.
(HasCallStack, ShelleyEraImp era) =>
Credential 'Staking -> ImpTestM era RewardAccount
registerStakeCredential Credential 'Staking
cred
    forall era.
ConwayEraImp era =>
Credential 'Staking -> ImpTestM era ()
submitAndExpireProposalToMakeReward Credential 'Staking
cred
    Coin
reward <- forall era.
(HasCallStack, EraCertState era) =>
Credential 'Staking -> ImpTestM era Coin
getReward Credential 'Staking
cred

    (Credential 'DRepRole
drep, Credential 'Staking
_, KeyPair 'Payment
_) <- forall era.
ConwayEraImp era =>
Integer
-> ImpTestM
     era (Credential 'DRepRole, Credential 'Staking, KeyPair 'Payment)
setupSingleDRep Integer
1_000_000

    KeyPair 'Payment
_ <- forall era.
ConwayEraImp era =>
Credential 'Staking
-> Coin -> DRep -> ImpTestM era (KeyPair 'Payment)
delegateToDRep Credential 'Staking
cred (Integer -> Coin
Coin Integer
1_000_000) (Credential 'DRepRole -> DRep
DRepCredential Credential 'DRepRole
drep)

    forall era.
(ShelleyEraImp era, ConwayEraTxCert era, ConwayEraCertState era) =>
Credential 'DRepRole -> ImpTestM era ()
unRegisterDRep Credential 'DRepRole
drep
    forall era.
(HasCallStack, ConwayEraCertState era) =>
Credential 'DRepRole -> ImpTestM era ()
expectDRepNotRegistered Credential 'DRepRole
drep
    let tx :: Tx era
tx =
          forall era. EraTx era => TxBody era -> Tx era
mkBasicTx forall a b. (a -> b) -> a -> b
$
            forall era. EraTxBody era => TxBody era
mkBasicTxBody
              forall a b. a -> (a -> b) -> b
& forall era. EraTxBody era => Lens' (TxBody era) Withdrawals
withdrawalsTxBodyL
                forall s t a b. ASetter s t a b -> b -> s -> t
.~ Map RewardAccount Coin -> Withdrawals
Withdrawals
                  [(RewardAccount
ra, Coin
reward)]
    forall era a.
EraGov era =>
ImpTestM era a -> ImpTestM era a -> ImpTestM era a
ifBootstrap (forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era ()
submitTx_ Tx era
tx forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (forall era.
(HasCallStack, EraCertState era) =>
Credential 'Staking -> ImpTestM era Coin
getReward Credential 'Staking
cred forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
m a -> a -> m ()
`shouldReturn` forall a. Monoid a => a
mempty)) forall a b. (a -> b) -> a -> b
$ do
      forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingTx Tx era
tx [forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure forall a b. (a -> b) -> a -> b
$ forall era.
NonEmpty (KeyHash 'Staking) -> ConwayLedgerPredFailure era
ConwayWdrlNotDelegatedToDRep [KeyHash 'Staking
kh]]

  forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Withdraw and unregister staking credential in the same transaction" forall a b. (a -> b) -> a -> b
$ do
    Coin
refund <- forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall a b. (a -> b) -> a -> b
$ forall era. Lens' (NewEpochState era) (EpochState era)
nesEsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EraGov era => Lens' (EpochState era) (PParams era)
curPParamsEpochStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EraPParams era => Lens' (PParams era) Coin
ppKeyDepositL
    KeyHash 'Staking
kh <- forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
    let cred :: Credential 'Staking
cred = forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj KeyHash 'Staking
kh
    RewardAccount
ra <- forall era.
(HasCallStack, ShelleyEraImp era) =>
Credential 'Staking -> ImpTestM era RewardAccount
registerStakeCredential Credential 'Staking
cred
    Positive Integer
newDeposit <- forall a (m :: * -> *). (Arbitrary a, MonadGen m) => m a
arbitrary
    forall era.
ShelleyEraImp era =>
(PParams era -> PParams era) -> ImpTestM era ()
modifyPParams forall a b. (a -> b) -> a -> b
$ \PParams era
pp ->
      PParams era
pp
        forall a b. a -> (a -> b) -> b
& forall era.
ConwayEraPParams era =>
Lens' (PParams era) EpochInterval
ppGovActionLifetimeL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Word32 -> EpochInterval
EpochInterval Word32
2
        forall a b. a -> (a -> b) -> b
& forall era. EraPParams era => Lens' (PParams era) Coin
ppKeyDepositL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Integer -> Coin
Coin Integer
newDeposit

    forall era.
ConwayEraImp era =>
Credential 'Staking -> ImpTestM era ()
submitAndExpireProposalToMakeReward Credential 'Staking
cred
    Coin
reward <- forall era.
(HasCallStack, EraCertState era) =>
Credential 'Staking -> ImpTestM era Coin
getReward Credential 'Staking
cred

    (Credential 'DRepRole
drep, Credential 'Staking
_, KeyPair 'Payment
_) <- forall era.
ConwayEraImp era =>
Integer
-> ImpTestM
     era (Credential 'DRepRole, Credential 'Staking, KeyPair 'Payment)
setupSingleDRep Integer
1_000_000

    KeyPair 'Payment
_ <- forall era.
ConwayEraImp era =>
Credential 'Staking
-> Coin -> DRep -> ImpTestM era (KeyPair 'Payment)
delegateToDRep Credential 'Staking
cred (Integer -> Coin
Coin Integer
1_000_000) (Credential 'DRepRole -> DRep
DRepCredential Credential 'DRepRole
drep)

    let tx :: Tx era
tx =
          forall era. EraTx era => TxBody era -> Tx era
mkBasicTx forall a b. (a -> b) -> a -> b
$
            forall era. EraTxBody era => TxBody era
mkBasicTxBody
              forall a b. a -> (a -> b) -> b
& forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxCert era))
certsTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ [forall era.
ConwayEraTxCert era =>
Credential 'Staking -> Coin -> TxCert era
UnRegDepositTxCert Credential 'Staking
cred Coin
refund]
              forall a b. a -> (a -> b) -> b
& (forall era. EraTxBody era => Lens' (TxBody era) Withdrawals
withdrawalsTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Map RewardAccount Coin -> Withdrawals
Withdrawals [(RewardAccount
ra, Coin
reward)])
    forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era ()
submitTx_ Tx era
tx

  forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Withdraw from a key delegated to an expired DRep" forall a b. (a -> b) -> a -> b
$ do
    forall era.
ShelleyEraImp era =>
(PParams era -> PParams era) -> ImpTestM era ()
modifyPParams forall a b. (a -> b) -> a -> b
$ \PParams era
pp ->
      PParams era
pp
        forall a b. a -> (a -> b) -> b
& forall era.
ConwayEraPParams era =>
Lens' (PParams era) EpochInterval
ppGovActionLifetimeL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Word32 -> EpochInterval
EpochInterval Word32
4
        forall a b. a -> (a -> b) -> b
& forall era.
ConwayEraPParams era =>
Lens' (PParams era) EpochInterval
ppDRepActivityL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Word32 -> EpochInterval
EpochInterval Word32
1
    KeyHash 'Staking
kh <- forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
    let cred :: Credential 'Staking
cred = forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj KeyHash 'Staking
kh
    RewardAccount
ra <- forall era.
(HasCallStack, ShelleyEraImp era) =>
Credential 'Staking -> ImpTestM era RewardAccount
registerStakeCredential Credential 'Staking
cred
    forall era.
ConwayEraImp era =>
Credential 'Staking -> ImpTestM era ()
submitAndExpireProposalToMakeReward Credential 'Staking
cred
    Coin
reward <- forall era.
(HasCallStack, EraCertState era) =>
Credential 'Staking -> ImpTestM era Coin
getReward Credential 'Staking
cred

    (Credential 'DRepRole
drep, Credential 'Staking
_, KeyPair 'Payment
_) <- forall era.
ConwayEraImp era =>
Integer
-> ImpTestM
     era (Credential 'DRepRole, Credential 'Staking, KeyPair 'Payment)
setupSingleDRep Integer
1_000_000

    -- expire the drep before delegation
    forall era.
ConwayEraImp era =>
StrictMaybe GovActionId -> ImpTestM era (GovAction era)
mkMinFeeUpdateGovAction forall a. StrictMaybe a
SNothing forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
GovAction era -> ImpTestM era ()
submitGovAction_
    forall era. ShelleyEraImp era => Natural -> ImpTestM era ()
passNEpochs Natural
4
    forall era.
(HasCallStack, ConwayEraCertState era) =>
Credential 'DRepRole -> ImpTestM era Bool
isDRepExpired Credential 'DRepRole
drep forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
m a -> a -> m ()
`shouldReturn` Bool
True

    KeyPair 'Payment
_ <- forall era.
ConwayEraImp era =>
Credential 'Staking
-> Coin -> DRep -> ImpTestM era (KeyPair 'Payment)
delegateToDRep Credential 'Staking
cred (Integer -> Coin
Coin Integer
1_000_000) (Credential 'DRepRole -> DRep
DRepCredential Credential 'DRepRole
drep)

    forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era ()
submitTx_ forall a b. (a -> b) -> a -> b
$
      forall era. EraTx era => TxBody era -> Tx era
mkBasicTx forall a b. (a -> b) -> a -> b
$
        forall era. EraTxBody era => TxBody era
mkBasicTxBody
          forall a b. a -> (a -> b) -> b
& forall era. EraTxBody era => Lens' (TxBody era) Withdrawals
withdrawalsTxBodyL
            forall s t a b. ASetter s t a b -> b -> s -> t
.~ Map RewardAccount Coin -> Withdrawals
Withdrawals
              [(RewardAccount
ra, Coin
reward)]

  forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Withdraw from a key delegated to a DRep that expired after delegation" forall a b. (a -> b) -> a -> b
$ do
    forall era.
ShelleyEraImp era =>
(PParams era -> PParams era) -> ImpTestM era ()
modifyPParams forall a b. (a -> b) -> a -> b
$ \PParams era
pp ->
      PParams era
pp
        forall a b. a -> (a -> b) -> b
& forall era.
ConwayEraPParams era =>
Lens' (PParams era) EpochInterval
ppGovActionLifetimeL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Word32 -> EpochInterval
EpochInterval Word32
4
        forall a b. a -> (a -> b) -> b
& forall era.
ConwayEraPParams era =>
Lens' (PParams era) EpochInterval
ppDRepActivityL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Word32 -> EpochInterval
EpochInterval Word32
1
    KeyHash 'Staking
kh <- forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
    let cred :: Credential 'Staking
cred = forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj KeyHash 'Staking
kh
    RewardAccount
ra <- forall era.
(HasCallStack, ShelleyEraImp era) =>
Credential 'Staking -> ImpTestM era RewardAccount
registerStakeCredential Credential 'Staking
cred
    forall era.
ConwayEraImp era =>
Credential 'Staking -> ImpTestM era ()
submitAndExpireProposalToMakeReward Credential 'Staking
cred
    Coin
reward <- forall era.
(HasCallStack, EraCertState era) =>
Credential 'Staking -> ImpTestM era Coin
getReward Credential 'Staking
cred

    (Credential 'DRepRole
drep, Credential 'Staking
_, KeyPair 'Payment
_) <- forall era.
ConwayEraImp era =>
Integer
-> ImpTestM
     era (Credential 'DRepRole, Credential 'Staking, KeyPair 'Payment)
setupSingleDRep Integer
1_000_000

    KeyPair 'Payment
_ <- forall era.
ConwayEraImp era =>
Credential 'Staking
-> Coin -> DRep -> ImpTestM era (KeyPair 'Payment)
delegateToDRep Credential 'Staking
cred (Integer -> Coin
Coin Integer
1_000_000) (Credential 'DRepRole -> DRep
DRepCredential Credential 'DRepRole
drep)

    -- expire the drep after delegation
    forall era.
ConwayEraImp era =>
StrictMaybe GovActionId -> ImpTestM era (GovAction era)
mkMinFeeUpdateGovAction forall a. StrictMaybe a
SNothing forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
GovAction era -> ImpTestM era ()
submitGovAction_

    forall era. ShelleyEraImp era => Natural -> ImpTestM era ()
passNEpochs Natural
4
    forall era.
(HasCallStack, ConwayEraCertState era) =>
Credential 'DRepRole -> ImpTestM era Bool
isDRepExpired Credential 'DRepRole
drep forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
m a -> a -> m ()
`shouldReturn` Bool
True

    forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era ()
submitTx_ forall a b. (a -> b) -> a -> b
$
      forall era. EraTx era => TxBody era -> Tx era
mkBasicTx forall a b. (a -> b) -> a -> b
$
        forall era. EraTxBody era => TxBody era
mkBasicTxBody
          forall a b. a -> (a -> b) -> b
& forall era. EraTxBody era => Lens' (TxBody era) Withdrawals
withdrawalsTxBodyL
            forall s t a b. ASetter s t a b -> b -> s -> t
.~ Map RewardAccount Coin -> Withdrawals
Withdrawals
              [(RewardAccount
ra, Coin
reward)]

  forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Withdraw from delegated and non-delegated staking script" forall a b. (a -> b) -> a -> b
$ do
    forall era.
ShelleyEraImp era =>
(PParams era -> PParams era) -> ImpTestM era ()
modifyPParams forall a b. (a -> b) -> a -> b
$ forall era.
ConwayEraPParams era =>
Lens' (PParams era) EpochInterval
ppGovActionLifetimeL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Word32 -> EpochInterval
EpochInterval Word32
2
    let scriptHash :: ScriptHash
scriptHash = forall (l :: Language). PlutusLanguage l => Plutus l -> ScriptHash
hashPlutusScript forall a b. (a -> b) -> a -> b
$ forall (l :: Language). SLanguage l -> Plutus l
alwaysSucceedsNoDatum SLanguage 'PlutusV3
SPlutusV3
    let cred :: Credential kr
cred = forall (kr :: KeyRole). ScriptHash -> Credential kr
ScriptHashObj ScriptHash
scriptHash
    RewardAccount
ra <- forall era.
(HasCallStack, ShelleyEraImp era) =>
Credential 'Staking -> ImpTestM era RewardAccount
registerStakeCredential forall {kr :: KeyRole}. Credential kr
cred
    forall era.
ConwayEraImp era =>
Credential 'Staking -> ImpTestM era ()
submitAndExpireProposalToMakeReward forall {kr :: KeyRole}. Credential kr
cred
    Coin
reward <- forall era.
(HasCallStack, EraCertState era) =>
Credential 'Staking -> ImpTestM era Coin
getReward forall {kr :: KeyRole}. Credential kr
cred

    forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era ()
submitTx_ forall a b. (a -> b) -> a -> b
$
      forall era. EraTx era => TxBody era -> Tx era
mkBasicTx forall a b. (a -> b) -> a -> b
$
        forall era. EraTxBody era => TxBody era
mkBasicTxBody forall a b. a -> (a -> b) -> b
& forall era. EraTxBody era => Lens' (TxBody era) Withdrawals
withdrawalsTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Map RewardAccount Coin -> Withdrawals
Withdrawals [(RewardAccount
ra, Coin
reward)]

    KeyPair 'Payment
_ <- forall era.
ConwayEraImp era =>
Credential 'Staking
-> Coin -> DRep -> ImpTestM era (KeyPair 'Payment)
delegateToDRep forall {kr :: KeyRole}. Credential kr
cred (Integer -> Coin
Coin Integer
1_000_000) DRep
DRepAlwaysAbstain
    forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era ()
submitTx_ forall a b. (a -> b) -> a -> b
$
      forall era. EraTx era => TxBody era -> Tx era
mkBasicTx forall a b. (a -> b) -> a -> b
$
        forall era. EraTxBody era => TxBody era
mkBasicTxBody forall a b. a -> (a -> b) -> b
& forall era. EraTxBody era => Lens' (TxBody era) Withdrawals
withdrawalsTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Map RewardAccount Coin -> Withdrawals
Withdrawals [(RewardAccount
ra, forall a. Monoid a => a
mempty)]

  forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Mempool" forall a b. (a -> b) -> a -> b
$ do
    let
      submitFailingMempoolTx :: String
-> Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpM (LedgerSpec era) (Tx era)
submitFailingMempoolTx String
cause Tx era
tx NonEmpty (PredicateFailure (EraRule "LEDGER" era))
expectedFailures = do
        Globals
globals <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use forall era. Lens' (ImpTestState era) Globals
impGlobalsL
        NewEpochState era
nes <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use forall era. Lens' (ImpTestState era) (NewEpochState era)
impNESL
        SlotNo
slotNo <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use forall era. SimpleGetter (ImpTestState era) SlotNo
impLastTickG
        let
          mempoolEnv :: MempoolEnv era
mempoolEnv = forall era.
EraGov era =>
NewEpochState era -> SlotNo -> MempoolEnv era
mkMempoolEnv NewEpochState era
nes SlotNo
slotNo
          ls :: LedgerState era
ls = NewEpochState era
nes forall s a. s -> Getting a s a -> a
^. forall era. Lens' (NewEpochState era) (EpochState era)
nesEsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (EpochState era) (LedgerState era)
esLStateL
        Tx era
txFixed <- (Tx era
tx forall a b. a -> (a -> b) -> b
&) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall era. ImpTestEnv era -> Tx era -> ImpTestM era (Tx era)
iteFixup
        forall a t. (HasCallStack, ToExpr a) => a -> ImpM t ()
logToExpr Tx era
txFixed
        case forall era.
ApplyTx era =>
Globals
-> MempoolEnv era
-> MempoolState era
-> Tx era
-> Either (ApplyTxError era) (MempoolState era, Validated (Tx era))
applyTx Globals
globals MempoolEnv era
mempoolEnv LedgerState era
ls Tx era
txFixed of
          Left ApplyTxError era
err -> do
            ApplyTxError era
err forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
a -> a -> m ()
`shouldBe` forall era.
NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ApplyTxError era
ApplyTxError @era NonEmpty (PredicateFailure (EraRule "LEDGER" era))
expectedFailures
          Right (LedgerState era, Validated (Tx era))
_ ->
            forall (m :: * -> *) a. (HasCallStack, MonadIO m) => String -> m a
assertFailure forall a b. (a -> b) -> a -> b
$ String
"Expected failure due to " forall a. Semigroup a => a -> a -> a
<> String
cause forall a. Semigroup a => a -> a -> a
<> String
": " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Tx era
txFixed
        forall (f :: * -> *) a. Applicative f => a -> f a
pure Tx era
txFixed
      submitFailingMempoolTx_ :: String
-> Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpM (LedgerSpec era) ()
submitFailingMempoolTx_ String
c Tx era
t = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. String
-> Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpM (LedgerSpec era) (Tx era)
submitFailingMempoolTx String
c Tx era
t

    forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Duplicate transactions" forall a b. (a -> b) -> a -> b
$ do
      let
        newInput :: ImpM (LedgerSpec era) TxIn
newInput = do
          Addr
addr <- forall s (m :: * -> *) g.
(HasKeyPairs s, MonadState s m, HasStatefulGen g m, MonadGen m) =>
m Addr
freshKeyAddr_
          Coin
amount <- Integer -> Coin
Coin forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (g :: * -> *) a. (MonadGen g, Random a) => (a, a) -> g a
choose (Integer
2_000_000, Integer
8_000_000)
          forall era.
(ShelleyEraImp era, HasCallStack) =>
Addr -> Coin -> ImpTestM era TxIn
sendCoinTo Addr
addr Coin
amount

      [TxIn]
inputsCommon <- forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
5 ImpM (LedgerSpec era) TxIn
newInput
      [TxIn]
inputs1 <- forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
2 ImpM (LedgerSpec era) TxIn
newInput
      [TxIn]
inputs2 <- forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
3 ImpM (LedgerSpec era) TxIn
newInput

      Tx era
txFinal <-
        forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era (Tx era)
submitTx forall a b. (a -> b) -> a -> b
$
          forall era. EraTx era => TxBody era -> Tx era
mkBasicTx forall a b. (a -> b) -> a -> b
$
            forall era. EraTxBody era => TxBody era
mkBasicTxBody forall a b. a -> (a -> b) -> b
& forall era. EraTxBody era => Lens' (TxBody era) (Set TxIn)
inputsTxBodyL forall a s t. Monoid a => ASetter s t a a -> a -> s -> t
<>~ forall l. IsList l => [Item l] -> l
fromList ([TxIn]
inputsCommon forall a. Semigroup a => a -> a -> a
<> [TxIn]
inputs1)

      forall a t. NFData a => String -> ImpM t a -> ImpM t a
impAnn String
"Identical transaction" forall a b. (a -> b) -> a -> b
$ do
        forall era a. ImpTestM era a -> ImpTestM era a
withNoFixup forall a b. (a -> b) -> a -> b
$
          String
-> Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpM (LedgerSpec era) ()
submitFailingMempoolTx_ String
"duplicate transaction" Tx era
txFinal forall a b. (a -> b) -> a -> b
$
            forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Text -> ConwayLedgerPredFailure era
ConwayMempoolFailure forall a b. (a -> b) -> a -> b
$
              Text
"All inputs are spent. Transaction has probably already been included"

      forall a t. NFData a => String -> ImpM t a -> ImpM t a
impAnn String
"Overlapping transaction" forall a b. (a -> b) -> a -> b
$ do
        let txOverlap :: Tx era
txOverlap = forall era. EraTx era => TxBody era -> Tx era
mkBasicTx forall a b. (a -> b) -> a -> b
$ forall era. EraTxBody era => TxBody era
mkBasicTxBody forall a b. a -> (a -> b) -> b
& forall era. EraTxBody era => Lens' (TxBody era) (Set TxIn)
inputsTxBodyL forall a s t. Monoid a => ASetter s t a a -> a -> s -> t
<>~ forall l. IsList l => [Item l] -> l
fromList ([TxIn]
inputsCommon forall a. Semigroup a => a -> a -> a
<> [TxIn]
inputs2)
        String
-> Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpM (LedgerSpec era) ()
submitFailingMempoolTx_
          String
"overlapping transaction"
          Tx era
txOverlap
          [forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure forall a b. (a -> b) -> a -> b
$ forall era. Set TxIn -> ConwayUtxoPredFailure era
BadInputsUTxO forall a b. (a -> b) -> a -> b
$ forall l. IsList l => [Item l] -> l
fromList [TxIn]
inputsCommon]

    forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Unelected Committee voting" forall a b. (a -> b) -> a -> b
$ forall era. EraGov era => ImpTestM era () -> ImpTestM era ()
whenPostBootstrap forall a b. (a -> b) -> a -> b
$ do
      NonEmpty (Credential 'HotCommitteeRole)
_ <- forall era.
(HasCallStack, ConwayEraImp era) =>
ImpTestM era (NonEmpty (Credential 'HotCommitteeRole))
registerInitialCommittee
      Credential 'ColdCommitteeRole
ccCold <- forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
      EpochNo
curEpochNo <- forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall era. Lens' (NewEpochState era) EpochNo
nesELL
      let action :: GovAction era
action =
            forall era.
StrictMaybe (GovPurposeId 'CommitteePurpose era)
-> Set (Credential 'ColdCommitteeRole)
-> Map (Credential 'ColdCommitteeRole) EpochNo
-> UnitInterval
-> GovAction era
UpdateCommittee
              forall a. StrictMaybe a
SNothing
              forall a. Monoid a => a
mempty
              (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 forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
1)
      ProposalProcedure era
proposal <- forall era.
(ShelleyEraImp era, ConwayEraTxBody era) =>
GovAction era -> ImpTestM era (ProposalProcedure era)
mkProposal GovAction era
action
      forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era ()
submitTx_ forall a b. (a -> b) -> a -> b
$
        forall era. EraTx era => TxBody era -> Tx era
mkBasicTx (forall era. EraTxBody era => TxBody era
mkBasicTxBody forall a b. a -> (a -> b) -> b
& forall era.
ConwayEraTxBody era =>
Lens' (TxBody era) (OSet (ProposalProcedure era))
proposalProceduresTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ [ProposalProcedure era
proposal])
      Credential 'HotCommitteeRole
ccHot <- forall era.
(ShelleyEraImp era, ConwayEraTxCert era) =>
Credential 'ColdCommitteeRole
-> ImpTestM era (Credential 'HotCommitteeRole)
registerCommitteeHotKey Credential 'ColdCommitteeRole
ccCold
      GovActionId
govActionId <- do
        RewardAccount
rewardAccount <- forall era.
(HasCallStack, ShelleyEraImp era) =>
ImpTestM era RewardAccount
registerRewardAccount
        forall era.
(ShelleyEraImp era, ConwayEraTxBody era, ConwayEraGov era) =>
[(RewardAccount, Coin)] -> ImpTestM era GovActionId
submitTreasuryWithdrawals [(RewardAccount
rewardAccount, Integer -> Coin
Coin Integer
1)]

      let
        tx :: Tx era
tx =
          forall era. EraTx era => TxBody era -> Tx era
mkBasicTx forall a b. (a -> b) -> a -> b
$
            forall era. EraTxBody era => TxBody era
mkBasicTxBody
              forall a b. a -> (a -> b) -> b
& forall era.
ConwayEraTxBody era =>
Lens' (TxBody era) (VotingProcedures era)
votingProceduresTxBodyL
                forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall era.
Map Voter (Map GovActionId (VotingProcedure era))
-> VotingProcedures era
VotingProcedures
                  ( forall k a. k -> a -> Map k a
Map.singleton
                      (Credential 'HotCommitteeRole -> Voter
CommitteeVoter Credential 'HotCommitteeRole
ccHot)
                      (forall k a. k -> a -> Map k a
Map.singleton GovActionId
govActionId (forall era. Vote -> StrictMaybe Anchor -> VotingProcedure era
VotingProcedure Vote
VoteYes forall a. StrictMaybe a
SNothing))
                  )

      Tx era
txFixed <-
        String
-> Tx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpM (LedgerSpec era) (Tx era)
submitFailingMempoolTx String
"unallowed votes" Tx era
tx forall a b. (a -> b) -> a -> b
$
          forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Text -> ConwayLedgerPredFailure era
ConwayMempoolFailure forall a b. (a -> b) -> a -> b
$
            Text
"Unelected committee members are not allowed to cast votes: " forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (forall a. Show a => a -> String
show (forall (f :: * -> *) a. Applicative f => a -> f a
pure @[] Credential 'HotCommitteeRole
ccHot))

      -- The tx should pass all other rules
      forall era a. ImpTestM era a -> ImpTestM era a
withNoFixup forall a b. (a -> b) -> a -> b
$
        forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era ()
submitTx_ Tx era
txFixed