diff --git a/lib/integration/framework/Test/Integration/Framework/DSL.hs b/lib/integration/framework/Test/Integration/Framework/DSL.hs index af9eeb04125..7b0a9ea034d 100644 --- a/lib/integration/framework/Test/Integration/Framework/DSL.hs +++ b/lib/integration/framework/Test/Integration/Framework/DSL.hs @@ -197,6 +197,7 @@ module Test.Integration.Framework.DSL , notDelegating , delegating , onlyVoting + , votingAndDelegating , getSlotParams , arbitraryStake @@ -235,6 +236,7 @@ module Test.Integration.Framework.DSL , listLimitedTransactions , noConway , noBabbage + , babbageOrConway ) where import Prelude @@ -3522,10 +3524,9 @@ delegating pidActive nexts = (notDelegating nexts) { active = ApiWalletDelegationNext Delegating (Just pidActive) Nothing Nothing } --- this one will be revisited when I add voting and delegation together. Now only voting onlyVoting :: ApiT DRep - -- ^ Pool joined + -- ^ voting -> [(Maybe (ApiT PoolId), EpochInfo)] -- ^ Pools to be joined & epoch at which the new delegation will become active -> ApiWalletDelegation @@ -3533,6 +3534,18 @@ onlyVoting drep nexts = (notDelegating nexts) { active = ApiWalletDelegationNext Voting Nothing (Just drep) Nothing } +votingAndDelegating + :: ApiT PoolId + -- ^ Pool joined + -> ApiT DRep + -- ^ voting + -> [(Maybe (ApiT PoolId), EpochInfo)] + -- ^ Pools to be joined & epoch at which the new delegation will become active + -> ApiWalletDelegation +votingAndDelegating pidActive drep nexts = (notDelegating nexts) + { active = ApiWalletDelegationNext VotingAndDelegating (Just pidActive) (Just drep) Nothing + } + getRetirementEpoch :: StakePool -> Maybe EpochNo getRetirementEpoch = fmap (view #epochNumber) . view #retirement @@ -3602,3 +3615,9 @@ noBabbage :: MonadIO m => Context -> String -> m () noBabbage ctx reason = liftIO $ do when (_mainEra ctx == ApiBabbage) $ pendingWith $ "BABBAGE is not supported: " <> reason + +babbageOrConway :: Context -> a -> a -> a +babbageOrConway ctx valBabbage valConway = + case _mainEra ctx of + ApiBabbage -> valBabbage + _ -> valConway diff --git a/lib/integration/scenarios/Test/Integration/Scenario/API/Shelley/StakePools.hs b/lib/integration/scenarios/Test/Integration/Scenario/API/Shelley/StakePools.hs index 6c4390de4ef..0a95a309680 100644 --- a/lib/integration/scenarios/Test/Integration/Scenario/API/Shelley/StakePools.hs +++ b/lib/integration/scenarios/Test/Integration/Scenario/API/Shelley/StakePools.hs @@ -71,6 +71,9 @@ import Cardano.Wallet.Primitive.Types import Cardano.Wallet.Primitive.Types.Coin ( Coin (..) ) +import Cardano.Wallet.Primitive.Types.DRep + ( DRep (..) + ) import Cardano.Wallet.Primitive.Types.Tx.Constraints ( TxSize (..) ) @@ -152,6 +155,7 @@ import Test.Integration.Framework.DSL ( Headers (..) , Payload (..) , arbitraryStake + , babbageOrConway , bracketSettings , decodeErrorInfo , delegating @@ -193,6 +197,7 @@ import Test.Integration.Framework.DSL , verify , verifyMaintenanceAction , verifyMetadataSource + , votingAndDelegating , waitForEpoch , waitForNextEpoch , waitForTxImmutability @@ -399,6 +404,7 @@ spec = describe "SHELLEY_STAKE_POOLS" $ do ] -- Listing stake keys shows + let delegStatus = babbageOrConway ctx Delegating VotingAndDelegating request @(ApiStakeKeys n) ctx (Link.listStakeKeys src) Default Empty >>= flip verify @@ -410,7 +416,7 @@ spec = describe "SHELLEY_STAKE_POOLS" $ do (acc ^. #_stake) .> ApiAmount 0 acc ^. (#_delegation . #active . #status) - `shouldBe` Delegating + `shouldBe` delegStatus acc ^. (#_delegation . #active . #target) `shouldBe` (Just (ApiT pool)) @@ -709,12 +715,13 @@ spec = describe "SHELLEY_STAKE_POOLS" $ do waitForTxStatus ctx w InLedger . getResponse =<< joinStakePool @n ctx (SpecificPool pool1) (w, fixturePassphrase) + let delegStatus = babbageOrConway ctx Delegating VotingAndDelegating request @ApiWallet ctx (Link.getWallet @'Shelley w) Default Empty >>= flip verify [ expectField (#delegation . #next) $ \case [dlg] -> do - (dlg ^. #status) `shouldBe` Delegating + (dlg ^. #status) `shouldBe` delegStatus (dlg ^. #target) `shouldBe` Just (ApiT pool1) (view #epochNumber <$> dlg ^. #changesAt) `shouldSatisfy` ( \x -> @@ -736,10 +743,14 @@ spec = describe "SHELLEY_STAKE_POOLS" $ do -- Epoch A+2: stake is active, rewards start accumulating. waitNumberOfEpochBoundaries 2 ctx + let deleg pool = babbageOrConway ctx + (delegating (ApiT pool) []) + (votingAndDelegating (ApiT pool) (ApiT Abstain) []) + request @ApiWallet ctx (Link.getWallet @'Shelley w) Default Empty >>= flip verify - [expectField #delegation (`shouldBe` delegating (ApiT pool1) [])] + [expectField #delegation (`shouldBe` deleg pool1)] -- join another stake pool waitForTxStatus ctx w InLedger . getResponse @@ -751,7 +762,7 @@ spec = describe "SHELLEY_STAKE_POOLS" $ do request @ApiWallet ctx (Link.getWallet @'Shelley w) Default Empty >>= flip verify - [expectField #delegation (`shouldBe` delegating (ApiT pool2) [])] + [expectField #delegation (`shouldBe` deleg pool2)] it "STAKE_POOLS_JOIN_04 - Rewards accumulate" $ \ctx -> runResourceT $ do w <- fixtureWallet ctx @@ -986,10 +997,14 @@ spec = describe "SHELLEY_STAKE_POOLS" $ do waitNumberOfEpochBoundaries 2 ctx + let deleg = babbageOrConway ctx + (delegating (ApiT pool1) []) + (votingAndDelegating (ApiT pool1) (ApiT Abstain) []) + request @ApiWallet ctx (Link.getWallet @'Shelley w) Default Empty >>= flip verify - [expectField #delegation (`shouldBe` delegating (ApiT pool1) [])] + [expectField #delegation (`shouldBe` deleg)] -- Cannot join the same pool liftIO @@ -1138,6 +1153,10 @@ spec = describe "SHELLEY_STAKE_POOLS" $ do -- Epoch A+2: stake is active, rewards start accumulating. waitNumberOfEpochBoundaries 2 ctx + let deleg = babbageOrConway ctx + (delegating (ApiT pool) []) + (votingAndDelegating (ApiT pool) (ApiT Abstain) []) + request @ApiWallet ctx (Link.getWallet @'Shelley w) @@ -1145,7 +1164,7 @@ spec = describe "SHELLEY_STAKE_POOLS" $ do Empty >>= flip verify - [ expectField #delegation (`shouldBe` delegating (ApiT pool) []) + [ expectField #delegation (`shouldBe` deleg) ] rQuit <- quitStakePool @n ctx (w, fixturePassphrase) @@ -1202,7 +1221,8 @@ spec = describe "SHELLEY_STAKE_POOLS" $ do "STAKE_POOLS_QUIT_01x - \ \I cannot quit if I have not enough to cover fees" $ \ctx -> runResourceT $ do - let initBalance = [costOfJoining ctx + depositAmt ctx] + let fuzz = costOf 50 ctx + let initBalance = [costOfJoining ctx + depositAmt ctx + fuzz] w <- fixtureWalletWith @n ctx initBalance pool : _ <- @@ -1225,6 +1245,10 @@ spec = describe "SHELLEY_STAKE_POOLS" $ do -- Epoch A+2: stake is active, rewards start accumulating. waitNumberOfEpochBoundaries 2 ctx + let deleg = babbageOrConway ctx + (delegating (ApiT pool) []) + (votingAndDelegating (ApiT pool) (ApiT Abstain) []) + request @ApiWallet ctx (Link.getWallet @'Shelley w) @@ -1232,7 +1256,7 @@ spec = describe "SHELLEY_STAKE_POOLS" $ do Empty >>= flip verify - [ expectField #delegation (`shouldBe` delegating (ApiT pool) []) + [ expectField #delegation (`shouldBe` deleg) ] response <- quitStakePool @n ctx (w, fixturePassphrase) diff --git a/lib/integration/scenarios/Test/Integration/Scenario/API/Voting.hs b/lib/integration/scenarios/Test/Integration/Scenario/API/Voting.hs index b221e3ebe2f..f871561f2fd 100644 --- a/lib/integration/scenarios/Test/Integration/Scenario/API/Voting.hs +++ b/lib/integration/scenarios/Test/Integration/Scenario/API/Voting.hs @@ -24,6 +24,7 @@ import Cardano.Wallet.Api.Types , ApiCertificate (..) , ApiConstructTransaction (..) , ApiDecodedTransaction + , ApiPoolSpecifier (..) , ApiSerialisedTransaction (..) , ApiT (..) , ApiTransaction @@ -50,6 +51,16 @@ import Control.Monad.Trans.Resource import Data.Aeson ( toJSON ) +import Data.Function + ( (&) + ) +import Data.Generics.Internal.VL.Lens + ( view + , (^.) + ) +import Numeric.Natural + ( Natural + ) import Test.Hspec ( SpecWith , describe @@ -64,22 +75,35 @@ import Test.Integration.Framework.DSL ( Context (..) , Headers (..) , Payload (..) + , counterexample + , delegating + , emptyWallet , eventually , expectField , expectResponseCode , expectSuccess + , fixturePassphrase , fixtureWallet , getFromResponse , getResponse + , joinStakePool , json + , listAddresses + , minUTxOValue , noBabbage , notDelegating + , notRetiringPools , onlyVoting + , quitStakePool , request , signTx , submitTxWithWid , verify + , votingAndDelegating + , waitForNextEpoch , waitNumberOfEpochBoundaries + , (.<) + , (.>) ) import qualified Cardano.Wallet.Api.Link as Link @@ -88,23 +112,101 @@ import qualified Network.HTTP.Types.Status as HTTP spec :: forall n. HasSNetworkId n => SpecWith Context spec = describe "VOTING_TRANSACTIONS" $ do - it "VOTING_01a - Can vote and revote" $ \ctx -> runResourceT $ do + it "VOTING_01a - Can vote and revote and then delegate" $ \ctx -> runResourceT $ do noBabbage ctx "voting supported in Conway onwards" src <- fixtureWallet ctx - let getSrcWallet = - let endpoint = Link.getWallet @'Shelley src - in request @ApiWallet ctx endpoint Default Empty - getSrcWallet >>= flip verify + let depositAmt = ApiAmount 1_000_000 + getSrcWallet ctx src >>= flip verify [ expectField #delegation (`shouldBe` notDelegating []) ] + -- voting and re-voting + _ <- voteAndRevote ctx src depositAmt + + -- quitting, ie. deregistrating the stake key + quit ctx src depositAmt + + -- voting and re-voting once again + voting2 <- voteAndRevote ctx src depositAmt + + --Second delegation + pool1 : _ : _ <- map (view #id) <$> notRetiringPools ctx + + let delegationJoin = Json [json|{ + "delegations": [{ + "join": { + "pool": #{ApiT pool1}, + "stake_key_index": "0H" + } + }] + }|] + rTx3 <- request @(ApiConstructTransaction n) ctx + (Link.createUnsignedTransaction @'Shelley src) Default delegationJoin + verify rTx3 + [ expectResponseCode HTTP.status202 + , expectField (#coinSelection . #depositsTaken) (`shouldBe` []) + , expectField (#coinSelection . #depositsReturned) (`shouldBe` []) + ] + + let ApiSerialisedTransaction apiTx3 _ = getFromResponse #transaction rTx3 + signedTx3 <- signTx ctx src apiTx3 [ expectResponseCode HTTP.status202 ] + + submittedTx3 <- submitTxWithWid ctx src signedTx3 + verify submittedTx3 + [ expectSuccess + , expectResponseCode HTTP.status202 + ] + + eventually "Wallet has joined pool and still voting" $ do + rJoin' <- request @(ApiTransaction n) ctx + (Link.getTransaction @'Shelley src + (getResponse submittedTx3)) + Default Empty + verify rJoin' + [ expectResponseCode HTTP.status200 + , expectField (#status . #getApiT) (`shouldBe` InLedger) + , expectField (#direction . #getApiT) (`shouldBe` Outgoing) + , expectField #depositTaken (`shouldBe` ApiAmount 0) + , expectField #depositReturned (`shouldBe` ApiAmount 0) + ] + + let txId3 = getFromResponse #id submittedTx3 + let link = Link.getTransaction @'Shelley src (ApiTxId txId3) + eventually "delegation transaction is in ledger" $ do + request @(ApiTransaction n) ctx link Default Empty + >>= flip verify + [ expectResponseCode HTTP.status200 + , expectField (#direction . #getApiT) (`shouldBe` Outgoing) + , expectField (#status . #getApiT) (`shouldBe` InLedger) + , expectField #metadata (`shouldBe` Nothing) + ] + + waitNumberOfEpochBoundaries 2 ctx + + eventually "Wallet is delegating to pool1 and voting abstain" $ do + getSrcWallet ctx src >>= flip verify + [ expectField #delegation (`shouldBe` votingAndDelegating (ApiT pool1) voting2 []) + ] + + it "VOTING_01b - Can vote and revote after delegation" $ \ctx -> runResourceT $ do + noBabbage ctx "voting supported in Conway onwards" + src <- fixtureWallet ctx + + pool1 : _pool2 : _ <- map (view #id) <$> notRetiringPools ctx let depositAmt = ApiAmount 1_000_000 - let voteNoConfidence = Json [json|{ - "vote": "no_confidence" + + --First delegating + let delegationJoin = Json [json|{ + "delegations": [{ + "join": { + "pool": #{ApiT pool1}, + "stake_key_index": "0H" + } + }] }|] rTx1 <- request @(ApiConstructTransaction n) ctx - (Link.createUnsignedTransaction @'Shelley src) Default voteNoConfidence + (Link.createUnsignedTransaction @'Shelley src) Default delegationJoin verify rTx1 [ expectResponseCode HTTP.status202 , expectField (#coinSelection . #depositsTaken) (`shouldBe` [depositAmt]) @@ -114,38 +216,272 @@ spec = describe "VOTING_TRANSACTIONS" $ do let ApiSerialisedTransaction apiTx1 _ = getFromResponse #transaction rTx1 signedTx1 <- signTx ctx src apiTx1 [ expectResponseCode HTTP.status202 ] - -- as we are joining for the first time we expect two certificates - let stakeKeyDerPath = NE.fromList - [ ApiT (DerivationIndex 2_147_485_500) - , ApiT (DerivationIndex 2_147_485_463) - , ApiT (DerivationIndex 2_147_483_648) - , ApiT (DerivationIndex 2) - , ApiT (DerivationIndex 0) + submittedTx1 <- submitTxWithWid ctx src signedTx1 + verify submittedTx1 + [ expectSuccess + , expectResponseCode HTTP.status202 + ] + + eventually "Wallet has joined pool and deposit info persists" $ do + rJoin' <- request @(ApiTransaction n) ctx + (Link.getTransaction @'Shelley src + (getResponse submittedTx1)) + Default Empty + verify rJoin' + [ expectResponseCode HTTP.status200 + , expectField (#status . #getApiT) (`shouldBe` InLedger) + , expectField (#direction . #getApiT) (`shouldBe` Outgoing) + , expectField #depositTaken (`shouldBe` depositAmt) + , expectField #depositReturned (`shouldBe` ApiAmount 0) + ] + + let txId1 = getFromResponse #id submittedTx1 + let link = Link.getTransaction @'Shelley src (ApiTxId txId1) + eventually "delegation transaction is in ledger" $ do + request @(ApiTransaction n) ctx link Default Empty + >>= flip verify + [ expectResponseCode HTTP.status200 + , expectField (#direction . #getApiT) (`shouldBe` Outgoing) + , expectField (#status . #getApiT) (`shouldBe` InLedger) + , expectField #metadata (`shouldBe` Nothing) ] - let registerStakeKeyCert = - WalletDelegationCertificate $ RegisterRewardAccount stakeKeyDerPath + + waitNumberOfEpochBoundaries 2 ctx + + eventually "Wallet is delegating to pool1" $ do + getSrcWallet ctx src >>= flip verify + [ expectField #delegation (`shouldBe` delegating (ApiT pool1) []) + ] + + -- we get rewards and try to withdraw + -- it works now but at some point in Conway it is expected to fail + -- as one will not be able to withdraw without voting. + dest <- emptyWallet ctx + waitForNextEpoch ctx + + walletBeforeWithdrawal <- getResponse <$> getSrcWallet ctx src + + addrs <- listAddresses @n ctx dest + let addr = (addrs !! 1) ^. #id + let withdrawalAmount = minUTxOValue (_mainEra ctx) + + waitNumberOfEpochBoundaries 4 ctx + + submittedWithdrawalTx <- do + let endpoint = Link.createTransactionOld @'Shelley src + request @(ApiTransaction n) ctx endpoint Default + $ Json [json| + { "payments": + [ { "address": #{addr} + , "amount": + { "quantity": #{withdrawalAmount} + , "unit": "lovelace" + } + } + ] + , "passphrase": #{fixturePassphrase}, + "withdrawal": "self" + }|] + + verify submittedWithdrawalTx + [ expectField #amount (.> ApiAmount withdrawalAmount) + , expectField (#direction . #getApiT) (`shouldBe` Outgoing) + ] + + eventually "Rewards have been consumed" $ do + getSrcWallet ctx src >>= flip verify + [ expectField (#balance . #reward . #toNatural) + (.< withdrawalAmount) + , expectField (#balance . #available) + (.> (walletBeforeWithdrawal ^. #balance . #available)) + ] & counterexample ("Wdrl: " <> show withdrawalAmount) + + --Now voting + let voteNoConfidence = Json [json|{ + "vote": "no_confidence" + }|] + rTx2 <- request @(ApiConstructTransaction n) ctx + (Link.createUnsignedTransaction @'Shelley src) Default voteNoConfidence + verify rTx2 + [ expectResponseCode HTTP.status202 + , expectField (#coinSelection . #depositsTaken) (`shouldBe` []) + , expectField (#coinSelection . #depositsReturned) (`shouldBe` []) + ] + let ApiSerialisedTransaction apiTx2 _ = getFromResponse #transaction rTx2 + signedTx2 <- signTx ctx src apiTx2 [ expectResponseCode HTTP.status202 ] + let voting1 = ApiT NoConfidence let votingCert1 = WalletDelegationCertificate $ CastVote stakeKeyDerPath voting1 + let decodePayload2 = Json (toJSON signedTx2) + rDecodedTx2 <- request @(ApiDecodedTransaction n) ctx + (Link.decodeTransaction @'Shelley src) Default decodePayload2 + verify rDecodedTx2 + [ expectResponseCode HTTP.status202 + , expectField #certificates (`shouldBe` [votingCert1]) + , expectField #depositsTaken (`shouldBe` []) + , expectField #depositsReturned (`shouldBe` []) + ] + submittedTx2 <- submitTxWithWid ctx src signedTx2 + verify submittedTx2 + [ expectSuccess + , expectResponseCode HTTP.status202 + ] + + eventually "Wallet has voted" $ do + rJoin' <- request @(ApiTransaction n) ctx + (Link.getTransaction @'Shelley src + (getResponse submittedTx2)) + Default Empty + verify rJoin' + [ expectResponseCode HTTP.status200 + , expectField (#status . #getApiT) (`shouldBe` InLedger) + , expectField (#direction . #getApiT) (`shouldBe` Outgoing) + , expectField #depositTaken (`shouldBe` ApiAmount 0) + , expectField #depositReturned (`shouldBe` ApiAmount 0) + ] + + let txId2 = getFromResponse #id submittedTx2 + let link2 = Link.getTransaction @'Shelley src (ApiTxId txId2) + eventually "Voting transaction is in ledger" $ do + request @(ApiTransaction n) ctx link2 Default Empty + >>= flip verify + [ expectResponseCode HTTP.status200 + , expectField (#direction . #getApiT) (`shouldBe` Outgoing) + , expectField (#status . #getApiT) (`shouldBe` InLedger) + ] + + waitNumberOfEpochBoundaries 2 ctx + + eventually "Wallet is both voting no confidence and delegating to pool1" $ do + getSrcWallet ctx src >>= flip verify + [ expectField #delegation + (`shouldBe` votingAndDelegating (ApiT pool1) voting1 []) + ] + + let voteAbstain = Json [json|{ + "vote": "abstain" + }|] + rTx3 <- request @(ApiConstructTransaction n) ctx + (Link.createUnsignedTransaction @'Shelley src) Default voteAbstain + verify rTx3 + [ expectResponseCode HTTP.status202 + , expectField (#coinSelection . #depositsTaken) (`shouldBe` []) + , expectField (#coinSelection . #depositsReturned) (`shouldBe` []) + ] + + let ApiSerialisedTransaction apiTx3 _ = getFromResponse #transaction rTx3 + signedTx3 <- signTx ctx src apiTx3 [ expectResponseCode HTTP.status202 ] + + let voting2 = ApiT Abstain + let votingCert2 = + WalletDelegationCertificate $ CastVote stakeKeyDerPath voting2 + + let decodePayload3 = Json (toJSON signedTx3) + rDecodedTx3 <- request @(ApiDecodedTransaction n) ctx + (Link.decodeTransaction @'Shelley src) Default decodePayload3 + verify rDecodedTx3 + [ expectResponseCode HTTP.status202 + , expectField #certificates (`shouldBe` [votingCert2]) + , expectField #depositsTaken (`shouldBe` []) + , expectField #depositsReturned (`shouldBe` []) + ] + + -- Submit tx + submittedTx3 <- submitTxWithWid ctx src signedTx3 + verify submittedTx3 + [ expectSuccess + , expectResponseCode HTTP.status202 + ] + + eventually "Wallet has voted again" $ do + rJoin' <- request @(ApiTransaction n) ctx + (Link.getTransaction @'Shelley src + (getResponse submittedTx3)) + Default Empty + verify rJoin' + [ expectResponseCode HTTP.status200 + , expectField (#status . #getApiT) (`shouldBe` InLedger) + , expectField (#direction . #getApiT) (`shouldBe` Outgoing) + , expectField #depositTaken (`shouldBe` ApiAmount 0) + , expectField #depositReturned (`shouldBe` ApiAmount 0) + ] + + let txId3 = getFromResponse #id submittedTx3 + let link3 = Link.getTransaction @'Shelley src (ApiTxId txId3) + eventually "Re-voting transaction is in ledger" $ do + request @(ApiTransaction n) ctx link3 Default Empty + >>= flip verify + [ expectResponseCode HTTP.status200 + , expectField (#direction . #getApiT) (`shouldBe` Outgoing) + , expectField (#status . #getApiT) (`shouldBe` InLedger) + ] + + waitNumberOfEpochBoundaries 2 ctx + + eventually "Wallet is both voting abstain and delegating to pool1" $ do + getSrcWallet ctx src >>= flip verify + [ expectField #delegation + (`shouldBe` votingAndDelegating (ApiT pool1) voting2 []) + ] + + it "VOTING_01c - Can vote together with delegation" $ \ctx -> runResourceT $ do + noBabbage ctx "voting supported in Conway onwards" + src <- fixtureWallet ctx + + pool1 : pool2 : _ <- map (view #id) <$> notRetiringPools ctx + let depositAmt = ApiAmount 1_000_000 + getSrcWallet ctx src >>= flip verify + [ expectField #delegation (`shouldBe` notDelegating []) + ] + + --First vote abstain and delegating to pool1 + let delegationJoinAbstain = Json [json|{ + "delegations": [{ + "join": { + "pool": #{ApiT pool1}, + "stake_key_index": "0H" + } + }], + "vote": "abstain" + }|] + rTx1 <- request @(ApiConstructTransaction n) ctx + (Link.createUnsignedTransaction @'Shelley src) Default delegationJoinAbstain + verify rTx1 + [ expectResponseCode HTTP.status202 + , expectField (#coinSelection . #depositsTaken) (`shouldBe` [depositAmt]) + , expectField (#coinSelection . #depositsReturned) (`shouldBe` []) + ] + + let ApiSerialisedTransaction apiTx1 _ = getFromResponse #transaction rTx1 + signedTx1 <- signTx ctx src apiTx1 [ expectResponseCode HTTP.status202 ] + + let voting1 = ApiT Abstain + let votingCert1 = + WalletDelegationCertificate $ CastVote stakeKeyDerPath voting1 + let registerStakeKeyCert = + WalletDelegationCertificate $ RegisterRewardAccount stakeKeyDerPath + let delegatingCert1 = + WalletDelegationCertificate $ JoinPool stakeKeyDerPath (ApiT pool1) + let decodePayload1 = Json (toJSON signedTx1) rDecodedTx1 <- request @(ApiDecodedTransaction n) ctx (Link.decodeTransaction @'Shelley src) Default decodePayload1 verify rDecodedTx1 [ expectResponseCode HTTP.status202 - , expectField #certificates (`shouldBe` [registerStakeKeyCert, votingCert1]) + , expectField #certificates (`shouldBe` [registerStakeKeyCert, delegatingCert1, votingCert1]) , expectField #depositsTaken (`shouldBe` [depositAmt]) , expectField #depositsReturned (`shouldBe` []) ] - -- Submit tx submittedTx1 <- submitTxWithWid ctx src signedTx1 verify submittedTx1 [ expectSuccess , expectResponseCode HTTP.status202 ] - eventually "Wallet has voted and deposit info persists" $ do + eventually "Wallet has joined pool 1, voted and deposit info persists" $ do rJoin' <- request @(ApiTransaction n) ctx (Link.getTransaction @'Shelley src (getResponse submittedTx1)) @@ -160,7 +496,7 @@ spec = describe "VOTING_TRANSACTIONS" $ do let txId1 = getFromResponse #id submittedTx1 let link1 = Link.getTransaction @'Shelley src (ApiTxId txId1) - eventually "Voting transaction is in ledger" $ do + eventually "delegation transaction is in ledger" $ do request @(ApiTransaction n) ctx link1 Default Empty >>= flip verify [ expectResponseCode HTTP.status200 @@ -171,16 +507,23 @@ spec = describe "VOTING_TRANSACTIONS" $ do waitNumberOfEpochBoundaries 2 ctx - eventually "Wallet is voting no confidence" $ do - getSrcWallet >>= flip verify - [ expectField #delegation (`shouldBe` onlyVoting voting1 []) + eventually "Wallet is delegating to pool1 and voting abstain" $ do + getSrcWallet ctx src >>= flip verify + [ expectField #delegation (`shouldBe` votingAndDelegating (ApiT pool1) voting1 []) ] - let voteAbstain = Json [json|{ - "vote": "abstain" + --Second vote no confidence and delegating to pool2 + let delegationJoinNoConfidence = Json [json|{ + "delegations": [{ + "join": { + "pool": #{ApiT pool2}, + "stake_key_index": "0H" + } + }], + "vote": "no_confidence" }|] rTx2 <- request @(ApiConstructTransaction n) ctx - (Link.createUnsignedTransaction @'Shelley src) Default voteAbstain + (Link.createUnsignedTransaction @'Shelley src) Default delegationJoinNoConfidence verify rTx2 [ expectResponseCode HTTP.status202 , expectField (#coinSelection . #depositsTaken) (`shouldBe` []) @@ -190,32 +533,32 @@ spec = describe "VOTING_TRANSACTIONS" $ do let ApiSerialisedTransaction apiTx2 _ = getFromResponse #transaction rTx2 signedTx2 <- signTx ctx src apiTx2 [ expectResponseCode HTTP.status202 ] - let voting2 = ApiT Abstain + let voting2 = ApiT NoConfidence let votingCert2 = WalletDelegationCertificate $ CastVote stakeKeyDerPath voting2 + let delegatingCert2 = + WalletDelegationCertificate $ JoinPool stakeKeyDerPath (ApiT pool2) let decodePayload2 = Json (toJSON signedTx2) rDecodedTx2 <- request @(ApiDecodedTransaction n) ctx (Link.decodeTransaction @'Shelley src) Default decodePayload2 verify rDecodedTx2 [ expectResponseCode HTTP.status202 - , expectField #certificates (`shouldBe` [votingCert2]) + , expectField #certificates (`shouldBe` [delegatingCert2, votingCert2]) , expectField #depositsTaken (`shouldBe` []) , expectField #depositsReturned (`shouldBe` []) ] - -- Submit tx submittedTx2 <- submitTxWithWid ctx src signedTx2 verify submittedTx2 [ expectSuccess , expectResponseCode HTTP.status202 ] - eventually "Wallet has voted again" $ do + eventually "Wallet has joined pool 2 and re-voted" $ do rJoin' <- request @(ApiTransaction n) ctx (Link.getTransaction @'Shelley src - (getResponse submittedTx2)) - Default Empty + (getResponse submittedTx2)) Default Empty verify rJoin' [ expectResponseCode HTTP.status200 , expectField (#status . #getApiT) (`shouldBe` InLedger) @@ -226,7 +569,7 @@ spec = describe "VOTING_TRANSACTIONS" $ do let txId2 = getFromResponse #id submittedTx2 let link2 = Link.getTransaction @'Shelley src (ApiTxId txId2) - eventually "Re-voting transaction is in ledger" $ do + eventually "delegation transaction is in ledger" $ do request @(ApiTransaction n) ctx link2 Default Empty >>= flip verify [ expectResponseCode HTTP.status200 @@ -237,7 +580,415 @@ spec = describe "VOTING_TRANSACTIONS" $ do waitNumberOfEpochBoundaries 2 ctx - eventually "Wallet is voting abstain" $ do - getSrcWallet >>= flip verify - [ expectField #delegation (`shouldBe` onlyVoting voting2 []) + eventually "Wallet is delegating to pool2 and voting no confidence" $ do + getSrcWallet ctx src >>= flip verify + [ expectField #delegation (`shouldBe` votingAndDelegating (ApiT pool2) voting2 []) ] + + -- we get rewards + dest <- emptyWallet ctx + waitForNextEpoch ctx + + walletBeforeWithdrawal <- getResponse <$> getSrcWallet ctx src + + addrs <- listAddresses @n ctx dest + let addr = (addrs !! 1) ^. #id + let withdrawalAmount = minUTxOValue (_mainEra ctx) + + submittedWithdrawalTx <- do + let endpoint = Link.createTransactionOld @'Shelley src + request @(ApiTransaction n) ctx endpoint Default + $ Json [json| + { "payments": + [ { "address": #{addr} + , "amount": + { "quantity": #{withdrawalAmount} + , "unit": "lovelace" + } + } + ] + , "passphrase": #{fixturePassphrase}, + "withdrawal": "self" + }|] + + verify submittedWithdrawalTx + [ expectField #amount (.> ApiAmount withdrawalAmount) + , expectField (#direction . #getApiT) (`shouldBe` Outgoing) + ] + + eventually "Rewards have been consumed" $ do + getSrcWallet ctx src >>= flip verify + [ expectField (#balance . #reward . #toNatural) + (.< withdrawalAmount) + , expectField (#balance . #available) + (.> (walletBeforeWithdrawal ^. #balance . #available)) + ] & counterexample ("Wdrl: " <> show withdrawalAmount) + + -- now we quit + quit ctx src depositAmt + + it "VOTING_01d - Can joinStakePool and quitStakePool" $ \ctx -> runResourceT $ do + noBabbage ctx "voting supported in Conway onwards" + + let depositAmt = ApiAmount 1_000_000 + src <- fixtureWallet ctx + dest <- emptyWallet ctx + pool1 : pool2 : _ <- map (view #id) <$> notRetiringPools ctx + + getSrcWallet ctx src >>= flip verify + [ expectField #delegation (`shouldBe` notDelegating []) + ] + + -- Join Pool 1 + rJoin1 <- joinStakePool @n ctx (SpecificPool pool1) (src, fixturePassphrase) + verify rJoin1 + [ expectResponseCode HTTP.status202 + , expectField (#status . #getApiT) (`shouldBe` Pending) + , expectField (#direction . #getApiT) (`shouldBe` Outgoing) + , expectField #depositTaken (`shouldBe` depositAmt) + ] + eventually "Wallet has joined pool and deposit info persists" $ do + let endpoint = Link.getTransaction @'Shelley src (getResponse rJoin1) + request @(ApiTransaction n) ctx endpoint Default Empty + >>= flip verify + [ expectResponseCode HTTP.status200 + , expectField (#status . #getApiT) (`shouldBe` InLedger) + , expectField (#direction . #getApiT) (`shouldBe` Outgoing) + , expectField #depositTaken (`shouldBe` depositAmt) + , expectField #depositReturned (`shouldBe` ApiAmount 0) + ] + + let txId1 = getFromResponse #id rJoin1 + let link1 = Link.getTransaction @'Shelley src (ApiTxId txId1) + eventually "delegation transaction is in ledger" $ do + rSrc <- request @(ApiTransaction n) ctx link1 Default Empty + verify rSrc + [ expectResponseCode HTTP.status200 + , expectField (#direction . #getApiT) (`shouldBe` Outgoing) + , expectField (#status . #getApiT) (`shouldBe` InLedger) + , expectField #metadata (`shouldBe` Nothing) + , expectField #depositTaken (`shouldBe` depositAmt) + , expectField #depositReturned (`shouldBe` ApiAmount 0) + ] + + let voting = ApiT Abstain + eventually "Wallet is delegating to pool1 and voting abstain" $ do + getSrcWallet ctx src >>= flip verify + [ expectField #delegation (`shouldBe` votingAndDelegating (ApiT pool1) voting []) + ] + + -- Join Pool 2 + rJoin2 <- joinStakePool @n ctx (SpecificPool pool2) (src, fixturePassphrase) + verify + rJoin2 + [ expectResponseCode HTTP.status202 + , expectField (#status . #getApiT) (`shouldBe` Pending) + , expectField (#direction . #getApiT) (`shouldBe` Outgoing) + , expectField #depositTaken (`shouldBe` ApiAmount 0) + ] + eventually "Wallet has joined pool" $ do + let endpoint = Link.getTransaction @'Shelley src (getResponse rJoin2) + request @(ApiTransaction n) ctx endpoint Default Empty + >>= flip verify + [ expectResponseCode HTTP.status200 + , expectField (#status . #getApiT) (`shouldBe` InLedger) + , expectField (#direction . #getApiT) (`shouldBe` Outgoing) + , expectField #depositTaken (`shouldBe` ApiAmount 0) + , expectField #depositReturned (`shouldBe` ApiAmount 0) + ] + + let txId2 = getFromResponse #id rJoin2 + let link2 = Link.getTransaction @'Shelley src (ApiTxId txId2) + eventually "delegation transaction is in ledger" $ do + rSrc <- request @(ApiTransaction n) ctx link2 Default Empty + verify rSrc + [ expectResponseCode HTTP.status200 + , expectField (#direction . #getApiT) (`shouldBe` Outgoing) + , expectField (#status . #getApiT) (`shouldBe` InLedger) + , expectField #metadata (`shouldBe` Nothing) + , expectField #depositTaken (`shouldBe` ApiAmount 0) + , expectField #depositReturned (`shouldBe` ApiAmount 0) + ] + + -- Epoch A: delegation tx is in the ledger. + -- Epoch A+1: stake is registered to a chosen pool. + -- Epoch A+2: stake is active, rewards start accumulating. + -- Epoch A+3: rewards from epoch A+2 are calculated. + -- Epoch A+4: rewards from epoch A+2 are paid out. + waitNumberOfEpochBoundaries 4 ctx + + previousBalance <- eventually "Wallet gets rewards" $ do + let endpoint = Link.getWallet @'Shelley src + r <- request @ApiWallet ctx endpoint Default Empty + verify r [expectField (#balance . #reward) (.> ApiAmount 0)] + pure $ getFromResponse (#balance . #available) r + + -- can use rewards with an explicit withdrawal request to self. + addrs <- listAddresses @n ctx dest + let coin = minUTxOValue (_mainEra ctx) :: Natural + let addr = (addrs !! 1) ^. #id + let payloadWithdrawal = [json| + { "payments": + [ { "address": #{addr} + , "amount": + { "quantity": #{coin} + , "unit": "lovelace" + } + } + ] + , "passphrase": #{fixturePassphrase}, + "withdrawal": "self" + }|] + + waitForNextEpoch ctx + rTx2 <- request @(ApiTransaction n) + ctx + (Link.createTransactionOld @'Shelley src) + Default + (Json payloadWithdrawal) + verify rTx2 + [ expectField (#direction . #getApiT) (`shouldBe` Outgoing) + ] + + -- Rewards are have been consumed. + eventually "Wallet has consumed rewards" $ do + request @ApiWallet ctx (Link.getWallet @'Shelley src) Default Empty + >>= flip verify + [ expectField + (#balance . #reward) + (`shouldBe` (ApiAmount 0)) + , expectField + (#balance . #available) + (.> previousBalance) + ] + + -- Quit delegation . + rQuit <- quitStakePool @n ctx (src, fixturePassphrase) + verify rQuit + [ expectResponseCode HTTP.status202 + , expectField (#status . #getApiT) (`shouldBe` Pending) + , expectField (#direction . #getApiT) (`shouldBe` Incoming) + , expectField #depositTaken (`shouldBe` ApiAmount 0) + , expectField #depositReturned (`shouldBe` depositAmt) + ] + let txid2 = getFromResponse Prelude.id rQuit + + eventually "Certificates are inserted after quitting a pool" $ do + let epg = Link.getTransaction @'Shelley src txid2 + rlg <- request @(ApiTransaction n) ctx epg Default Empty + verify rlg + [ expectField + (#direction . #getApiT) + (`shouldBe` Incoming) + , expectField + (#status . #getApiT) + (`shouldBe` InLedger) + , expectField #depositTaken (`shouldBe` ApiAmount 0) + , expectField #depositReturned (`shouldBe` depositAmt) + ] + + eventually "Wallet is neither delegating nor voting" $ do + getSrcWallet ctx src >>= flip verify + [ expectField #delegation (`shouldBe` notDelegating []) ] + where + stakeKeyDerPath = NE.fromList + [ ApiT (DerivationIndex 2_147_485_500) + , ApiT (DerivationIndex 2_147_485_463) + , ApiT (DerivationIndex 2_147_483_648) + , ApiT (DerivationIndex 2) + , ApiT (DerivationIndex 0) + ] + + getSrcWallet ctx wal = + let endpoint = Link.getWallet @'Shelley wal + in request @ApiWallet ctx endpoint Default Empty + + quit ctx wal depositAmt = do + -- quitting, ie. deregistrating the stake key + let delegationQuit = Json [json|{ + "delegations": [{ + "quit": { + "stake_key_index": "0H" + } + }] + }|] + rTx <- request @(ApiConstructTransaction n) ctx + (Link.createUnsignedTransaction @'Shelley wal) Default delegationQuit + verify rTx + [ expectResponseCode HTTP.status202 + , expectField (#coinSelection . #depositsTaken) (`shouldBe` []) + , expectField (#coinSelection . #depositsReturned) (`shouldBe` [depositAmt]) + ] + let ApiSerialisedTransaction apiTx _ = getFromResponse #transaction rTx + signedTx <- signTx ctx wal apiTx [ expectResponseCode HTTP.status202 ] + let quittingCert = + WalletDelegationCertificate $ QuitPool stakeKeyDerPath + + let decodePayload = Json (toJSON signedTx) + rDecodedTx <- request @(ApiDecodedTransaction n) ctx + (Link.decodeTransaction @'Shelley wal) Default decodePayload + verify rDecodedTx + [ expectResponseCode HTTP.status202 + , expectField #certificates (`shouldBe` [quittingCert]) + , expectField #depositsReturned (`shouldBe` [depositAmt]) + , expectField #depositsTaken (`shouldBe` []) + ] + submittedTx <- submitTxWithWid ctx wal signedTx + verify submittedTx + [ expectSuccess + , expectResponseCode HTTP.status202 + ] + + let txid = getFromResponse #id submittedTx + let queryTx = Link.getTransaction @'Shelley wal (ApiTxId txid) + request @(ApiTransaction n) ctx queryTx Default Empty + >>= flip verify + [ expectResponseCode HTTP.status200 + , expectField #depositTaken (`shouldBe` ApiAmount 0) + , expectField #depositReturned (`shouldBe` depositAmt) + ] + + waitNumberOfEpochBoundaries 2 ctx + + eventually "Wallet is neither delegating nor voting" $ do + getSrcWallet ctx wal >>= flip verify + [ expectField #delegation (`shouldBe` notDelegating []) ] + + voteAndRevote ctx wal depositAmt = do + -- First voting + let voteNoConfidence = Json [json|{ + "vote": "no_confidence" + }|] + rTx1 <- request @(ApiConstructTransaction n) ctx + (Link.createUnsignedTransaction @'Shelley wal) Default voteNoConfidence + verify rTx1 + [ expectResponseCode HTTP.status202 + , expectField (#coinSelection . #depositsTaken) (`shouldBe` [depositAmt]) + , expectField (#coinSelection . #depositsReturned) (`shouldBe` []) + ] + + let ApiSerialisedTransaction apiTx1 _ = getFromResponse #transaction rTx1 + signedTx1 <- signTx ctx wal apiTx1 [ expectResponseCode HTTP.status202 ] + + -- as we are joining for the first time we expect two certificates + let registerStakeKeyCert = + WalletDelegationCertificate $ RegisterRewardAccount stakeKeyDerPath + let voting1 = ApiT NoConfidence + let votingCert1 = + WalletDelegationCertificate $ CastVote stakeKeyDerPath voting1 + + let decodePayload1 = Json (toJSON signedTx1) + rDecodedTx1 <- request @(ApiDecodedTransaction n) ctx + (Link.decodeTransaction @'Shelley wal) Default decodePayload1 + verify rDecodedTx1 + [ expectResponseCode HTTP.status202 + , expectField #certificates (`shouldBe` [registerStakeKeyCert, votingCert1]) + , expectField #depositsTaken (`shouldBe` [depositAmt]) + , expectField #depositsReturned (`shouldBe` []) + ] + + -- Submit tx + submittedTx1 <- submitTxWithWid ctx wal signedTx1 + verify submittedTx1 + [ expectSuccess + , expectResponseCode HTTP.status202 + ] + + eventually "Wallet has voted and deposit info persists" $ do + rJoin' <- request @(ApiTransaction n) ctx + (Link.getTransaction @'Shelley wal + (getResponse submittedTx1)) + Default Empty + verify rJoin' + [ expectResponseCode HTTP.status200 + , expectField (#status . #getApiT) (`shouldBe` InLedger) + , expectField (#direction . #getApiT) (`shouldBe` Outgoing) + , expectField #depositTaken (`shouldBe` depositAmt) + , expectField #depositReturned (`shouldBe` ApiAmount 0) + ] + + let txId1 = getFromResponse #id submittedTx1 + let link1 = Link.getTransaction @'Shelley wal (ApiTxId txId1) + eventually "Voting transaction is in ledger" $ do + request @(ApiTransaction n) ctx link1 Default Empty + >>= flip verify + [ expectResponseCode HTTP.status200 + , expectField (#direction . #getApiT) (`shouldBe` Outgoing) + , expectField (#status . #getApiT) (`shouldBe` InLedger) + , expectField #metadata (`shouldBe` Nothing) + ] + + waitNumberOfEpochBoundaries 2 ctx + + eventually "Wallet is voting no confidence" $ do + getSrcWallet ctx wal >>= flip verify + [ expectField #delegation (`shouldBe` onlyVoting voting1 []) + ] + + let voteAbstain = Json [json|{ + "vote": "abstain" + }|] + rTx2 <- request @(ApiConstructTransaction n) ctx + (Link.createUnsignedTransaction @'Shelley wal) Default voteAbstain + verify rTx2 + [ expectResponseCode HTTP.status202 + , expectField (#coinSelection . #depositsTaken) (`shouldBe` []) + , expectField (#coinSelection . #depositsReturned) (`shouldBe` []) + ] + + let ApiSerialisedTransaction apiTx2 _ = getFromResponse #transaction rTx2 + signedTx2 <- signTx ctx wal apiTx2 [ expectResponseCode HTTP.status202 ] + + let voting2 = ApiT Abstain + let votingCert2 = + WalletDelegationCertificate $ CastVote stakeKeyDerPath voting2 + + let decodePayload2 = Json (toJSON signedTx2) + rDecodedTx2 <- request @(ApiDecodedTransaction n) ctx + (Link.decodeTransaction @'Shelley wal) Default decodePayload2 + verify rDecodedTx2 + [ expectResponseCode HTTP.status202 + , expectField #certificates (`shouldBe` [votingCert2]) + , expectField #depositsTaken (`shouldBe` []) + , expectField #depositsReturned (`shouldBe` []) + ] + + -- Submit tx + submittedTx2 <- submitTxWithWid ctx wal signedTx2 + verify submittedTx2 + [ expectSuccess + , expectResponseCode HTTP.status202 + ] + + eventually "Wallet has voted again" $ do + rJoin' <- request @(ApiTransaction n) ctx + (Link.getTransaction @'Shelley wal + (getResponse submittedTx2)) + Default Empty + verify rJoin' + [ expectResponseCode HTTP.status200 + , expectField (#status . #getApiT) (`shouldBe` InLedger) + , expectField (#direction . #getApiT) (`shouldBe` Outgoing) + , expectField #depositTaken (`shouldBe` ApiAmount 0) + , expectField #depositReturned (`shouldBe` ApiAmount 0) + ] + + let txId2 = getFromResponse #id submittedTx2 + let link2 = Link.getTransaction @'Shelley wal (ApiTxId txId2) + eventually "Re-voting transaction is in ledger" $ do + request @(ApiTransaction n) ctx link2 Default Empty + >>= flip verify + [ expectResponseCode HTTP.status200 + , expectField (#direction . #getApiT) (`shouldBe` Outgoing) + , expectField (#status . #getApiT) (`shouldBe` InLedger) + , expectField #metadata (`shouldBe` Nothing) + ] + + waitNumberOfEpochBoundaries 2 ctx + + eventually "Wallet is voting abstain" $ do + getSrcWallet ctx wal >>= flip verify + [ expectField #delegation (`shouldBe` onlyVoting voting2 []) + ] + + return voting2 diff --git a/lib/unit/test/unit/Cardano/Wallet/DelegationSpec.hs b/lib/unit/test/unit/Cardano/Wallet/DelegationSpec.hs index b2d81a49a7a..84fb72c87c4 100644 --- a/lib/unit/test/unit/Cardano/Wallet/DelegationSpec.hs +++ b/lib/unit/test/unit/Cardano/Wallet/DelegationSpec.hs @@ -139,26 +139,26 @@ spec = describe "Cardano.Wallet.DelegationSpec" $ do `shouldBe` Left (W.ErrNoSuchPool pidUnknown) it "Cannot quit when active: not_delegating, next = []" $ do let dlg = WalletDelegation {active = NotDelegating, next = []} - WD.guardQuit dlg NoWithdrawal (Coin 0) + WD.guardQuit dlg NoWithdrawal (Coin 0) False `shouldBe` Left (W.ErrNotDelegatingOrAboutTo) it "Cannot quit when active: A, next = [not_delegating]" $ do let next1 = WalletDelegationNext (EpochNo 1) NotDelegating let dlg = WalletDelegation {active = Delegating pidA, next = [next1]} - WD.guardQuit dlg NoWithdrawal (Coin 0) + WD.guardQuit dlg NoWithdrawal (Coin 0) False `shouldBe` Left (W.ErrNotDelegatingOrAboutTo) it "Cannot quit when active: A, next = [B, not_delegating]" $ do let next1 = WalletDelegationNext (EpochNo 1) (Delegating pidB) let next2 = WalletDelegationNext (EpochNo 2) NotDelegating let dlg = WalletDelegation {active = Delegating pidA, next = [next1, next2]} - WD.guardQuit dlg NoWithdrawal (Coin 0) + WD.guardQuit dlg NoWithdrawal (Coin 0) False `shouldBe` Left (W.ErrNotDelegatingOrAboutTo) it "Can quit when active: not_delegating, next = [A]" $ do let next1 = WalletDelegationNext (EpochNo 1) (Delegating pidA) let dlg = WalletDelegation {active = NotDelegating, next = [next1]} - WD.guardQuit dlg NoWithdrawal (Coin 0) `shouldBe` Right () + WD.guardQuit dlg NoWithdrawal (Coin 0) False `shouldBe` Right () where pidA = PoolId "A" pidB = PoolId "B" @@ -192,7 +192,7 @@ prop_guardJoinQuit knownPoolsList dlg pid wdrl mRetirementInfo = checkCoverage label "ErrNoSuchPool" $ property True Left W.ErrAlreadyDelegating{} -> label "ErrAlreadyDelegating" - (WD.guardQuit dlg wdrl (Coin 0) === Right ()) + (WD.guardQuit dlg wdrl (Coin 0) False === Right ()) where knownPools = Set.fromList knownPoolsList retirementNotPlanned = @@ -215,7 +215,7 @@ prop_guardQuitJoin prop_guardQuitJoin (NonEmpty knownPoolsList) dlg rewards wdrl = let knownPools = Set.fromList knownPoolsList in let noRetirementPlanned = Nothing in - case WD.guardQuit dlg wdrl (Coin.fromWord64 rewards) of + case WD.guardQuit dlg wdrl (Coin.fromWord64 rewards) False of Right () -> label "I can quit" $ property True Left W.ErrNotDelegatingOrAboutTo -> diff --git a/lib/wallet/api/http/Cardano/Wallet/Api/Http/Shelley/Server.hs b/lib/wallet/api/http/Cardano/Wallet/Api/Http/Shelley/Server.hs index 52716de79f6..415930565fa 100644 --- a/lib/wallet/api/http/Cardano/Wallet/Api/Http/Shelley/Server.hs +++ b/lib/wallet/api/http/Cardano/Wallet/Api/Http/Shelley/Server.hs @@ -897,7 +897,7 @@ import qualified Cardano.Wallet.Api.Types.Amount as ApiAmount import qualified Cardano.Wallet.Api.Types.WalletAssets as ApiWalletAssets import qualified Cardano.Wallet.DB as W import qualified Cardano.Wallet.Delegation as WD -import qualified Cardano.Wallet.IO.Delegation +import qualified Cardano.Wallet.IO.Delegation as IODeleg import qualified Cardano.Wallet.Network as NW import qualified Cardano.Wallet.Primitive.Ledger.Convert as Convert import qualified Cardano.Wallet.Primitive.Types as W @@ -2144,7 +2144,7 @@ selectCoinsForJoin ctx knownPools getPoolStatus poolId walletId = do poolStatus <- liftIO $ getPoolStatus poolId pools <- liftIO knownPools withWorkerCtx ctx walletId liftE liftE $ \workerCtx -> liftIO $ do - W.CoinSelection{..} <- Cardano.Wallet.IO.Delegation.selectCoinsForJoin + W.CoinSelection{..} <- IODeleg.selectCoinsForJoin workerCtx pools poolId @@ -2177,7 +2177,7 @@ selectCoinsForQuit selectCoinsForQuit ctx (ApiT walletId) = do withWorkerCtx ctx walletId liftE liftE $ \workerCtx -> liftIO $ do W.CoinSelection{..} <- - Cardano.Wallet.IO.Delegation.selectCoinsForQuit workerCtx + IODeleg.selectCoinsForQuit workerCtx pure ApiCoinSelection { inputs = mkApiCoinSelectionInput <$> inputs , outputs = mkApiCoinSelectionOutput <$> outputs @@ -2736,7 +2736,7 @@ constructTransaction api argGenChange knownPools poolStatus apiWalletId body = d currentEpochSlotting <- liftIO $ getCurrentEpochSlotting netLayer optionalDelegationAction <- liftIO $ forM delegationRequest $ - Cardano.Wallet.IO.Delegation.handleDelegationRequest + IODeleg.handleDelegationRequest wrk currentEpochSlotting knownPools poolStatus withdrawal @@ -2744,7 +2744,7 @@ constructTransaction api argGenChange knownPools poolStatus apiWalletId body = d optionalVoteAction <- case (body ^. #vote) of Just (ApiT action) -> liftIO $ Just <$> - Cardano.Wallet.IO.Delegation.voteAction wrk action + IODeleg.voteAction wrk action Nothing -> pure Nothing @@ -3286,13 +3286,13 @@ constructSharedTransaction optionalDelegationAction <- liftIO $ forM delegationRequest $ - Cardano.Wallet.IO.Delegation.handleDelegationRequest + IODeleg.handleDelegationRequest wrk currentEpochSlotting knownPools getPoolStatus NoWithdrawal optionalVoteAction <- case (body ^. #vote) of Just (ApiT action) -> liftIO $ Just <$> - Cardano.Wallet.IO.Delegation.voteAction wrk action + IODeleg.voteAction wrk action Nothing -> pure Nothing let txCtx = defaultTransactionCtx @@ -3961,7 +3961,7 @@ joinStakePool withWorkerCtx ctx walletId liftE liftE $ \wrk -> do (BuiltTx{..}, txTime) <- liftIO - $ Cardano.Wallet.IO.Delegation.joinStakePool + $ IODeleg.joinStakePool wrk walletId pools @@ -4025,7 +4025,7 @@ quitStakePool ctx@ApiLayer{..} (ApiT walletId) body = do withWorkerCtx ctx walletId liftE liftE $ \wrk -> do (BuiltTx{..}, txTime) <- liftIO - $ Cardano.Wallet.IO.Delegation.quitStakePool + $ IODeleg.quitStakePool wrk walletId (coerce $ getApiT $ body ^. #passphrase) diff --git a/lib/wallet/src/Cardano/Wallet/Delegation.hs b/lib/wallet/src/Cardano/Wallet/Delegation.hs index e05f4529c3f..70e31b424cc 100644 --- a/lib/wallet/src/Cardano/Wallet/Delegation.hs +++ b/lib/wallet/src/Cardano/Wallet/Delegation.hs @@ -1,10 +1,10 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -Wno-redundant-constraints #-} + module Cardano.Wallet.Delegation ( joinStakePoolDelegationAction , guardJoin @@ -20,6 +20,7 @@ import qualified Cardano.Wallet.DB.WalletState as WalletState import qualified Cardano.Wallet.Primitive.Types as W import qualified Cardano.Wallet.Transaction as Tx import qualified Data.Set as Set +import qualified Internal.Cardano.Write.Tx as Write import Cardano.Pool.Types ( PoolId (..) @@ -40,6 +41,9 @@ import Cardano.Wallet.Primitive.Types import Cardano.Wallet.Primitive.Types.Coin ( Coin (..) ) +import Cardano.Wallet.Primitive.Types.DRep + ( DRep (..) + ) import Cardano.Wallet.Transaction ( ErrCannotJoin (..) , Withdrawal (..) @@ -49,7 +53,6 @@ import Control.Error ) import Control.Monad ( forM_ - , unless , when ) import Data.Generics.Internal.VL.Lens @@ -76,20 +79,31 @@ data DelegationRequest Join stake pool ------------------------------------------------------------------------------} joinStakePoolDelegationAction - :: WalletState.WalletState s + :: Write.IsRecentEra era + => Write.RecentEra era + -> WalletState.WalletState s -> CurrentEpochSlotting -> Set PoolId -> PoolId -> PoolLifeCycleStatus - -> Either ErrStakePoolDelegation Tx.DelegationAction + -> Either + ErrStakePoolDelegation + (Tx.DelegationAction, Maybe Tx.VotingAction) joinStakePoolDelegationAction - wallet currentEpochSlotting knownPools poolId poolStatus + era wallet currentEpochSlotting knownPools poolId poolStatus = case guardJoin knownPools delegation poolId retirementInfo of Left e -> Left $ ErrStakePoolJoin e - Right () -> Right $ - if stakeKeyIsRegistered - then Tx.Join poolId - else Tx.JoinRegisteringKey poolId + Right () -> Right + ( if stakeKeyIsRegistered + then Tx.Join poolId + else Tx.JoinRegisteringKey poolId + , case era of + Write.RecentEraBabbage -> Nothing + Write.RecentEraConway -> Just $ + if stakeKeyIsRegistered + then Tx.Vote Abstain + else Tx.VoteRegisteringKey Abstain + ) where stakeKeyIsRegistered = Dlgs.isStakeKeyRegistered @@ -130,27 +144,36 @@ guardJoin knownPools delegation pid mRetirementEpochInfo = do -- | Given the state of the wallet, -- return a 'DelegationAction' for quitting the current stake pool. quitStakePoolDelegationAction - :: forall s - . WalletState.WalletState s + :: forall s. () + => WalletState.WalletState s -> Coin -- ^ Reward balance of the wallet -> CurrentEpochSlotting -> Withdrawal -> Either ErrStakePoolDelegation Tx.DelegationAction quitStakePoolDelegationAction wallet rewards currentEpochSlotting withdrawal = - case guardQuit delegation withdrawal rewards of + case guardQuit delegation withdrawal rewards voting of Left e -> Left $ ErrStakePoolQuit e Right () -> Right Tx.Quit where + voting = + Dlgs.isVoting + $ WalletState.delegations wallet delegation = Dlgs.readDelegation currentEpochSlotting $ WalletState.delegations wallet -guardQuit :: WalletDelegation -> Withdrawal -> Coin -> Either ErrCannotQuit () -guardQuit WalletDelegation{active,next} wdrl rewards = do +guardQuit + :: WalletDelegation + -> Withdrawal + -> Coin + -> Bool + -> Either ErrCannotQuit () +guardQuit WalletDelegation{active,next} wdrl rewards voting = do let last_ = maybe active (view #status) $ lastMay next let anyone _ = True - unless (isDelegatingTo anyone last_) $ Left ErrNotDelegatingOrAboutTo + when (not (isDelegatingTo anyone last_) && not voting) + $ Left ErrNotDelegatingOrAboutTo case wdrl of WithdrawalSelf {} -> Right () _ diff --git a/lib/wallet/src/Cardano/Wallet/IO/Delegation.hs b/lib/wallet/src/Cardano/Wallet/IO/Delegation.hs index cfc4417ad34..ddde0d18beb 100644 --- a/lib/wallet/src/Cardano/Wallet/IO/Delegation.hs +++ b/lib/wallet/src/Cardano/Wallet/IO/Delegation.hs @@ -144,7 +144,7 @@ handleDelegationRequest WD.Join poolId -> do poolStatus <- getPoolStatus poolId pools <- getKnownPools - joinStakePoolDelegationAction + fst <$> joinStakePoolDelegationAction ctx currentEpochSlotting pools @@ -199,7 +199,7 @@ selectCoinsForJoin ctx pools poolId poolStatus = do <- W.readNodeTipStateForTxWrite netLayer currentEpochSlotting <- W.getCurrentEpochSlotting netLayer - action <- joinStakePoolDelegationAction + (action, _) <- joinStakePoolDelegationAction ctx currentEpochSlotting pools @@ -293,7 +293,7 @@ joinStakePoolDelegationAction -> Set PoolId -> PoolId -> PoolLifeCycleStatus - -> IO Tx.DelegationAction + -> IO (Tx.DelegationAction, Maybe Tx.VotingAction) joinStakePoolDelegationAction ctx currentEpochSlotting knownPools poolId poolStatus = do @@ -305,8 +305,12 @@ joinStakePoolDelegationAction traceWith tr $ W.MsgWallet $ W.MsgIsStakeKeyRegistered stakeKeyIsRegistered + (Write.PParamsInAnyRecentEra era _, _) + <- W.readNodeTipStateForTxWrite netLayer + either (throwIO . ExceptionStakePoolDelegation) pure $ WD.joinStakePoolDelegationAction + era wallet currentEpochSlotting knownPools @@ -315,6 +319,7 @@ joinStakePoolDelegationAction where db = ctx ^. dbLayer tr = ctx ^. logger + netLayer = ctx ^. networkLayer -- | Send a transaction to the network where we join a stake pool. joinStakePool @@ -340,7 +345,7 @@ joinStakePool ctx wid pools poolId poolStatus passphrase = do pp <- currentProtocolParameters netLayer currentEpochSlotting <- W.getCurrentEpochSlotting netLayer - action <- + (delegation, votingM) <- joinStakePoolDelegationAction ctx currentEpochSlotting @@ -353,7 +358,8 @@ joinStakePool ctx wid pools poolId poolStatus passphrase = do defaultTransactionCtx { txWithdrawal = NoWithdrawal , txValidityInterval = (Nothing, ttl) - , txDelegationAction = Just action + , txDelegationAction = Just delegation + , txVotingAction = votingM , txDeposit = Just $ stakeKeyDeposit pp } diff --git a/lib/wallet/src/Cardano/Wallet/Shelley/Transaction.hs b/lib/wallet/src/Cardano/Wallet/Shelley/Transaction.hs index 97afa39263a..6d26015f482 100644 --- a/lib/wallet/src/Cardano/Wallet/Shelley/Transaction.hs +++ b/lib/wallet/src/Cardano/Wallet/Shelley/Transaction.hs @@ -767,7 +767,7 @@ mkUnsignedTransaction networkId stakeCred ctx selection = do , "either xpub or script when there is delegation" , "action" ] - let certs = L.nub $ votingCerts <> delegCerts + let certs = L.nub $ delegCerts <> votingCerts let payload = (view #txMetadata ctx, certs) constructUnsignedTx networkId payload ttl wdrl selection delta assetsToBeMinted assetsToBeBurned inpsScripts