refactor: extract wallet delegation module and spec

lib/wallet/api/http/Cardano/Wallet/Api/Http/Shelley/Server.hs

@@ -175,9 +175,10 @@ import Cardano.Wallet
     , FeeEstimation (..)
     , HasNetworkLayer
     , TxSubmitLog
-    , WalletWorkerLog
+    , WalletWorkerLog (..)
     , dbLayer
     , genesisData
+    , logger
     , manageRewardBalance
     , networkLayer
     , transactionLayer
@@ -635,6 +636,7 @@ import qualified Cardano.Api as Cardano
 import qualified Cardano.Wallet as W
 import qualified Cardano.Wallet.Api.Types as Api
 import qualified Cardano.Wallet.DB as W
+import qualified Cardano.Wallet.Delegation as WD
 import qualified Cardano.Wallet.Network as NW
 import qualified Cardano.Wallet.Primitive.AddressDerivation.Byron as Byron
 import qualified Cardano.Wallet.Primitive.AddressDerivation.Icarus as Icarus
@@ -1697,8 +1699,18 @@ selectCoinsForJoin ctx knownPools getPoolStatus pid wid = do
     curEpoch <- getCurrentEpoch ctx
 
     withWorkerCtx ctx wid liftE liftE $ \wrk -> do
+        let db = wrk ^. typed @(DBLayer IO s k)
+            netLayer = wrk ^. networkLayer
         (action, deposit) <- liftHandler
