Skip to content
Open
Show file tree
Hide file tree
Changes from all commits
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
Original file line number Diff line number Diff line change
Expand Up @@ -20,4 +20,5 @@ spec = do
describe "AllegraImpSpec" . withEachEraVersion @era $
UtxowSpec.spec

instance EraSpecificSpec AllegraEra
instance EraSpecificSpec AllegraEra where
eraSpecificSpec = ShelleyImp.shelleyEraSpecificSpec
Original file line number Diff line number Diff line change
Expand Up @@ -16,6 +16,7 @@ import qualified Test.Cardano.Ledger.Alonzo.Imp.UtxowSpec as Utxow
import Test.Cardano.Ledger.Alonzo.ImpTest
import Test.Cardano.Ledger.Imp.Common
import qualified Test.Cardano.Ledger.Mary.Imp as MaryImp
import qualified Test.Cardano.Ledger.Shelley.Imp as ShelleyImp

spec ::
forall era.
Expand All @@ -40,4 +41,4 @@ alonzoEraSpecificSpec = do
Utxow.alonzoEraSpecificSpec

instance EraSpecificSpec AlonzoEra where
eraSpecificSpec = alonzoEraSpecificSpec
eraSpecificSpec = ShelleyImp.shelleyEraSpecificSpec >> alonzoEraSpecificSpec
Original file line number Diff line number Diff line change
Expand Up @@ -16,6 +16,7 @@ import qualified Test.Cardano.Ledger.Babbage.Imp.UtxosSpec as Utxos
import qualified Test.Cardano.Ledger.Babbage.Imp.UtxowSpec as Utxow
import Test.Cardano.Ledger.Babbage.ImpTest (BabbageEraImp)
import Test.Cardano.Ledger.Imp.Common
import qualified Test.Cardano.Ledger.Shelley.Imp as ShelleyImp

spec :: forall era. (BabbageEraImp era, EraSpecificSpec era) => Spec
spec = do
Expand All @@ -28,4 +29,5 @@ spec = do

instance EraSpecificSpec BabbageEra where
eraSpecificSpec =
AlonzoImp.alonzoEraSpecificSpec
ShelleyImp.shelleyEraSpecificSpec
>> AlonzoImp.alonzoEraSpecificSpec
Original file line number Diff line number Diff line change
Expand Up @@ -75,7 +75,6 @@ conwayEraSpecificSpec :: SpecWith (ImpInit (LedgerSpec ConwayEra))
conwayEraSpecificSpec = do
describe "Conway era specific Imp spec" $
describe "Certificates without deposits" $ do
describe "DELEG" Deleg.conwayEraSpecificSpec
describe "UTXO" Utxo.conwayEraSpecificSpec

instance EraSpecificSpec ConwayEra where
Expand Down
102 changes: 42 additions & 60 deletions eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/DelegSpec.hs
Original file line number Diff line number Diff line change
Expand Up @@ -10,7 +10,6 @@

module Test.Cardano.Ledger.Conway.Imp.DelegSpec (
spec,
conwayEraSpecificSpec,
) where

import Cardano.Ledger.Address (RewardAccount (..))
Expand Down Expand Up @@ -252,13 +251,12 @@ spec = do

describe "Delegate stake" $ do
it "Delegate registered stake credentials to registered pool" $ do
expectedDeposit <- getsNES $ nesEsL . curPParamsEpochStateL . ppKeyDepositL

cred <- KeyHashObj <$> freshKeyHash
regTxCert <- genRegTxCert cred
submitTx_ $
mkBasicTx mkBasicTxBody
& bodyTxL . certsTxBodyL
.~ [RegDepositTxCert cred expectedDeposit]
.~ [regTxCert]

poolKh <- freshKeyHash
registerPool poolKh
Expand All @@ -273,14 +271,26 @@ spec = do
it "Register and delegate in the same transaction" $ do
expectedDeposit <- getsNES $ nesEsL . curPParamsEpochStateL . ppKeyDepositL

poolKh <- freshKeyHash
registerPool poolKh
poolKh1 <- freshKeyHash
registerPool poolKh1
freshKeyHash >>= \kh -> do
submitTx_ $
mkBasicTx mkBasicTxBody
& bodyTxL . certsTxBodyL
.~ [RegDepositDelegTxCert (KeyHashObj kh) (DelegStake poolKh) expectedDeposit]
expectDelegatedToPool (KeyHashObj kh) poolKh
.~ [RegDepositDelegTxCert (KeyHashObj kh) (DelegStake poolKh1) expectedDeposit]
expectDelegatedToPool (KeyHashObj kh) poolKh1

poolKh2 <- freshKeyHash
registerPool poolKh2
cred <- KeyHashObj <$> freshKeyHash
regTxCert <- genRegTxCert cred
submitTx_ $
mkBasicTx mkBasicTxBody
& bodyTxL . certsTxBodyL
.~ [ regTxCert
, DelegTxCert cred (DelegStake poolKh2)
]
expectDelegatedToPool cred poolKh2

