make quitting on a non-empty reward account forbidden

The Cardano ledger forbids to de-register a stake key, if there are
still rewards associated with it. We could have implemented some more
convoluted logic where the wallet would automatically collect rewards as
part of a de-registration, but we are a bit lacking time here so we'll
simply make this a manual operation that users have to undergo. Yet, the
backend will still return a meaningful error message explaining the
situation.

lib/core-integration/src/Test/Integration/Framework/TestData.hs

@@ -55,6 +55,7 @@ module Test.Integration.Framework.TestData
     , errMsg404NoSuchPool
     , errMsg403PoolAlreadyJoined
     , errMsg403NotDelegating
+    , errMsg403NonNullReward
     , errMsg403NothingToMigrate
     , errMsg404NoEndpoint
     , errMsg404CannotFindTx
@@ -369,6 +370,10 @@ errMsg403NotDelegating = "It seems that you're trying to retire from \
     \delegation although you're not even delegating, nor won't be in an \
     \immediate future."
 
+errMsg403NonNullReward :: String
+errMsg403NonNullReward = "It seems that you're trying to retire from delegation \
+    \although you've unspoiled rewards in your rewards account!"
+
 errMsg404CannotFindTx :: Text -> String
 errMsg404CannotFindTx tid = "I couldn't find a transaction with the given id: "
     ++ unpack tid

lib/core-integration/src/Test/Integration/Scenario/API/Shelley/StakePools.hs

