change guardJoin along with tests

cardano-foundation · Apr 30, 2024 · c667050 · c667050
1 parent abafcdb
commit c667050
Show file tree

Hide file tree

Showing 6 changed files with 69 additions and 23 deletions.
diff --git a/lib/api/src/Cardano/Wallet/Api/Http/Server/Error.hs b/lib/api/src/Cardano/Wallet/Api/Http/Server/Error.hs
@@ -721,6 +721,13 @@ instance IsServerError ErrCannotJoin where
                 [ "I couldn't find any stake pool with the given id: "
                 , toText pid
                 ]
+        ErrAlreadyDelegatingVoting pid ->
+            apiError err403 PoolAlreadyJoined $ mconcat
+                [ "I couldn't join a stake pool with the given id: "
+                , toText pid
+                , " and vote. I have already joined this pool, also voted the same last time;"
+                , " joining/voting again would incur an unnecessary fee!"
+                ]
 
 instance IsServerError ErrCannotQuit where
     toServerError = \case

diff --git a/lib/api/src/Cardano/Wallet/Api/Http/Shelley/Server.hs b/lib/api/src/Cardano/Wallet/Api/Http/Shelley/Server.hs
@@ -2774,7 +2774,7 @@ constructTransaction api argGenChange knownPools poolStatus apiWalletId body = d
                 IODeleg.handleDelegationRequest
                     wrk
                     currentEpochSlotting knownPools