it "Delegate unregistered stake credentials" $ do
cred <- KeyHashObj <$> freshKeyHash
Expand All @@ -296,13 +306,12 @@ spec = do
expectNotRegistered cred

it "Delegate to unregistered pool" $ do
expectedDeposit <- getsNES $ nesEsL . curPParamsEpochStateL . ppKeyDepositL

cred <- KeyHashObj <$> freshKeyHash
regTxCert <- genRegTxCert cred
submitTx_ $
mkBasicTx mkBasicTxBody
& bodyTxL . certsTxBodyL
.~ [RegDepositTxCert cred expectedDeposit]
.~ [regTxCert]

poolKh <- freshKeyHash
submitFailingTx
Expand All @@ -315,15 +324,14 @@ spec = do
expectNotDelegatedToPool cred

it "Delegate already delegated credentials" $ do
expectedDeposit <- getsNES $ nesEsL . curPParamsEpochStateL . ppKeyDepositL

cred <- KeyHashObj <$> freshKeyHash
regTxCert <- genRegTxCert cred
poolKh <- freshKeyHash
registerPool poolKh
submitTx_ $
mkBasicTx mkBasicTxBody
& bodyTxL . certsTxBodyL
.~ [ RegDepositTxCert cred expectedDeposit
.~ [ regTxCert
, DelegTxCert cred (DelegStake poolKh)
]
expectDelegatedToPool cred poolKh
Expand Down Expand Up @@ -687,13 +695,30 @@ spec = do
expectDelegatedToPool cred poolKh'
expectDelegatedVote cred (DRepCredential drepCred)
where
expectNotRegistered :: Credential 'Staking -> ImpTestM era ()
expectRegistered :: HasCallStack => Credential 'Staking -> ImpTestM era ()
expectRegistered cred = do
accounts <- getsNES $ nesEsL . esLStateL . lsCertStateL . certDStateL . accountsL
expectedDeposit <- getsNES $ nesEsL . curPParamsEpochStateL . ppKeyDepositL

accountState <- expectJust $ lookupAccountState cred accounts
impAnn (show cred <> " expected to be in Accounts with the correct deposit") $ do
accountState ^. depositAccountStateL `shouldBe` compactCoinOrError expectedDeposit

expectNotRegistered :: HasCallStack => Credential 'Staking -> ImpTestM era ()
expectNotRegistered cred = do
accounts <- getsNES $ nesEsL . esLStateL . lsCertStateL . certDStateL . accountsL
impAnn (show cred <> " expected to not be in Accounts") $ do
expectNothingExpr $ lookupAccountState cred accounts

expectNotDelegatedToPool :: Credential 'Staking -> ImpTestM era ()
expectDelegatedToPool ::
HasCallStack => Credential 'Staking -> KeyHash 'StakePool -> ImpTestM era ()
expectDelegatedToPool cred poolKh = do
accounts <- getsNES $ nesEsL . esLStateL . lsCertStateL . certDStateL . accountsL
impAnn (show cred <> " expected to have delegated to " <> show poolKh) $ do
accountState <- expectJust $ lookupAccountState cred accounts
accountState ^. stakePoolDelegationAccountStateL `shouldBe` Just poolKh

expectNotDelegatedToPool :: HasCallStack => Credential 'Staking -> ImpTestM era ()
expectNotDelegatedToPool cred = do
accounts <- getsNES $ nesEsL . esLStateL . lsCertStateL . certDStateL . accountsL
impAnn (show cred <> " expected to not have delegated to a stake pool") $ do
Expand All @@ -720,51 +745,8 @@ spec = do
(cred `Set.member` drepDelegs drepState)
_ -> pure ()

expectNotDelegatedVote :: Credential 'Staking -> ImpTestM era ()
expectNotDelegatedVote :: HasCallStack => Credential 'Staking -> ImpTestM era ()
expectNotDelegatedVote cred = do
accounts <- getsNES $ nesEsL . esLStateL . lsCertStateL . certDStateL . accountsL
impAnn (show cred <> " expected to not have their vote delegated") $
expectNothingExpr (lookupDRepDelegation cred accounts)

conwayEraSpecificSpec :: SpecWith (ImpInit (LedgerSpec ConwayEra))
conwayEraSpecificSpec = do
describe "Delegate stake" $ do
it "Register and delegate in the same transaction" $ do
cred1 <- KeyHashObj <$> freshKeyHash
regTxCert1 <- genRegTxCert cred1
poolKh <- freshKeyHash
registerPool poolKh
submitTx_ $
mkBasicTx mkBasicTxBody
& bodyTxL . certsTxBodyL
.~ [ regTxCert1
, DelegTxCert cred1 (DelegStake poolKh)
]
expectDelegatedToPool cred1 poolKh

cred2 <- KeyHashObj <$> freshKeyHash
regTxCert2 <- genRegTxCert cred2
submitTx_ $
mkBasicTx mkBasicTxBody
& bodyTxL . certsTxBodyL
.~ [ regTxCert2
, DelegStakeTxCert cred2 poolKh -- using the pattern from Shelley
]
expectDelegatedToPool cred2 poolKh

expectRegistered :: (HasCallStack, ConwayEraImp era) => Credential 'Staking -> ImpTestM era ()
expectRegistered cred = do
accounts <- getsNES $ nesEsL . esLStateL . lsCertStateL . certDStateL . accountsL
expectedDeposit <- getsNES $ nesEsL . curPParamsEpochStateL . ppKeyDepositL

accountState <- expectJust $ lookupAccountState cred accounts
impAnn (show cred <> " expected to be in Accounts with the correct deposit") $ do
accountState ^. depositAccountStateL `shouldBe` compactCoinOrError expectedDeposit

expectDelegatedToPool ::
(HasCallStack, ConwayEraImp era) => Credential 'Staking -> KeyHash 'StakePool -> ImpTestM era ()
expectDelegatedToPool cred poolKh = do
accounts <- getsNES $ nesEsL . esLStateL . lsCertStateL . certDStateL . accountsL
impAnn (show cred <> " expected to have delegated to " <> show poolKh) $ do
accountState <- expectJust $ lookupAccountState cred accounts
accountState ^. stakePoolDelegationAccountStateL `shouldBe` Just poolKh
4 changes: 3 additions & 1 deletion eras/mary/impl/testlib/Test/Cardano/Ledger/Mary/Imp.hs
Original file line number Diff line number Diff line change
Expand Up @@ -13,6 +13,7 @@ import qualified Test.Cardano.Ledger.Allegra.Imp as AllegraImp
import Test.Cardano.Ledger.Imp.Common
import qualified Test.Cardano.Ledger.Mary.Imp.UtxoSpec as Utxo
import Test.Cardano.Ledger.Mary.ImpTest
import qualified Test.Cardano.Ledger.Shelley.Imp as ShelleyImp

spec :: forall era. (MaryEraImp era, EraSpecificSpec era) => Spec
spec = do
Expand All @@ -21,4 +22,5 @@ spec = do
withEachEraVersion @era $
Utxo.spec

instance EraSpecificSpec MaryEra
instance EraSpecificSpec MaryEra where
eraSpecificSpec = ShelleyImp.shelleyEraSpecificSpec
1 change: 1 addition & 0 deletions eras/shelley/impl/cardano-ledger-shelley.cabal
Original file line number Diff line number Diff line change
Expand Up @@ -146,6 +146,7 @@ library testlib
Test.Cardano.Ledger.Shelley.Era
Test.Cardano.Ledger.Shelley.Examples
Test.Cardano.Ledger.Shelley.Imp
Test.Cardano.Ledger.Shelley.Imp.DelegSpec
Test.Cardano.Ledger.Shelley.Imp.EpochSpec
Test.Cardano.Ledger.Shelley.Imp.LedgerSpec
Test.Cardano.Ledger.Shelley.Imp.PoolSpec
Expand Down
26 changes: 24 additions & 2 deletions eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/Imp.hs
Original file line number Diff line number Diff line change
Expand Up @@ -5,10 +5,18 @@
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Test.Cardano.Ledger.Shelley.Imp (spec) where
module Test.Cardano.Ledger.Shelley.Imp (spec, shelleyEraSpecificSpec) where

import Cardano.Ledger.Shelley (ShelleyEra)
import Cardano.Ledger.Shelley.Rules (
ShelleyDelegPredFailure,
ShelleyPoolPredFailure,
ShelleyUtxoPredFailure,
ShelleyUtxowPredFailure,
)
import Cardano.Ledger.Shelley.TxCert (ShelleyEraTxCert)
import Test.Cardano.Ledger.Imp.Common
import qualified Test.Cardano.Ledger.Shelley.Imp.DelegSpec as Deleg
import qualified Test.Cardano.Ledger.Shelley.Imp.EpochSpec as Epoch
import qualified Test.Cardano.Ledger.Shelley.Imp.LedgerSpec as Ledger
import qualified Test.Cardano.Ledger.Shelley.Imp.PoolSpec as Pool
Expand All @@ -34,4 +42,18 @@ spec = do
describe "ShelleyPureTests" $ do
Instant.spec @era

instance EraSpecificSpec ShelleyEra
shelleyEraSpecificSpec ::
forall era.
( ShelleyEraImp era
, ShelleyEraTxCert era
, InjectRuleFailure "LEDGER" ShelleyDelegPredFailure era
, InjectRuleFailure "LEDGER" ShelleyPoolPredFailure era
) =>
SpecWith (ImpInit (LedgerSpec era))
shelleyEraSpecificSpec = do
describe "Shelley era specific Imp spec" $
describe "Certificates without deposits" $
Deleg.shelleyEraSpecificSpec

instance EraSpecificSpec ShelleyEra where
eraSpecificSpec = shelleyEraSpecificSpec
Loading
Loading