{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Test.Cardano.Ledger.Dijkstra.Imp.CertSpec (spec) where

import Cardano.Ledger.BaseTypes
import Cardano.Ledger.Conway.Governance (Voter (..))
import Cardano.Ledger.Conway.Rules (ConwayDelegPredFailure (..))
import Cardano.Ledger.Credential (Credential (..))
import Cardano.Ledger.Dijkstra.Core
import Cardano.Ledger.Dijkstra.Rules
import qualified Data.Sequence.Strict as SSeq
import qualified Data.Set as Set
import Lens.Micro ((&), (.~))
import Test.Cardano.Ledger.Dijkstra.ImpTest
import Test.Cardano.Ledger.Imp.Common

spec :: forall era. DijkstraEraImp era => SpecWith (ImpInit (LedgerSpec era))
spec :: forall era.
DijkstraEraImp 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
"CERT" (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
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Subtransaction consumes correct refund after keyDeposit is changed" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
    stakingCred <- KeyHash Staking -> Credential Staking
forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj (KeyHash Staking -> Credential Staking)
-> ImpM (LedgerSpec era) (KeyHash Staking)
-> ImpM (LedgerSpec era) (Credential Staking)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ImpM (LedgerSpec era) (KeyHash Staking)
forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
    _ <- registerStakeCredential stakingCred

    initialKeyDeposit <- getsPParams ppKeyDepositL
    let newKeyDeposit = Coin
initialKeyDeposit Coin -> Coin -> Coin
forall a. Semigroup a => a -> a -> a
<> Coin
initialKeyDeposit
    impAnn "Change key deposit" $ do
      (dRep, _, _) <- setupSingleDRep 100_000_000
      ccHotCreds <- registerInitialCommittee
      ppChangeId <-
        submitParameterChange SNothing $
          emptyPParamsUpdate
            & ppuKeyDepositL .~ SJust newKeyDeposit
      submitYesVote_ (DRepVoter dRep) ppChangeId
      submitYesVoteCCs_ ccHotCreds ppChangeId
      getsPParams ppKeyDepositL `shouldReturn` initialKeyDeposit
      passNEpochs 2
      getsPParams ppKeyDepositL `shouldReturn` newKeyDeposit

    impAnn "Unregister staking credential" $ do
      let
        unregTxWithRefund Coin
refund =
          [Tx SubTx era] -> Tx TopTx era
forall era. DijkstraEraImp era => [Tx SubTx era] -> Tx TopTx era
mkTopTxWithSubTxs
            [ TxBody SubTx era -> Tx SubTx era
forall era (l :: TxLevel). EraTx era => TxBody l era -> Tx l era
forall (l :: TxLevel). TxBody l era -> Tx l era
mkBasicTx TxBody SubTx era
forall era (l :: TxLevel).
(EraTxBody era, Typeable l) =>
TxBody l era
forall (l :: TxLevel). Typeable l => TxBody l era
mkBasicTxBody
                Tx SubTx era -> (Tx SubTx era -> Tx SubTx era) -> Tx SubTx era
forall a b. a -> (a -> b) -> b
& (TxBody SubTx era -> Identity (TxBody SubTx era))
-> Tx SubTx era -> Identity (Tx SubTx era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l era) (TxBody l era)
bodyTxL ((TxBody SubTx era -> Identity (TxBody SubTx era))
 -> Tx SubTx era -> Identity (Tx SubTx era))
-> ((StrictSeq (TxCert era) -> Identity (StrictSeq (TxCert era)))
    -> TxBody SubTx era -> Identity (TxBody SubTx era))
-> (StrictSeq (TxCert era) -> Identity (StrictSeq (TxCert era)))
-> Tx SubTx era
-> Identity (Tx SubTx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictSeq (TxCert era) -> Identity (StrictSeq (TxCert era)))
-> TxBody SubTx era -> Identity (TxBody SubTx era)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (StrictSeq (TxCert era))
forall (l :: TxLevel).
Lens' (TxBody l era) (StrictSeq (TxCert era))
certsTxBodyL ((StrictSeq (TxCert era) -> Identity (StrictSeq (TxCert era)))
 -> Tx SubTx era -> Identity (Tx SubTx era))
-> StrictSeq (TxCert era) -> Tx SubTx era -> Tx SubTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ TxCert era -> StrictSeq (TxCert era)
forall a. a -> StrictSeq a
SSeq.singleton (Credential Staking -> Coin -> TxCert era
forall era.
ConwayEraTxCert era =>
Credential Staking -> Coin -> TxCert era
UnRegDepositTxCert Credential Staking
stakingCred Coin
refund)
            ]

      -- the refund has to match the deposit that was actually paid at registration,
      -- not the key deposit currently in the protocol parameters
      submitFailingTx
        (unregTxWithRefund newKeyDeposit)
        [ injectFailure . DijkstraSubDelegPredFailure $
            RefundIncorrectDELEG (Mismatch newKeyDeposit initialKeyDeposit)
        ]

      submitTx_ $ unregTxWithRefund initialKeyDeposit
      expectStakeCredNotRegistered stakingCred

  String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Two sub-transactions cannot unregister the same credential" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
    stakingCred <- KeyHash Staking -> Credential Staking
forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj (KeyHash Staking -> Credential Staking)
-> ImpM (LedgerSpec era) (KeyHash Staking)
-> ImpM (LedgerSpec era) (Credential Staking)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ImpM (LedgerSpec era) (KeyHash Staking)
forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
    _ <- registerStakeCredential stakingCred
    keyDeposit <- getsPParams ppKeyDepositL
    (_, addr1) <- freshKeyAddr
    input1 <- sendCoinTo addr1 mempty
    (_, addr2) <- freshKeyAddr
    input2 <- sendCoinTo addr2 mempty
    let
      subTx1 =
        TxBody SubTx era -> Tx SubTx era
forall era (l :: TxLevel). EraTx era => TxBody l era -> Tx l era
forall (l :: TxLevel). TxBody l era -> Tx l era
mkBasicTx TxBody SubTx era
forall era (l :: TxLevel).
(EraTxBody era, Typeable l) =>
TxBody l era
forall (l :: TxLevel). Typeable l => TxBody l era
mkBasicTxBody
          Tx SubTx era -> (Tx SubTx era -> Tx SubTx era) -> Tx SubTx era
forall a b. a -> (a -> b) -> b
& (TxBody SubTx era -> Identity (TxBody SubTx era))
-> Tx SubTx era -> Identity (Tx SubTx era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l era) (TxBody l era)
bodyTxL ((TxBody SubTx era -> Identity (TxBody SubTx era))
 -> Tx SubTx era -> Identity (Tx SubTx era))
-> ((Set TxIn -> Identity (Set TxIn))
    -> TxBody SubTx era -> Identity (TxBody SubTx era))
-> (Set TxIn -> Identity (Set TxIn))
-> Tx SubTx era
-> Identity (Tx SubTx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set TxIn -> Identity (Set TxIn))
-> TxBody SubTx era -> Identity (TxBody SubTx era)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (Set TxIn)
forall (l :: TxLevel). Lens' (TxBody l era) (Set TxIn)
inputsTxBodyL ((Set TxIn -> Identity (Set TxIn))
 -> Tx SubTx era -> Identity (Tx SubTx era))
-> Set TxIn -> Tx SubTx era -> Tx SubTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ TxIn -> Set TxIn
forall a. a -> Set a
Set.singleton TxIn
input1
          Tx SubTx era -> (Tx SubTx era -> Tx SubTx era) -> Tx SubTx era
forall a b. a -> (a -> b) -> b
& (TxBody SubTx era -> Identity (TxBody SubTx era))
-> Tx SubTx era -> Identity (Tx SubTx era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l era) (TxBody l era)
bodyTxL ((TxBody SubTx era -> Identity (TxBody SubTx era))
 -> Tx SubTx era -> Identity (Tx SubTx era))
-> ((StrictSeq (TxCert era) -> Identity (StrictSeq (TxCert era)))
    -> TxBody SubTx era -> Identity (TxBody SubTx era))
-> (StrictSeq (TxCert era) -> Identity (StrictSeq (TxCert era)))
-> Tx SubTx era
-> Identity (Tx SubTx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictSeq (TxCert era) -> Identity (StrictSeq (TxCert era)))
-> TxBody SubTx era -> Identity (TxBody SubTx era)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (StrictSeq (TxCert era))
forall (l :: TxLevel).
Lens' (TxBody l era) (StrictSeq (TxCert era))
certsTxBodyL ((StrictSeq (TxCert era) -> Identity (StrictSeq (TxCert era)))
 -> Tx SubTx era -> Identity (Tx SubTx era))
-> StrictSeq (TxCert era) -> Tx SubTx era -> Tx SubTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Credential Staking -> Coin -> TxCert era
forall era.
ConwayEraTxCert era =>
Credential Staking -> Coin -> TxCert era
UnRegDepositTxCert Credential Staking
stakingCred Coin
keyDeposit]
      subTx2 =
        TxBody SubTx era -> Tx SubTx era
forall era (l :: TxLevel). EraTx era => TxBody l era -> Tx l era
forall (l :: TxLevel). TxBody l era -> Tx l era
mkBasicTx TxBody SubTx era
forall era (l :: TxLevel).
(EraTxBody era, Typeable l) =>
TxBody l era
forall (l :: TxLevel). Typeable l => TxBody l era
mkBasicTxBody
          Tx SubTx era -> (Tx SubTx era -> Tx SubTx era) -> Tx SubTx era
forall a b. a -> (a -> b) -> b
& (TxBody SubTx era -> Identity (TxBody SubTx era))
-> Tx SubTx era -> Identity (Tx SubTx era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l era) (TxBody l era)
bodyTxL ((TxBody SubTx era -> Identity (TxBody SubTx era))
 -> Tx SubTx era -> Identity (Tx SubTx era))
-> ((Set TxIn -> Identity (Set TxIn))
    -> TxBody SubTx era -> Identity (TxBody SubTx era))
-> (Set TxIn -> Identity (Set TxIn))
-> Tx SubTx era
-> Identity (Tx SubTx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set TxIn -> Identity (Set TxIn))
-> TxBody SubTx era -> Identity (TxBody SubTx era)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (Set TxIn)
forall (l :: TxLevel). Lens' (TxBody l era) (Set TxIn)
inputsTxBodyL ((Set TxIn -> Identity (Set TxIn))
 -> Tx SubTx era -> Identity (Tx SubTx era))
-> Set TxIn -> Tx SubTx era -> Tx SubTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ TxIn -> Set TxIn
forall a. a -> Set a
Set.singleton TxIn
input2
          Tx SubTx era -> (Tx SubTx era -> Tx SubTx era) -> Tx SubTx era
forall a b. a -> (a -> b) -> b
& (TxBody SubTx era -> Identity (TxBody SubTx era))
-> Tx SubTx era -> Identity (Tx SubTx era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l era) (TxBody l era)
bodyTxL ((TxBody SubTx era -> Identity (TxBody SubTx era))
 -> Tx SubTx era -> Identity (Tx SubTx era))
-> ((StrictSeq (TxCert era) -> Identity (StrictSeq (TxCert era)))
    -> TxBody SubTx era -> Identity (TxBody SubTx era))
-> (StrictSeq (TxCert era) -> Identity (StrictSeq (TxCert era)))
-> Tx SubTx era
-> Identity (Tx SubTx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictSeq (TxCert era) -> Identity (StrictSeq (TxCert era)))
-> TxBody SubTx era -> Identity (TxBody SubTx era)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (StrictSeq (TxCert era))
forall (l :: TxLevel).
Lens' (TxBody l era) (StrictSeq (TxCert era))
certsTxBodyL ((StrictSeq (TxCert era) -> Identity (StrictSeq (TxCert era)))
 -> Tx SubTx era -> Identity (Tx SubTx era))
-> StrictSeq (TxCert era) -> Tx SubTx era -> Tx SubTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Credential Staking -> Coin -> TxCert era
forall era.
ConwayEraTxCert era =>
Credential Staking -> Coin -> TxCert era
UnRegDepositTxCert Credential Staking
stakingCred Coin
keyDeposit]
    submitFailingTx
      (mkTopTxWithSubTxs [subTx1, subTx2])
      [injectFailure $ DijkstraSubDelegPredFailure $ StakeKeyNotRegisteredDELEG stakingCred]