-                    poolStatus withdrawal
+                    poolStatus withdrawal votingSameAgain
 
         let transactionCtx0 = defaultTransactionCtx
                 { txWithdrawal = withdrawal
@@ -3323,7 +3323,7 @@ constructSharedTransaction
             forM delegationRequest $
                 IODeleg.handleDelegationRequest
                     wrk currentEpochSlotting knownPools
-                    getPoolStatus NoWithdrawal
+                    getPoolStatus NoWithdrawal votingSameAgain
 
         let txCtx = defaultTransactionCtx
                 { txWithdrawal = withdrawal

diff --git a/lib/unit/test/unit/Cardano/Wallet/DelegationSpec.hs b/lib/unit/test/unit/Cardano/Wallet/DelegationSpec.hs
@@ -126,49 +126,69 @@ spec = describe "Cardano.Wallet.DelegationSpec" $ do
     describe "Join/Quit Stake pool unit mockEventSource" $ do
         it "Cannot join A, when active = A in Babbage" $ do
             let dlg = WalletDelegation {active = Delegating pidA, next = []}
-            WD.guardJoin Write.RecentEraBabbage knownPools dlg pidA noRetirementPlanned
+            WD.guardJoin Write.RecentEraBabbage knownPools dlg pidA noRetirementPlanned False
                 `shouldBe` Left (W.ErrAlreadyDelegating pidA)
         it "Can rejoin A, when active = A in Conway" $ do
             let dlg = WalletDelegation {active = Delegating pidA, next = []}
-            WD.guardJoin Write.RecentEraConway knownPools dlg pidA noRetirementPlanned
+            WD.guardJoin Write.RecentEraConway knownPools dlg pidA noRetirementPlanned False
                 `shouldBe` Right ()
+        it "Cannot rejoin A, when active = A in Conway" $ do
+            let dlg = WalletDelegation {active = Delegating pidA, next = []}
+            WD.guardJoin Write.RecentEraConway knownPools dlg pidA noRetirementPlanned True
+                `shouldBe` Left (W.ErrAlreadyDelegatingVoting pidA)
         it "Cannot join A, when next = [A] in Babbage" $ do
             let next1 = WalletDelegationNext (EpochNo 1) (Delegating pidA)
             let dlg = WalletDelegation {active = NotDelegating, next = [next1]}
-            WD.guardJoin Write.RecentEraBabbage knownPools dlg pidA noRetirementPlanned
+            WD.guardJoin Write.RecentEraBabbage knownPools dlg pidA noRetirementPlanned False
                 `shouldBe` Left (W.ErrAlreadyDelegating pidA)
         it "Can join A, when next = [A] in Conway" $ do
             let next1 = WalletDelegationNext (EpochNo 1) (Delegating pidA)
             let dlg = WalletDelegation {active = NotDelegating, next = [next1]}
-            WD.guardJoin Write.RecentEraConway knownPools dlg pidA noRetirementPlanned
+            WD.guardJoin Write.RecentEraConway knownPools dlg pidA noRetirementPlanned False
                 `shouldBe` Right ()
+        it "Can join A, when next = [A] in Conway" $ do
+            let next1 = WalletDelegationNext (EpochNo 1) (Delegating pidA)
+            let dlg = WalletDelegation {active = NotDelegating, next = [next1]}
+            WD.guardJoin Write.RecentEraConway knownPools dlg pidA noRetirementPlanned True
+                `shouldBe` Left (W.ErrAlreadyDelegatingVoting pidA)
         it "Can join A, when active = A, next = [B] in any era" $ do
             let next1 = WalletDelegationNext (EpochNo 1) (Delegating pidB)
             let dlg = WalletDelegation
                     {active = Delegating pidA, next = [next1]}
-            WD.guardJoin Write.RecentEraBabbage knownPools dlg pidA noRetirementPlanned
+            WD.guardJoin Write.RecentEraBabbage knownPools dlg pidA noRetirementPlanned False
+                `shouldBe` Right ()
+            WD.guardJoin Write.RecentEraConway knownPools dlg pidA noRetirementPlanned False
                 `shouldBe` Right ()
-            WD.guardJoin Write.RecentEraConway knownPools dlg pidA noRetirementPlanned
+            WD.guardJoin Write.RecentEraConway knownPools dlg pidA noRetirementPlanned True
                 `shouldBe` Right ()
         it "Cannot join A, when active = A, next = [B, A] in Babbage" $ do
             let next1 = WalletDelegationNext (EpochNo 1) (Delegating pidB)
             let next2 = WalletDelegationNext (EpochNo 2) (Delegating pidA)
             let dlg = WalletDelegation
                     {active = Delegating pidA, next = [next1, next2]}
-            WD.guardJoin Write.RecentEraBabbage knownPools dlg pidA noRetirementPlanned
+            WD.guardJoin Write.RecentEraBabbage knownPools dlg pidA noRetirementPlanned False
                 `shouldBe` Left (W.ErrAlreadyDelegating pidA)
         it "Can join A, when active = A, next = [B, A] in Conway" $ do
             let next1 = WalletDelegationNext (EpochNo 1) (Delegating pidB)
             let next2 = WalletDelegationNext (EpochNo 2) (Delegating pidA)
             let dlg = WalletDelegation
                     {active = Delegating pidA, next = [next1, next2]}
-            WD.guardJoin Write.RecentEraConway knownPools dlg pidA noRetirementPlanned
+            WD.guardJoin Write.RecentEraConway knownPools dlg pidA noRetirementPlanned False
                 `shouldBe` Right ()
+        it "Cannot join A, when active = A, next = [B, A] in Conway" $ do
+            let next1 = WalletDelegationNext (EpochNo 1) (Delegating pidB)
+            let next2 = WalletDelegationNext (EpochNo 2) (Delegating pidA)
+            let dlg = WalletDelegation
+                    {active = Delegating pidA, next = [next1, next2]}
+            WD.guardJoin Write.RecentEraConway knownPools dlg pidA noRetirementPlanned True
+                `shouldBe` Left (W.ErrAlreadyDelegatingVoting pidA)
         it "Cannot join when pool is unknown in any era" $ do
             let dlg = WalletDelegation {active = NotDelegating, next = []}
-            WD.guardJoin Write.RecentEraBabbage knownPools dlg pidUnknown noRetirementPlanned
+            WD.guardJoin Write.RecentEraBabbage knownPools dlg pidUnknown noRetirementPlanned False
+                `shouldBe` Left (W.ErrNoSuchPool pidUnknown)
+            WD.guardJoin Write.RecentEraConway knownPools dlg pidUnknown noRetirementPlanned False
                 `shouldBe` Left (W.ErrNoSuchPool pidUnknown)
-            WD.guardJoin Write.RecentEraConway knownPools dlg pidUnknown noRetirementPlanned
+            WD.guardJoin Write.RecentEraConway knownPools dlg pidUnknown noRetirementPlanned True
                 `shouldBe` Left (W.ErrNoSuchPool pidUnknown)
         it "Cannot quit when active: not_delegating, next = []" $ do
             let dlg = WalletDelegation {active = NotDelegating, next = []}
@@ -204,7 +224,7 @@ spec = describe "Cardano.Wallet.DelegationSpec" $ do
 -------------------------------------------------------------------------------}
 
 prop_guardJoinQuit
-    :: (Set PoolId -> WalletDelegation -> PoolId -> Maybe PoolRetirementEpochInfo -> Either ErrCannotJoin ())
+    :: (Set PoolId -> WalletDelegation -> PoolId -> Maybe PoolRetirementEpochInfo -> Bool -> Either ErrCannotJoin ())
     -> [PoolId]
     -> WalletDelegation
     -> PoolId
@@ -218,7 +238,7 @@ prop_guardJoinQuit guardJoin knownPoolsList dlg pid wdrl mRetirementInfo = check
         "retirementPlanned"
     $ cover 10 alreadyRetired
         "alreadyRetired"
-    $ case guardJoin knownPools dlg pid mRetirementInfo of
+    $ case guardJoin knownPools dlg pid mRetirementInfo False of
         Right () ->
             label "I can join" $ property $
                 alreadyRetired `shouldBe` False
@@ -227,6 +247,8 @@ prop_guardJoinQuit guardJoin knownPoolsList dlg pid wdrl mRetirementInfo = check
         Left W.ErrAlreadyDelegating{} ->
             label "ErrAlreadyDelegating"
                 (WD.guardQuit dlg wdrl (Coin 0) False === Right ())
+        Left W.ErrAlreadyDelegatingVoting{} ->
+            label "ErrAlreadyDelegatingVoting" $ property True
   where
     knownPools = Set.fromList knownPoolsList
     retirementNotPlanned =
@@ -241,7 +263,7 @@ prop_guardJoinQuit guardJoin knownPoolsList dlg pid wdrl mRetirementInfo = check
             pure $ W.currentEpoch info >= W.retirementEpoch info
 
 prop_guardQuitJoin
-    :: (Set PoolId -> WalletDelegation -> PoolId -> Maybe PoolRetirementEpochInfo -> Either ErrCannotJoin ())
+    :: (Set PoolId -> WalletDelegation -> PoolId -> Maybe PoolRetirementEpochInfo -> Bool -> Either ErrCannotJoin ())
     -> NonEmptyList PoolId
     -> WalletDelegation
     -> Word64
@@ -255,7 +277,7 @@ prop_guardQuitJoin guardJoin (NonEmpty knownPoolsList) dlg rewards wdrl =
             label "I can quit" $ property True
         Left W.ErrNotDelegatingOrAboutTo ->
             label "ErrNotDelegatingOrAboutTo" $
-                guardJoin knownPools dlg (last knownPoolsList) noRetirementPlanned
+                guardJoin knownPools dlg (last knownPoolsList) noRetirementPlanned False
                     === Right ()
         Left W.ErrNonNullRewards{} ->
             label "ErrNonNullRewards" $
@@ -270,6 +292,7 @@ guardJoinBabbage
     -> WalletDelegation
     -> PoolId
     -> Maybe PoolRetirementEpochInfo
+    -> Bool
     -> Either ErrCannotJoin ()
 guardJoinBabbage = WD.guardJoin Write.RecentEraBabbage
 
@@ -278,6 +301,7 @@ guardJoinConway
     -> WalletDelegation
     -> PoolId
     -> Maybe PoolRetirementEpochInfo
+    -> Bool
     -> Either ErrCannotJoin ()
 guardJoinConway = WD.guardJoin Write.RecentEraConway
 

diff --git a/lib/wallet/src/Cardano/Wallet/Delegation.hs b/lib/wallet/src/Cardano/Wallet/Delegation.hs
@@ -86,12 +86,13 @@ joinStakePoolDelegationAction
     -> Set PoolId
     -> PoolId
     -> PoolLifeCycleStatus
+    -> Bool
     -> Either
         ErrStakePoolDelegation
         (Tx.DelegationAction, Maybe Tx.VotingAction)
 joinStakePoolDelegationAction
-    era wallet currentEpochSlotting knownPools poolId poolStatus
-  = case guardJoin era knownPools delegation poolId retirementInfo of
+    era wallet currentEpochSlotting knownPools poolId poolStatus votedTheSame
+  = case guardJoin era knownPools delegation poolId retirementInfo votedTheSame of
         Left e -> Left $ ErrStakePoolJoin e
         Right () -> Right
             ( if stakeKeyIsRegistered
@@ -123,8 +124,9 @@ guardJoin
     -> WalletDelegation
     -> PoolId
     -> Maybe PoolRetirementEpochInfo
+    -> Bool
     -> Either ErrCannotJoin ()
-guardJoin era knownPools delegation pid mRetirementEpochInfo = do
+guardJoin era knownPools delegation pid mRetirementEpochInfo votedTheSame = do
     when (pid `Set.notMember` knownPools) $
         Left (ErrNoSuchPool pid)
 
@@ -137,14 +139,20 @@ guardJoin era knownPools delegation pid mRetirementEpochInfo = do
                 Write.RecentEraBabbage ->
                     Left (ErrAlreadyDelegating pid)
                 Write.RecentEraConway ->
-                    pure ()
+                    if votedTheSame then
+                        Left (ErrAlreadyDelegatingVoting pid)
+                    else
+                        pure ()
 
     when (not (null next) && isDelegatingTo (== pid) (last next)) $
         case era of
                 Write.RecentEraBabbage ->
                     Left (ErrAlreadyDelegating pid)
                 Write.RecentEraConway ->
-                    pure ()
+                    if votedTheSame then
+                        Left (ErrAlreadyDelegatingVoting pid)
+                    else
+                        pure ()
   where
     WalletDelegation {active, next} = delegation
 

diff --git a/lib/wallet/src/Cardano/Wallet/IO/Delegation.hs b/lib/wallet/src/Cardano/Wallet/IO/Delegation.hs
@@ -140,10 +140,11 @@ handleDelegationRequest
     -> IO (Set PoolId)
     -> (PoolId -> IO PoolLifeCycleStatus)
     -> Withdrawal
+    -> Bool
     -> WD.DelegationRequest
     -> IO Tx.DelegationAction
 handleDelegationRequest
-    ctx currentEpochSlotting getKnownPools getPoolStatus withdrawal = \case
+    ctx currentEpochSlotting getKnownPools getPoolStatus withdrawal votedTheSame = \case
     WD.Join poolId -> do
         poolStatus <- getPoolStatus poolId
         pools <- getKnownPools
@@ -153,6 +154,7 @@ handleDelegationRequest
             pools
             poolId
             poolStatus
+            votedTheSame
     WD.Quit ->
         quitStakePoolDelegationAction
             ctx
@@ -218,6 +220,7 @@ selectCoinsForJoin ctx pools poolId poolStatus = do
         pools
         poolId
         poolStatus
+        False
 
     let changeAddrGen = W.defaultChangeAddressGen (delegationAddressS @n)
 
@@ -306,9 +309,10 @@ joinStakePoolDelegationAction
     -> Set PoolId
     -> PoolId
     -> PoolLifeCycleStatus
+    -> Bool
     -> IO (Tx.DelegationAction, Maybe Tx.VotingAction)
 joinStakePoolDelegationAction
-    ctx currentEpochSlotting knownPools poolId poolStatus
+    ctx currentEpochSlotting knownPools poolId poolStatus votedTheSame
   = do
     (wallet, stakeKeyIsRegistered) <-
         db & \DBLayer{atomically,walletState} -> atomically $
@@ -329,6 +333,7 @@ joinStakePoolDelegationAction
             knownPools
             poolId
             poolStatus
+            votedTheSame
   where
     db = ctx ^. dbLayer
     tr = ctx ^. logger
@@ -365,6 +370,7 @@ joinStakePool ctx wid pools poolId poolStatus passphrase = do
             pools
             poolId
             poolStatus
+            False
 
     ttl <- W.transactionExpirySlot ti Nothing
     let transactionCtx =

diff --git a/lib/wallet/src/Cardano/Wallet/Transaction.hs b/lib/wallet/src/Cardano/Wallet/Transaction.hs
@@ -390,6 +390,7 @@ data ErrSignTx
 
 data ErrCannotJoin
     = ErrAlreadyDelegating PoolId
+    | ErrAlreadyDelegatingVoting PoolId
     | ErrNoSuchPool PoolId
     deriving (Generic, Eq, Show)