View on GitHub
File Changes
    , ApiWalletDelegation (..)
    , ApiWalletDelegationNext (..)
    , ApiWalletDelegationStatus (..)
+
    , BackwardCompatPlaceholder
    , ByronWalletStyle (..)
    , Iso8601Time (..)
    , WalletStyle (..)
        (Link.joinStakePool (Identity p) w) Default payload

                      
quitStakePool
-
    :: forall t w. (HasType (ApiT WalletId) w)
+
    :: forall t s w. (HasType (ApiT WalletId) w, HasType (ApiT PoolId) s)
    => Context t
-
    -> ApiT PoolId
+
    -> BackwardCompatPlaceholder s
    -> (w, Text)
    -> IO (HTTP.Status, Either RequestException (ApiTransaction 'Testnet))
quitStakePool ctx p (w, pass) = do
    let payload = Json [aesonQQ| {
            "passphrase": #{pass}
            } |]
    request @(ApiTransaction 'Testnet) ctx
-
        (Link.quitStakePool (Identity p) w) Default payload
+
        (Link.quitStakePool p w) Default payload

                      
selectCoins
    :: forall t w. (HasType (ApiT WalletId) w)
    , errMsg403NoPendingAnymore
    , errMsg404NoSuchPool
    , errMsg403PoolAlreadyJoined
-
    , errMsg403WrongPool
+
    , errMsg403NotDelegating
    , errMsg403NothingToMigrate
    , errMsg404NoEndpoint
    , errMsg404CannotFindTx
    ++ unpack pid ++ ". I have already joined this pool; joining again would "
    ++ "incur an unnecessary fee!"

                      
-
errMsg403WrongPool :: Text -> String
-
errMsg403WrongPool pid = "I couldn't quit a stake pool with the given id: "
-
    ++ unpack pid ++ ", because I'm not a member of this stake pool.\
-
    \ Please check if you are using correct stake pool id in your request."
+
errMsg403NotDelegating :: String
+
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."

                      
errMsg404CannotFindTx :: Text -> String
errMsg404CannotFindTx tid = "I couldn't find a transaction with the given id: "
    -> ArgGenChange s
    -> Passphrase "encryption"
    -> CoinSelection
-
    -> PoolId
    -> DelegationAction
    -> ExceptT ErrSignDelegation IO (Tx, TxMeta, UTCTime, SealedTx)
-
signDelegation ctx wid argGenChange pwd coinSel poolId action = db & \DBLayer{..} -> do
+
signDelegation ctx wid argGenChange pwd coinSel action = db & \DBLayer{..} -> do
    let (CoinSelection ins outs chgs) = coinSel
    withRootKey @_ @s ctx wid pwd ErrSignDelegationWithRootKey $ \xprv -> do
        mapExceptT atomically $ do
            let keyFrom = isOwned (getState cp) (xprv, pwd)
            (tx, sealedTx) <- withExceptT ErrSignDelegationMkTx $ ExceptT $ pure $
                case action of
-
                    Join ->
+
                    Join poolId ->
                        mkDelegationJoinTx tl poolId (rewardAcc, pwd) keyFrom ins allOuts
                    Quit ->
                        mkDelegationQuitTx tl (rewardAcc, pwd) keyFrom ins allOuts
                                  Delegation
-------------------------------------------------------------------------------}

                      
-
data DelegationAction = Join | Quit
+
data DelegationAction = Join PoolId | Quit

                      
-- | Helper function to factor necessary logic for joining a stake pool.
joinStakePool
    walMeta <- mapExceptT atomically $ withExceptT ErrJoinStakePoolNoSuchWallet $
        withNoSuchWallet wid $ readWalletMeta (PrimaryKey wid)

                      
-
    when (isDelegatingTo pid (walMeta ^. #delegation)) $
+
    when (isDelegatingTo (== pid) (walMeta ^. #delegation)) $
        throwE (ErrJoinStakePoolAlreadyDelegating pid)

                      
    when (pid `notElem` pools) $
        selectCoinsForDelegation @ctx @s @t @k ctx wid

                      
    (tx, txMeta, txTime, sealedTx) <- withExceptT ErrJoinStakePoolSignDelegation $
-
        signDelegation @ctx @s @t @k ctx wid argGenChange pwd selection pid Join
+
        signDelegation @ctx @s @t @k ctx wid argGenChange pwd selection (Join pid)

                      
    withExceptT ErrJoinStakePoolSubmitTx $
        submitTx @ctx @s @t @k ctx wid (tx, txMeta, sealedTx)
        )
    => ctx
    -> WalletId
-
    -> PoolId
    -> ArgGenChange s
    -> Passphrase "encryption"
    -> ExceptT ErrQuitStakePool IO (Tx, TxMeta, UTCTime)
-
quitStakePool ctx wid pid argGenChange pwd = db & \DBLayer{..} -> do
+
quitStakePool ctx wid argGenChange pwd = db & \DBLayer{..} -> do
    walMeta <- mapExceptT atomically $ withExceptT ErrQuitStakePoolNoSuchWallet $
        withNoSuchWallet wid $ readWalletMeta (PrimaryKey wid)

                      
-
    unless (isDelegatingTo pid (walMeta ^. #delegation)) $
-
        throwE (ErrQuitStakePoolNotDelegatingTo pid)
+
    unless (isDelegatingTo anyone (walMeta ^. #delegation)) $
+
        throwE ErrQuitStakePoolNotDelegating

                      
    selection <- withExceptT ErrQuitStakePoolSelectCoin $
        selectCoinsForDelegation @ctx @s @t @k ctx wid

                      
    (tx, txMeta, txTime, sealedTx) <- withExceptT ErrQuitStakePoolSignDelegation $
-
        signDelegation @ctx @s @t @k ctx wid argGenChange pwd selection pid Quit
+
        signDelegation @ctx @s @t @k ctx wid argGenChange pwd selection Quit

                      
    withExceptT ErrQuitStakePoolSubmitTx $
        submitTx @ctx @s @t @k ctx wid (tx, txMeta, sealedTx)

                      
    pure (tx, txMeta, txTime)
  where
    db = ctx ^. dbLayer @s @k
+
    anyone = const True

                      
{-------------------------------------------------------------------------------
                                  Key Store

                      
data ErrQuitStakePool
    = ErrQuitStakePoolNoSuchWallet ErrNoSuchWallet
-
    | ErrQuitStakePoolNotDelegatingTo PoolId
+
    | ErrQuitStakePoolNotDelegating
    | ErrQuitStakePoolSelectCoin ErrSelectForDelegation
    | ErrQuitStakePoolSignDelegation ErrSignDelegation
    | ErrQuitStakePoolSubmitTx ErrSubmitTx

                      
      -- * Miscellaneous Types
    , Any
+
    , BackwardCompatPlaceholder(..)
    ) where

                      
import Prelude
    , ApiUtxoStatistics
    , ApiWallet
    , ApiWalletPassphrase
+
    , BackwardCompatPlaceholder (..)
    , ByronWalletPostData
    , ByronWalletStyle (..)
    , Iso8601Time

                      
-- | https://input-output-hk.github.io/cardano-wallet/api/#operation/quitStakePool
type QuitStakePool n = "stake-pools"
-
    :> Capture "stakePoolId" (ApiT PoolId)
+
    :> Capture "stakePoolId" (BackwardCompatPlaceholder (ApiT PoolId))
    :> "wallets"
    :> Capture "walletId" (ApiT WalletId)
    :> ReqBody '[JSON] ApiWalletPassphrase
    , ApiUtxoStatistics
    , ApiWallet (..)
    , ApiWalletPassphrase
+
    , BackwardCompatPlaceholder (..)
    , DecodeAddress
    , EncodeAddress
    , Iso8601Time (..)
        -> ApiWalletPassphrase
        -> ClientM (ApiTransaction t)
    , quitStakePool
-
        :: ApiT PoolId
-
        -> ApiT WalletId
+
        :: ApiT WalletId
        -> ApiWalletPassphrase
        -> ClientM (ApiTransaction t)
    , networkInformation
            , getWalletUtxoStatistics = _getWalletUtxoStatistics
            , listPools = _listPools
            , joinStakePool = _joinStakePool
-
            , quitStakePool = _quitStakePool
+
            , quitStakePool = _quitStakePool Placeholder
            , networkInformation = _networkInformation
            , networkParameters = _networkParameters
            }
import Prelude

                      
import Cardano.Wallet.Api
-
    ( Api )
+
    ( Api, BackwardCompatPlaceholder )
import Cardano.Wallet.Api.Types
    ( ApiEpochNumber
    , ApiT (..)
import Data.Function
    ( (&) )
import Data.Generics.Internal.VL.Lens
-
    ( (^.) )
+
    ( view, (^.) )
import Data.Generics.Product.Typed
    ( HasType, typed )
import Data.Proxy
        ( HasType (ApiT PoolId) s
        , HasType (ApiT WalletId) w
        )
-
    => s
+
    => BackwardCompatPlaceholder s
    -> w
    -> (Method, Text)
quitStakePool s w =
    endpoint @(Api.QuitStakePool Net) (\mk -> mk sid wid)
  where
-
    sid = s ^. typed @(ApiT PoolId)
+
    sid = fmap (view (typed @(ApiT PoolId))) s
    wid = w ^. typed @(ApiT WalletId)

                      
getDelegationFee
    , ApiWalletDelegationNext (..)
    , ApiWalletDelegationStatus (..)
    , ApiWalletPassphrase (..)
+
    , BackwardCompatPlaceholder
    , ByronWalletPostData (..)
    , Iso8601Time (..)
    , PostExternalTransactionData (..)
        , ctx ~ ApiLayer s t k
        )
    => ctx
-
    -> ApiT PoolId
+
    -> BackwardCompatPlaceholder (ApiT PoolId)
    -> ApiT WalletId
    -> ApiWalletPassphrase
    -> Handler (ApiTransaction n)
-
quitStakePool ctx (ApiT pid) (ApiT wid) (ApiWalletPassphrase (ApiT pwd)) = do
+
quitStakePool ctx _ (ApiT wid) (ApiWalletPassphrase (ApiT pwd)) = do
    (tx, txMeta, txTime) <- liftHandler $ withWorkerCtx ctx wid liftE $ \wrk ->
-
        W.quitStakePool @_ @s @t @k wrk wid pid () pwd
+
        W.quitStakePool @_ @s @t @k wrk wid () pwd

                      
    pure $ mkApiTransaction
        (txId tx)
        ErrQuitStakePoolSelectCoin e -> handler e
        ErrQuitStakePoolSignDelegation e -> handler e
        ErrQuitStakePoolSubmitTx e -> handler e
-
        ErrQuitStakePoolNotDelegatingTo pid ->
+
        ErrQuitStakePoolNotDelegating  ->
            apiError err403 NotDelegatingTo $ mconcat
-
                [ "I couldn't quit a stake pool with the given id: "
-
                , toText pid
-
                , ", because I'm not a member of this stake pool."
-
                , " Please check if you are using correct stake pool id"
-
                , " in your request."
+
                [ "It seems that you're trying to retire from delegation "
+
                , "although you're not even delegating, nor won't be in an "
+
                , "immediate future."
                ]

                      
instance LiftHandler ErrGetNetworkParameters where
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
+
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
+
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ScopedTypeVariables #-}
    -- * Polymorphic Types
    , ApiT (..)
    , ApiMnemonicT (..)
+
    , BackwardCompatPlaceholder (..)
    , getApiMnemonicT
    ) where

                      
instance FromHttpApiData ApiEpochNumber where
    parseUrlPiece = first (T.pack . getTextDecodingError) . fromText

                      
+
instance ToHttpApiData a
+
    => ToHttpApiData (BackwardCompatPlaceholder a) where
+
    toUrlPiece = \case
+
        Placeholder -> "*"
+
        BackwardCompat a -> toUrlPiece a
+

                      
+
instance (ToHttpApiData a, FromHttpApiData a)
+
    => FromHttpApiData (BackwardCompatPlaceholder a) where
+
    parseUrlPiece = \case
+
        t | t == toUrlPiece (Placeholder @a) -> pure Placeholder
+
        t -> BackwardCompat <$> parseUrlPiece t
+

                      
{-------------------------------------------------------------------------------
                              API Types: Byron
-------------------------------------------------------------------------------}
getApiMnemonicT :: ApiMnemonicT sizes purpose -> Passphrase purpose
getApiMnemonicT (ApiMnemonicT (pw, _)) = pw

                      
+
-- | A backward compatible placeholder for path parameter. Renders as '*' or,
+
-- accept what used to be an old value now deprecated.
+
data BackwardCompatPlaceholder t
+
    = Placeholder
+
    | BackwardCompat t
+
    deriving (Functor)
+

                      
{-------------------------------------------------------------------------------
                               JSON Instances
-------------------------------------------------------------------------------}
        ", something wrong with awaiting"

                      
class IsDelegatingTo a where
-
    isDelegatingTo :: PoolId -> a -> Bool
+
    isDelegatingTo :: (PoolId -> Bool) -> a -> Bool

                      
instance IsDelegatingTo WalletDelegationStatus where
-
    isDelegatingTo pid = \case
-
        Delegating pid' -> pid' == pid
-
        NotDelegating   -> False
+
    isDelegatingTo predicate = \case
+
        Delegating pid -> predicate pid
+
        NotDelegating  -> False

                      
instance IsDelegatingTo WalletDelegationNext where
-
    isDelegatingTo pid WalletDelegationNext{status} =
-
        isDelegatingTo pid status
+
    isDelegatingTo predicate WalletDelegationNext{status} =
+
        isDelegatingTo predicate status

                      
instance IsDelegatingTo WalletDelegation where
-
    isDelegatingTo pid WalletDelegation{active,next} =
-
        isDelegatingTo pid active || any (isDelegatingTo pid) next
+
    isDelegatingTo predicate WalletDelegation{active,next} =
+
        isDelegatingTo predicate active || any (isDelegatingTo predicate) next

                      
newtype WalletPassphraseInfo = WalletPassphraseInfo
    { lastUpdatedAt :: UTCTime }
    , ApiT (..)
    , ApiTransaction
    , ApiWallet
+
    , BackwardCompatPlaceholder (..)
    , WalletStyle (..)
    )
import Cardano.Wallet.Primitive.AddressDerivation
    )
import Test.Integration.Framework.TestData
    ( errMsg403DelegationFee
+
    , errMsg403NotDelegating
    , errMsg403PoolAlreadyJoined
    , errMsg403WrongPass
-
    , errMsg403WrongPool
    , errMsg404NoEndpoint
    , errMsg404NoSuchPool
    , errMsg404NoWallet
                ]

                      
        -- Quit a pool
-
        quitStakePool ctx (p ^. #id) (w, fixturePassphrase) >>= flip verify
+
        quitStakePool ctx placeholder (w, fixturePassphrase) >>= flip verify
            [ expectResponseCode HTTP.status202
            , expectField (#status . #getApiT) (`shouldBe` Pending)
            , expectField (#direction . #getApiT) (`shouldBe` Outgoing)

                      
        waitForNextEpoch ctx

                      
-
        quitStakePool ctx (p1 ^. #id) (w, fixturePassphrase) >>= flip verify
+
        quitStakePool ctx placeholder (w, fixturePassphrase) >>= flip verify
            [ expectResponseCode HTTP.status202
            ]

                      
            let (feeJoin, _) = ctx ^. #_feeEstimator $ DelegDescription 1 1 1
            let (feeQuit, _) = ctx ^. #_feeEstimator $ DelegDescription 1 0 1
            let initBalance = [feeJoin + feeQuit]
-
            (w, p) <- joinStakePoolWithWalletBalance ctx initBalance
-
            rq <- quitStakePool ctx (p ^. #id) (w, "Secure Passphrase")
+
            (w, _) <- joinStakePoolWithWalletBalance ctx initBalance
+
            rq <- quitStakePool ctx placeholder (w, "Secure Passphrase")
            expectResponseCode HTTP.status202 rq
            eventually $ do
                request @ApiWallet ctx (Link.getWallet @'Shelley w) Default Empty >>= flip verify
            let (feeJoin, _) = ctx ^. #_feeEstimator $ DelegDescription 1 1 1
            let (feeQuit, _) = ctx ^. #_feeEstimator $ DelegDescription 0 0 1
            let initBalance = [feeJoin+1]
-
            (w, p) <- joinStakePoolWithWalletBalance ctx initBalance
-
            rq <- quitStakePool ctx (p ^. #id) (w, "Secure Passphrase")
+
            (w, _) <- joinStakePoolWithWalletBalance ctx initBalance
+
            rq <- quitStakePool ctx placeholder (w, "Secure Passphrase")
            verify rq
                [ expectResponseCode HTTP.status403
                , expectErrorMessage (errMsg403DelegationFee (feeQuit - 1))
                verifyIt ctx joinStakePool passphrase expec

                      
            it ("Quit: " ++ expec) $ \ctx -> do
-
                verifyIt ctx quitStakePool passphrase expec
+
                verifyIt ctx (\_ _ -> quitStakePool ctx placeholder) passphrase expec

                      
    describe "STAKE_POOLS_JOIN/QUIT_02 - Passphrase must be text" $ do
        let verifyIt ctx sPoolEndp = do
        it "Join" $ \ctx -> do
            verifyIt ctx Link.joinStakePool
        it "Quit" $ \ctx -> do
-
            verifyIt ctx Link.quitStakePool
+
            verifyIt ctx (\_ -> Link.quitStakePool placeholder)

                      
    it "STAKE_POOLS_JOIN_03 - Byron wallet cannot join stake pool" $ \ctx -> do
        (_, p:_) <- eventually $
        it "Join" $ \ctx -> do
            verifyIt ctx Link.joinStakePool
        it "Quit" $ \ctx -> do
-
            verifyIt ctx Link.quitStakePool
+
            verifyIt ctx (\_ -> Link.quitStakePool placeholder)

                      
    describe "STAKE_POOLS_JOIN/QUIT_05 -  Methods Not Allowed" $ do
        let methods = ["POST", "CONNECT", "TRACE", "OPTIONS"]
                verifyIt ctx Link.joinStakePool headers expectations
        forM_ payloadHeaderCases $ \(title, headers, expectations) -> do
            it ("Quit: " ++ title) $ \ctx ->
-
                verifyIt ctx Link.quitStakePool headers expectations
+
                verifyIt ctx (\_ -> Link.quitStakePool placeholder) headers expectations

                      
    it "STAKE_POOLS_QUIT_01 - Quiting before even joining" $ \ctx -> do
-
        (_, p:_) <- eventually $
-
            unsafeRequest @[ApiStakePool] ctx Link.listStakePools Empty
        w <- emptyWallet ctx

                      
-
        r <- quitStakePool ctx (p ^. #id) (w, "Secure Passprase")
+
        r <- quitStakePool ctx placeholder (w, "Secure Passprase")
        expectResponseCode HTTP.status403 r
-
        expectErrorMessage (errMsg403WrongPool $ toText $ getApiT $ p ^. #id) r
+
        expectErrorMessage errMsg403NotDelegating r

                      
    it "STAKE_POOLS_QUIT_02 - Passphrase must be correct to quit" $ \ctx -> do
-
        (w, p) <- joinStakePoolWithFixtureWallet ctx
+
        (w, _) <- joinStakePoolWithFixtureWallet ctx

                      
-
        r <- quitStakePool ctx (p ^. #id) (w, "Incorrect Passphrase")
+
        r <- quitStakePool ctx placeholder (w, "Incorrect Passphrase")
        expectResponseCode HTTP.status403 r
        expectErrorMessage errMsg403WrongPass r

                      
-
    it "STAKE_POOLS_QUIT_02 - Cannot quit existant stake pool \
-
       \I have not joined" $ \ctx -> do
-
        (_, p1:p2:_) <- eventually $
-
            unsafeRequest @[ApiStakePool] ctx Link.listStakePools Empty
-
        w <- fixtureWallet ctx
-
        r <- joinStakePool ctx (p1 ^. #id) (w, fixturePassphrase)
-
        expectResponseCode HTTP.status202 r
-
        eventually $ 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)
-
                ]
-
        let pId = p2 ^. #id
-
        let wrongPoolId = toText $ getApiT pId
-
        rq <- quitStakePool ctx pId (w, fixturePassphrase)
-
        expectResponseCode HTTP.status403 rq
-
        expectErrorMessage (errMsg403WrongPool wrongPoolId) rq
-

                      
    it "STAKE_POOLS_JOIN/QUIT - Checking delegation expectations" $ \ctx -> do
        (_, p1:p2:_) <- eventually $
            unsafeRequest @[ApiStakePool] ctx Link.listStakePools Empty
                ]

                      
        --quiting
-
        r3 <- quitStakePool ctx (p2 ^. #id) (w, fixturePassphrase)
+
        r3 <- quitStakePool ctx placeholder (w, fixturePassphrase)
        expectResponseCode HTTP.status202 r3
        eventually $ do
            let ep = Link.listTransactions @'Shelley w
    let sp = SlotParameters (EpochLength epochL) (SlotLength slotL) genesisBlockDate (ActiveSlotCoefficient coeff)

                      
    return (currentEpoch, sp)
+

                      
+
placeholder :: BackwardCompatPlaceholder (Identity (ApiT PoolId))
+
placeholder = Placeholder
          schema: *parametersJoinStakePool
      responses: *responsesJoinStakePool

                      
+
  /stake-pools/*/wallets/{walletId}:
    delete:
      operationId: quitStakePool
      tags: ["Stake Pools"]
        <p align="right">status: <strong>stable</strong></p>

                      
        Stop delegating completely. The wallet's stake will become inactive.
+

                      
+
        > ⚠️  Disclaimer ⚠️
+
        >
+
        > This endpoint historically use to take a stake pool id as a path parameter.
+
        > However, retiring from delegation is ubiquitous and not tight to a particular
+
        > stake pool. For backward-compatibility reasons, sending stake pool ids as path
+
        > parameter will still be accepted by the server but new integrations are
+
        > encouraged to provide a placeholder asterisk `*` instead.
      parameters:
-
        - *parametersStakePoolId
        - *parametersWalletId
        - <<: *parametersBody
          schema: *parametersQuitStakePool