-            $ W.joinStakePool @_ @s @k wrk curEpoch pools pid poolStatus wid
+            $ WD.joinStakePool @s @k
+                (contramap MsgWallet $ wrk ^. logger)
+                db
+                netLayer
+                curEpoch
+                pools
+                pid
+                poolStatus
+                wid
 
         let txCtx = defaultTransactionCtx
                 { txDelegationAction = Just action
@@ -1726,7 +1738,7 @@ selectCoinsForJoin ctx knownPools getPoolStatus pid wid = do
             $ W.selectAssets @_ @_ @s @k @'CredFromKeyK
                 wrk era pp selectAssetsParams transform
         (_, _, path) <- liftHandler
-            $ W.readRewardAccount (wrk ^. dbLayer) wid
+            $ W.readRewardAccount db wid
 
         let deposits = maybeToList deposit
 
@@ -1751,7 +1763,7 @@ selectCoinsForQuit ctx@ApiLayer{..} (ApiT wid) =
         wdrl <-
             liftIO $ W.shelleyOnlyMkSelfWithdrawal
                 @_ @_ @_ @_ @n netLayer txLayer era db wid
-        action <- liftIO $ W.validatedQuitStakePoolAction db wid wdrl
+        action <- liftIO $ WD.validatedQuitStakePoolAction db wid wdrl
 
         let txCtx = defaultTransactionCtx
                 { txDelegationAction = Just action
@@ -2308,12 +2320,20 @@ constructTransaction
                         poolStatus <- liftIO (getPoolStatus pid)
                         pools <- liftIO knownPools
                         curEpoch <- getCurrentEpoch apiLayer
-                        (del, act) <- liftHandler $ W.joinStakePool
-                            wrk curEpoch pools pid poolStatus walletId
+                        (del, act) <- liftHandler $
+                            WD.joinStakePool
+                                (contramap MsgWallet $ wrk ^. logger)
+                                db
+                                netLayer
+                                curEpoch
+                                pools
+                                pid
+                                poolStatus
+                                walletId
                         pure (del, act, Nothing)
                     [(Leaving _)] -> liftIO $
                         (, Nothing, Just (W.stakeKeyDeposit pp)) <$>
-                            W.validatedQuitStakePoolAction db walletId wdrl
+                            WD.validatedQuitStakePoolAction db walletId wdrl
                     _ ->
                         liftHandler $
                             throwE ErrConstructTxMultidelegationNotSupported
@@ -3257,8 +3277,18 @@ joinStakePool ctx knownPools getPoolStatus apiPool (ApiT wid) body = do
     pools <- liftIO knownPools
     curEpoch <- getCurrentEpoch ctx
     withWorkerCtx ctx wid liftE liftE $ \wrk -> do
+        let db = wrk ^. dbLayer
+            netLayer = wrk ^. networkLayer
         (action, _) <- liftHandler
-            $ W.joinStakePool @_ @s @k wrk curEpoch pools poolId poolStatus wid
+            $ WD.joinStakePool @s @k
+                (contramap MsgWallet $ wrk ^. logger)
+                db
+                netLayer
+                curEpoch
+                pools
+                poolId
+                poolStatus
+                wid
 
         ttl <- liftIO $ W.transactionExpirySlot ti Nothing
         let txCtx = defaultTransactionCtx
@@ -3388,7 +3418,7 @@ quitStakePool ctx@ApiLayer{..} (ApiT walletId) body = do
                                                (typeRep @ShelleyKey) of
                     Nothing -> notShelleyWallet
                     Just Refl -> liftIO $
-                        W.quitStakePool netLayer db ti walletId
+                        WD.quitStakePool netLayer db ti walletId
         (utxoAvailable, wallet, pendingTxs) <-
             liftHandler $ W.readWalletUTxOIndex @_ @s @k wrk walletId
         pp <- liftIO $ NW.currentProtocolParameters (wrk ^. networkLayer)

lib/wallet/cardano-wallet.cabal

@@ -241,6 +241,7 @@ library
     Cardano.Wallet.DB.Store.Wallets.Model
     Cardano.Wallet.DB.Store.Wallets.Store
     Cardano.Wallet.DB.WalletState
+    Cardano.Wallet.Delegation
     Cardano.Wallet.Gen
     Cardano.Wallet.Logging
     Cardano.Wallet.Network
@@ -310,6 +311,7 @@ library
     Cardano.Wallet.Read.Primitive.Tx.Mary
     Cardano.Wallet.Read.Primitive.Tx.Shelley
     Cardano.Wallet.Read.Tx
+    Cardano.Wallet.Read.Tx.Cardano
     Cardano.Wallet.Read.Tx.CBOR
     Cardano.Wallet.Read.Tx.Certificates
     Cardano.Wallet.Read.Tx.Eras
@@ -319,7 +321,6 @@ library
     Cardano.Wallet.Read.Tx.Mint
     Cardano.Wallet.Read.Tx.Validity
     Cardano.Wallet.Read.Tx.Witnesses
-    Cardano.Wallet.Read.Tx.Cardano
     Cardano.Wallet.Registry
     Cardano.Wallet.Shelley.BlockchainSource
     Cardano.Wallet.Shelley.Compatibility
@@ -722,6 +723,7 @@ test-suite unit
     , generic-lens
     , generics-sop
     , hedgehog
+    , hedgehog-corpus
     , hedgehog-quickcheck
     , hspec                        >=2.8.2
     , hspec-core                   >=2.8.2
@@ -830,6 +832,7 @@ test-suite unit
     Cardano.Wallet.DB.Store.Submissions.StoreSpec
     Cardano.Wallet.DB.Store.Transactions.StoreSpec
     Cardano.Wallet.DB.Store.Wallets.StoreSpec
+    Cardano.Wallet.DelegationSpec
     Cardano.Wallet.DummyTarget.Primitive.Types
     Cardano.Wallet.Network.LightSpec
     Cardano.Wallet.Network.PortsSpec
@@ -858,6 +861,7 @@ test-suite unit
     Cardano.Wallet.Primitive.Types.TxSpec
     Cardano.Wallet.Primitive.TypesSpec
     Cardano.Wallet.Read.Tx.CBORSpec
+    Cardano.Wallet.Read.Tx.CBORSpec
     Cardano.Wallet.RegistrySpec
     Cardano.Wallet.Shelley.Compatibility.LedgerSpec
     Cardano.Wallet.Shelley.CompatibilitySpec
@@ -868,7 +872,6 @@ test-suite unit
     Cardano.Wallet.Shelley.NetworkSpec
     Cardano.Wallet.Shelley.TransactionSpec
     Cardano.Wallet.TokenMetadataSpec
-    Cardano.Wallet.Read.Tx.CBORSpec
     Cardano.Wallet.Write.TxSpec
     Cardano.WalletSpec
     Control.Concurrent.ConciergeSpec

lib/wallet/src/Cardano/Wallet.hs

@@ -151,11 +151,6 @@ module Cardano.Wallet
 
     -- ** Delegation
     , PoolRetirementEpochInfo (..)
-    , joinStakePool
-    , quitStakePool
-    , validatedQuitStakePoolAction
-    , guardJoin
-    , guardQuit
     , ErrStakePoolDelegation (..)
 
     -- ** Fee Estimation
@@ -231,8 +226,6 @@ import Cardano.Crypto.Wallet
     ( toXPub )
 import Cardano.Mnemonic
     ( SomeMnemonic )
-import Cardano.Pool.Types
-    ( PoolId )
 import Cardano.Slotting.Slot
     ( SlotNo (..) )
 import Cardano.Wallet.Address.Book
@@ -397,10 +390,8 @@ import Cardano.Wallet.Primitive.Types
     , DelegationCertificate (..)
     , FeePolicy (LinearFee)
     , GenesisParameters (..)
-    , IsDelegatingTo (..)
     , LinearFunction (LinearFunction)
     , NetworkParameters (..)
-    , PoolLifeCycleStatus
     , ProtocolParameters (..)
     , Range (..)
     , Signature (..)
@@ -592,8 +583,6 @@ import GHC.Generics
     ( Generic )
 import Numeric.Natural
     ( Natural )
-import Safe
-    ( lastMay )
 import Statistics.Quantile
     ( medianUnbiased, quantiles )
 import System.Random.StdGenSeed
@@ -3062,94 +3051,6 @@ migrationPlanToSelectionWithdrawals plan rewardWithdrawal outputAddressesToCycle
         outputAddressesRemaining =
             drop (length outputs) outputAddresses
 
-{-------------------------------------------------------------------------------
-                                  Delegation
--------------------------------------------------------------------------------}
-
-joinStakePool
-    :: forall ctx s k.
-        ( HasDBLayer IO s k ctx
-        , HasNetworkLayer IO ctx
-        , HasLogger IO WalletWorkerLog ctx
-        )
-    => ctx
-    -> W.EpochNo
-    -> Set PoolId
-    -> PoolId
-    -> PoolLifeCycleStatus
-    -> WalletId
-    -> ExceptT ErrStakePoolDelegation IO (DelegationAction, Maybe Coin)
-    -- ^ snd is the deposit
-joinStakePool ctx currentEpoch knownPools pid poolStatus wid =
-    db & \DBLayer{..} -> do
-        ((_ , walDelegation), isKeyReg) <- mapExceptT atomically $ do
-            walMeta <- withExceptT ErrStakePoolDelegationNoSuchWallet
-                $ withNoSuchWallet wid
-                $ readWalletMeta wid
-            isKeyReg <- withExceptT ErrStakePoolDelegationNoSuchWallet
-                $ isStakeKeyRegistered wid
-            pure (walMeta, isKeyReg)
-
-        let mRetirementEpoch = view #retirementEpoch <$>
-                W.getPoolRetirementCertificate poolStatus
-        let retirementInfo =
-                PoolRetirementEpochInfo currentEpoch <$> mRetirementEpoch
-
-        withExceptT ErrStakePoolJoin $ except $
-            guardJoin knownPools walDelegation pid retirementInfo
-
-        liftIO $ traceWith tr $ MsgIsStakeKeyRegistered isKeyReg
-
-        dep <- liftIO $ stakeKeyDeposit <$> currentProtocolParameters nl
-
-        return $ if isKeyReg
-            then (Join pid, Nothing)
-            else (RegisterKeyAndJoin pid, Just dep)
-  where
-    db = ctx ^. dbLayer @IO @s @k
-    tr = contramap MsgWallet $ ctx ^. logger
-    nl = ctx ^. networkLayer
-
--- | Helper function to factor necessary logic for quitting a stake pool.
-validatedQuitStakePoolAction
-    :: forall s k
-     . DBLayer IO s k
-    -> WalletId
-    -> Withdrawal
-    -> IO DelegationAction
-validatedQuitStakePoolAction db@DBLayer{..} walletId withdrawal = do
-    (_, delegation) <- atomically (readWalletMeta walletId)
-        >>= maybe
-            (throwIO (ExceptionStakePoolDelegation
-                (ErrStakePoolDelegationNoSuchWallet
-                    (ErrNoSuchWallet walletId))))
-            pure
-    rewards <- liftIO $ fetchRewardBalance @s @k db walletId
-    either (throwIO . ExceptionStakePoolDelegation . ErrStakePoolQuit) pure
-        (guardQuit delegation withdrawal rewards)
-    pure Quit
-
-quitStakePool
-    :: forall (n :: NetworkDiscriminant)
-     . NetworkLayer IO Block
-    -> DBLayer IO (SeqState n ShelleyKey) ShelleyKey
-    -> TimeInterpreter (ExceptT PastHorizonException IO)
-    -> WalletId
-    -> IO TransactionCtx
-quitStakePool netLayer db timeInterpreter walletId = do
-    (rewardAccount, _, derivationPath) <-
-        runExceptT (readRewardAccount db walletId)
-            >>= either (throwIO . ExceptionReadRewardAccount) pure
-    withdrawal <- WithdrawalSelf rewardAccount derivationPath
-        <$> getCachedRewardAccountBalance netLayer rewardAccount
-    action <- validatedQuitStakePoolAction db walletId withdrawal
-    ttl <- transactionExpirySlot timeInterpreter  Nothing
-    pure defaultTransactionCtx
-        { txWithdrawal = withdrawal
-        , txValidityInterval = (Nothing, ttl)
-        , txDelegationAction = Just action
-        }
-
 {-------------------------------------------------------------------------------
                                  Fee Estimation
 -------------------------------------------------------------------------------}
@@ -3915,43 +3816,6 @@ data PoolRetirementEpochInfo = PoolRetirementEpochInfo
     }
     deriving (Eq, Generic, Show)
 
-guardJoin
-    :: Set PoolId
-    -> WalletDelegation
-    -> PoolId
-    -> Maybe PoolRetirementEpochInfo
-    -> Either ErrCannotJoin ()
-guardJoin knownPools delegation pid mRetirementEpochInfo = do
-    when (pid `Set.notMember` knownPools) $
-        Left (ErrNoSuchPool pid)
-
-    forM_ mRetirementEpochInfo $ \info ->
-        when (currentEpoch info >= retirementEpoch info) $
-            Left (ErrNoSuchPool pid)
-
-    when ((null next) && isDelegatingTo (== pid) active) $
-        Left (ErrAlreadyDelegating pid)
-
-    when (not (null next) && isDelegatingTo (== pid) (last next)) $
-        Left (ErrAlreadyDelegating pid)
-  where
-    WalletDelegation {active, next} = delegation
-
-guardQuit :: WalletDelegation -> Withdrawal -> Coin -> Either ErrCannotQuit ()
-guardQuit WalletDelegation{active,next} wdrl rewards = do
-    let last_ = maybe active (view #status) $ lastMay next
-
-    unless (isDelegatingTo anyone last_) $
-        Left ErrNotDelegatingOrAboutTo
-
-    case wdrl of
-        WithdrawalSelf {} -> return ()
-        _
-            | rewards == Coin 0  -> return ()
-            | otherwise          -> Left $ ErrNonNullRewards rewards
-  where
-    anyone = const True
-
 {-------------------------------------------------------------------------------
                                     Logging
 -------------------------------------------------------------------------------}