@@ -95,6 +95,7 @@ import Test.Integration.Framework.DSL
     )
 import Test.Integration.Framework.TestData
     ( errMsg403DelegationFee
+    , errMsg403NonNullReward
     , errMsg403NotDelegating
     , errMsg403PoolAlreadyJoined
     , errMsg403WrongPass
@@ -193,6 +194,29 @@ spec = do
                 , expectField (#balance . #getApiT . #available) (.> previousBalance)
                 ]
 
+        -- Quit delegation altogether.
+        quitStakePool @n ctx (w, fixturePassphrase) >>= flip verify
+            [ expectResponseCode HTTP.status202
+            , expectField (#status . #getApiT) (`shouldBe` Pending)
+            , expectField (#direction . #getApiT) (`shouldBe` Outgoing)
+            ]
+        eventually "Certificates are inserted after quiting a pool" $ do
+            let ep = Link.listTransactions @'Shelley w
+            request @[ApiTransaction n] ctx ep Default Empty >>= flip verify
+                [ expectListField 0
+                    (#direction . #getApiT) (`shouldBe` Outgoing)
+                , expectListField 0
+                    (#status . #getApiT) (`shouldBe` InLedger)
+                , expectListField 1
+                    (#direction . #getApiT) (`shouldBe` Outgoing)
+                , expectListField 1
+                    (#status . #getApiT) (`shouldBe` InLedger)
+                , expectListField 2
+                    (#direction . #getApiT) (`shouldBe` Outgoing)
+                , expectListField 2
+                    (#status . #getApiT) (`shouldBe` InLedger)
+                ]
+
     it "STAKE_POOLS_JOIN_02 - Cannot join already joined stake pool" $ \ctx -> do
         w <- fixtureWallet ctx
         pool:_ <- map (view #id) . snd
@@ -311,7 +335,7 @@ spec = do
                 [ expectField #delegation (`shouldBe` delegating pool2 [])
                 ]
 
-    it "STAKE_POOLS_JOIN_04 - Rewards accumulate and stop" $ \ctx -> do
+    it "STAKE_POOLS_JOIN_04 - Rewards accumulate" $ \ctx -> do
         w <- fixtureWallet ctx
         pool:_ <- map (view #id) . snd
             <$> unsafeRequest @[ApiStakePool] ctx (Link.listStakePools arbitraryStake) Empty
@@ -339,38 +363,11 @@ spec = do
                     (.> (Quantity 0))
                 ]
 
--- TODO: Check if we can enable this
---        -- Quit a pool
---        quitStakePool @n ctx (w, fixturePassphrase) >>= flip verify
---            [ expectResponseCode HTTP.status202
---            , expectField (#status . #getApiT) (`shouldBe` Pending)
---            , expectField (#direction . #getApiT) (`shouldBe` Outgoing)
---            ]
---        eventually "Certificates are inserted after quiting a pool" $ do
---            let ep = Link.listTransactions @'Shelley w
---            request @[ApiTransaction n] ctx ep Default Empty >>= flip verify
---                [ expectListField 0
---                    (#direction . #getApiT) (`shouldBe` Outgoing)
---                , expectListField 0
---                    (#status . #getApiT) (`shouldBe` InLedger)
---                , expectListField 1
---                    (#direction . #getApiT) (`shouldBe` Outgoing)
---                , expectListField 1
---                    (#status . #getApiT) (`shouldBe` InLedger)
---                ]
---
---        -- Check that rewards have stopped flowing.
---        waitForNextEpoch ctx
---        waitForNextEpoch ctx
---        reward <- getFromResponse (#balance . #getApiT . #reward) <$>
---            request @ApiWallet ctx (Link.getWallet @'Shelley w) Default Empty
---
---        waitForNextEpoch ctx
---        request @ApiWallet ctx (Link.getWallet @'Shelley w) Default Empty >>= flip verify
---            [ expectField
---                    (#balance . #getApiT . #reward)
---                    (`shouldBe` reward)
---            ]
+        -- Can't quite if unspoiled rewards.
+        quitStakePool @n ctx (w, fixturePassphrase) >>= flip verify
+            [ expectResponseCode HTTP.status403
+            , expectErrorMessage errMsg403NonNullReward
+            ]
 
     describe "STAKE_POOLS_JOIN_01x - Fee boundary values" $ do
         it "STAKE_POOLS_JOIN_01x - \

lib/core/src/Cardano/Wallet.hs

@@ -1753,8 +1753,9 @@ quitStakePool ctx wid argGenChange pwd = db & \DBLayer{..} -> do
     walMeta <- mapExceptT atomically $ withExceptT ErrQuitStakePoolNoSuchWallet $
         withNoSuchWallet wid $ readWalletMeta (PrimaryKey wid)
 
+    rewards <- liftIO $ fetchRewardBalance @ctx @s @k ctx wid
     withExceptT ErrQuitStakePoolCannotQuit $ except $
-        guardQuit (walMeta ^. #delegation)
+        guardQuit (walMeta ^. #delegation) rewards
 
     let action = Quit
 
@@ -2078,6 +2079,7 @@ data ErrCannotJoin
 
 data ErrCannotQuit
     = ErrNotDelegatingOrAboutTo
+    | ErrNonNullRewards (Quantity "lovelace" Word64)
     deriving (Generic, Eq, Show)
 
 -- | Can't perform given operation because the wallet died.
@@ -2131,11 +2133,16 @@ guardJoin knownPools WalletDelegation{active,next} pid = do
 
 guardQuit
     :: WalletDelegation
+    -> Quantity "lovelace" Word64
     -> Either ErrCannotQuit ()
-guardQuit WalletDelegation{active,next} = do
+guardQuit WalletDelegation{active,next} rewards = do
     let last_ = maybe active (view #status) $ lastMay next
+
     unless (isDelegatingTo anyone last_) $
         Left ErrNotDelegatingOrAboutTo
+
+    unless (rewards == Quantity 0) $
+        Left $ ErrNonNullRewards rewards
   where
     anyone = const True
 

lib/core/src/Cardano/Wallet/Api/Server.hs

@@ -2123,6 +2123,13 @@ instance LiftHandler ErrQuitStakePool where
                     , "although you're not even delegating, nor won't be in an "
                     , "immediate future."
                     ]
+            ErrNonNullRewards (Quantity rewards) ->
+                apiError err403 NonNullRewards $ mconcat
+                    [ "It seems that you're trying to retire from delegation "
+                    , "although you've unspoiled rewards in your rewards "
+                    , "account! Make sure to withdraw your ", pretty rewards
+                    , " lovelace first."
+                    ]
 
 instance LiftHandler ErrCreateRandomAddress where
     handler = \case

lib/core/src/Cardano/Wallet/Api/Types.hs

@@ -639,6 +639,7 @@ data ApiErrorCode
     | AddressAlreadyExists
     | InvalidWalletType
     | QueryParamMissing
+    | NonNullRewards
     deriving (Eq, Generic, Show)
 
 -- | Defines a point in time that can be formatted as and parsed from an

lib/core/test/unit/Cardano/WalletSpec.hs

@@ -138,7 +138,7 @@ import Data.Time.Clock
 import Data.Time.Clock.POSIX
     ( posixSecondsToUTCTime )
 import Data.Word
-    ( Word32 )
+    ( Word32, Word64 )
 import Data.Word.Odd
     ( Word31 )
 import GHC.Generics
@@ -262,22 +262,22 @@ spec = do
                 `shouldBe` Left (W.ErrNoSuchPool pidUnknown)
         it "Cannot quit when active: not_delegating, next = []" $ do
             let dlg = WalletDelegation {active = NotDelegating, next = []}
-            W.guardQuit dlg `shouldBe` Left (W.ErrNotDelegatingOrAboutTo)
+            W.guardQuit dlg (Quantity 0) `shouldBe` Left (W.ErrNotDelegatingOrAboutTo)
         it "Cannot quit when active: A, next = [not_delegating]" $ do
             let next1 = next (EpochNo 1) NotDelegating
             let dlg = WalletDelegation {active = Delegating pidA, next = [next1]}
-            W.guardQuit dlg `shouldBe` Left (W.ErrNotDelegatingOrAboutTo)
+            W.guardQuit dlg (Quantity 0) `shouldBe` Left (W.ErrNotDelegatingOrAboutTo)
         it "Cannot quit when active: A, next = [B, not_delegating]" $ do
             let next1 = next (EpochNo 1) (Delegating pidB)
             let next2 = next (EpochNo 2) NotDelegating
             let dlg = WalletDelegation
                     {active = Delegating pidA, next = [next1, next2]}
-            W.guardQuit dlg `shouldBe` Left (W.ErrNotDelegatingOrAboutTo)
+            W.guardQuit dlg (Quantity 0) `shouldBe` Left (W.ErrNotDelegatingOrAboutTo)
         it "Can quit when active: not_delegating, next = [A]" $ do
             let next1 = next (EpochNo 1) (Delegating pidA)
             let dlg = WalletDelegation
                     {active = NotDelegating, next = [next1]}
-            W.guardQuit dlg `shouldBe` Right ()
+            W.guardQuit dlg (Quantity 0) `shouldBe` Right ()
      where
          pidA = PoolId "A"
          pidB = PoolId "B"
@@ -298,22 +298,29 @@ prop_guardJoinQuit
     -> Property
 prop_guardJoinQuit knownPools dlg pid =
     case W.guardJoin knownPools dlg pid of
-        Right () -> label "I can join" $ property True
-        Left W.ErrNoSuchPool{}  -> label "ErrNoSuchPool" $ property True
+        Right () ->
+            label "I can join" $ property True
+        Left W.ErrNoSuchPool{}  ->
+            label "ErrNoSuchPool" $ property True
         Left W.ErrAlreadyDelegating{} ->
-            label "ErrAlreadyDelegating" (W.guardQuit dlg === Right ())
+            label "ErrAlreadyDelegating"
+                (W.guardQuit dlg (Quantity 0) === Right ())
 
 prop_guardQuitJoin
     :: NonEmptyList PoolId
     -> WalletDelegation
+    -> Word64
     -> Property
-prop_guardQuitJoin (NonEmpty knownPools) dlg =
-    case W.guardQuit dlg of
+prop_guardQuitJoin (NonEmpty knownPools) dlg rewards =
+    case W.guardQuit dlg (Quantity rewards) of
         Right () ->
             label "I can quit" $ property True
         Left W.ErrNotDelegatingOrAboutTo ->
             label "ErrNotDelegatingOrAboutTo"
                 (W.guardJoin knownPools dlg (last knownPools) === Right ())
+        Left W.ErrNonNullRewards{} ->
+            label "ErrNonNullRewards"
+                (property $ rewards /= 0)
 
 walletCreationProp
     :: (WalletId, WalletName, DummyState)

lib/jormungandr/test/integration/Test/Integration/Jormungandr/Scenario/API/StakePools.hs

@@ -92,6 +92,7 @@ import Test.Integration.Framework.DSL
 import Test.Integration.Framework.TestData
     ( errMsg403DelegationFee
     , errMsg403NoRootKey
+    , errMsg403NonNullReward
     , errMsg403NotDelegating
     , errMsg403PoolAlreadyJoined
     , errMsg403WrongPass
@@ -354,35 +355,10 @@ spec = do
                     (.> (Quantity 0))
                 ]
 
-        -- Quit a pool
+        -- Can't quit a pool
         quitStakePool @n ctx (w, fixturePassphrase) >>= flip verify
-            [ expectResponseCode HTTP.status202
-            , expectField (#status . #getApiT) (`shouldBe` Pending)
-            , expectField (#direction . #getApiT) (`shouldBe` Outgoing)
-            ]
-        eventually "Certificates are inserted after quiting a pool" $ do
-            let ep = Link.listTransactions @'Shelley w
-            request @[ApiTransaction n] ctx ep Default Empty >>= flip verify
-                [ expectListField 0
-                    (#direction . #getApiT) (`shouldBe` Outgoing)
-                , expectListField 0
-                    (#status . #getApiT) (`shouldBe` InLedger)
-                , expectListField 1
-                    (#direction . #getApiT) (`shouldBe` Outgoing)
-                , expectListField 1
-                    (#status . #getApiT) (`shouldBe` InLedger)
-                ]
-
-        waitForNextEpoch ctx
-        waitForNextEpoch ctx
-        reward <- getFromResponse (#balance . #getApiT . #reward) <$>
-            request @ApiWallet ctx (Link.getWallet @'Shelley w) Default Empty
-
-        waitForNextEpoch ctx
-        request @ApiWallet ctx (Link.getWallet @'Shelley w) Default Empty >>= flip verify
-            [ expectField
-                    (#balance . #getApiT . #reward)
-                    (`shouldBe` reward)
+            [ expectResponseCode HTTP.status403
+            , expectErrorMessage errMsg403NonNullReward
             ]
 
     it "STAKE_POOLS_JOIN_04 -\