Allow to return unsigned delegation certificate

Author: Julian Ospald

lib/core/src/Cardano/Wallet.hs

@@ -125,6 +125,7 @@ module Cardano.Wallet
     -- ** Delegation
     , PoolRetirementEpochInfo (..)
     , joinStakePool
+    , getStakePoolCoinSelection
     , quitStakePool
     , selectCoinsForDelegation
     , estimateFeeForDelegation
@@ -418,6 +419,7 @@ import Statistics.Quantile
 import Type.Reflection
     ( Typeable, typeRep )
 
+import qualified Cardano.Api.Typed as Cardano
 import qualified Cardano.Wallet.Primitive.AddressDiscovery.Random as Rnd
 import qualified Cardano.Wallet.Primitive.AddressDiscovery.Sequential as Seq
 import qualified Cardano.Wallet.Primitive.CoinSelection.Random as CoinSelection
@@ -1714,8 +1716,9 @@ signDelegation
     -> Passphrase "raw"
     -> CoinSelection
     -> DelegationAction
+    -> [Cardano.Certificate]
     -> ExceptT ErrSignDelegation IO (Tx, TxMeta, UTCTime, SealedTx)
-signDelegation ctx wid argGenChange pwd coinSel action = db & \DBLayer{..} -> do
+signDelegation ctx wid argGenChange pwd coinSel action certs = db & \DBLayer{..} -> do
     nodeTip <- withExceptT ErrSignDelegationNetwork $ currentNodeTip nl
     withRootKey @_ @s ctx wid pwd ErrSignDelegationWithRootKey $ \xprv scheme -> do
         let pwdP = preparePassphrase scheme pwd
@@ -1733,20 +1736,23 @@ signDelegation ctx wid argGenChange pwd coinSel action = db & \DBLayer{..} -> do
                 case action of
                     RegisterKeyAndJoin poolId ->
                         mkDelegationJoinTx tl poolId
+                            certs
                             (rewardAcnt, pwdP)
                             keyFrom
                             (nodeTip ^. #slotNo)
                             coinSel'
 
                     Join poolId ->
                         mkDelegationJoinTx tl poolId
+                            certs
                             (rewardAcnt, pwdP)
                             keyFrom
                             (nodeTip ^. #slotNo)
                             coinSel'
 
                     Quit ->
                         mkDelegationQuitTx tl
+                            certs
                             (rewardAcnt, pwdP)
                             keyFrom
                             (nodeTip ^. #slotNo)
@@ -1934,16 +1940,12 @@ getTransaction ctx wid tid = db & \DBLayer{..} -> do
                                   Delegation
 -------------------------------------------------------------------------------}
 
--- | Helper function to factor necessary logic for joining a stake pool.
-joinStakePool
+-- | Get the coin selection for joining a stake pool.
+getStakePoolCoinSelection
     :: forall ctx s t k.
         ( HasDBLayer s k ctx
         , HasLogger WalletLog ctx
-        , HasNetworkLayer t ctx
         , HasTransactionLayer t k ctx
-        , IsOwned s k
-        , IsOurs s ChimericAccount
-        , GenChange s
         , HardDerivation k
         , AddressIndexDerivationType k ~ 'Soft
         , WalletKey k
@@ -1954,10 +1956,9 @@ joinStakePool
     -> PoolId
     -> PoolLifeCycleStatus
     -> WalletId
-    -> ArgGenChange s
     -> Passphrase "raw"
-    -> ExceptT ErrJoinStakePool IO (Tx, TxMeta, UTCTime)
-joinStakePool ctx currentEpoch knownPools pid poolStatus wid argGenChange pwd =
+    -> ExceptT ErrJoinStakePool IO (CoinSelection, [Cardano.Certificate], DelegationAction)
+getStakePoolCoinSelection ctx currentEpoch knownPools pid poolStatus wid pwd =
     db & \DBLayer{..} -> do
 
         (isKeyReg, walMeta) <- mapExceptT atomically
@@ -1976,21 +1977,62 @@ joinStakePool ctx currentEpoch knownPools pid poolStatus wid argGenChange pwd =
         let action = if isKeyReg then Join pid else RegisterKeyAndJoin pid
         liftIO $ traceWith tr $ MsgIsStakeKeyRegistered isKeyReg
 
-        selection <- withExceptT ErrJoinStakePoolSelectCoin $
+        cs <- withExceptT ErrJoinStakePoolSelectCoin $
             selectCoinsForDelegation @ctx @s @t @k ctx wid action
 
+        withRootKey @_ @s ctx wid pwd ErrJoinStakePoolRootKey $ \xprv scheme -> do
+            let pwdP = preparePassphrase scheme pwd
+            let rewardAcnt = getRawKey $ deriveRewardAccount @k pwdP xprv
+            let certs = (mkDelegationCertificates tl) (W.Join pid)
+                    (rewardAcnt, pwdP) cs
+
+            pure (cs, certs, action)
+
+  where
+    tl = ctx ^. transactionLayer @t @k
+    db = ctx ^. dbLayer @s @k
+    tr = ctx ^. logger
+
+-- | Helper function to factor necessary logic for joining a stake pool.
+joinStakePool
+    :: forall ctx s t k.
+        ( HasDBLayer s k ctx
+        , HasLogger WalletLog ctx
+        , HasNetworkLayer t ctx
+        , HasTransactionLayer t k ctx
+        , IsOwned s k
+        , IsOurs s ChimericAccount
+        , GenChange s
+        , HardDerivation k
+        , AddressIndexDerivationType k ~ 'Soft
+        , WalletKey k
+        )
+    => ctx
+    -> W.EpochNo
+    -> Set PoolId
+    -> PoolId
+    -> PoolLifeCycleStatus
+    -> WalletId
+    -> ArgGenChange s
+    -> Passphrase "raw"
+    -> ExceptT ErrJoinStakePool IO (Tx, TxMeta, UTCTime)
+joinStakePool ctx currentEpoch knownPools pid poolStatus wid argGenChange pwd =
+    db & \DBLayer{..} -> do
+        (selection, certs, action) <- getStakePoolCoinSelection @ctx @s @t @k
+            ctx currentEpoch knownPools pid poolStatus wid pwd
+
         (tx, txMeta, txTime, sealedTx) <-
             withExceptT ErrJoinStakePoolSignDelegation $
                 signDelegation
                     @ctx @s @t @k ctx wid argGenChange pwd selection action
+                    certs
 
         withExceptT ErrJoinStakePoolSubmitTx $
             submitTx @ctx @s @t @k ctx wid (tx, txMeta, sealedTx)
 
         pure (tx, txMeta, txTime)
   where
     db = ctx ^. dbLayer @s @k
-    tr = ctx ^. logger
 
 -- | Helper function to factor necessary logic for quitting a stake pool.
 quitStakePool
@@ -2024,14 +2066,22 @@ quitStakePool ctx wid argGenChange pwd = db & \DBLayer{..} -> do
     selection <- withExceptT ErrQuitStakePoolSelectCoin $
         selectCoinsForDelegation @ctx @s @t @k ctx wid action
 
+    certs <- withRootKey @_ @s ctx wid pwd ErrQuitStakePoolRootKey $ \xprv scheme -> do
+        let pwdP = preparePassphrase scheme pwd
+        let rewardAcnt = getRawKey $ deriveRewardAccount @k pwdP xprv
+        pure $ (mkDelegationCertificates tl) W.Quit
+            (rewardAcnt, pwdP) selection
+
     (tx, txMeta, txTime, sealedTx) <- withExceptT ErrQuitStakePoolSignDelegation $
         signDelegation @ctx @s @t @k ctx wid argGenChange pwd selection action
+        certs
 
     withExceptT ErrQuitStakePoolSubmitTx $
         submitTx @ctx @s @t @k ctx wid (tx, txMeta, sealedTx)
 
     pure (tx, txMeta, txTime)
   where
+    tl = ctx ^. transactionLayer @t @k
     db = ctx ^. dbLayer @s @k
 
 
@@ -2309,6 +2359,7 @@ data ErrJoinStakePool
     | ErrJoinStakePoolSignDelegation ErrSignDelegation
     | ErrJoinStakePoolSubmitTx ErrSubmitTx
     | ErrJoinStakePoolCannotJoin ErrCannotJoin
+    | ErrJoinStakePoolRootKey ErrWithRootKey
     deriving (Generic, Eq, Show)
 
 data ErrQuitStakePool
@@ -2317,6 +2368,7 @@ data ErrQuitStakePool
     | ErrQuitStakePoolSignDelegation ErrSignDelegation
     | ErrQuitStakePoolSubmitTx ErrSubmitTx
     | ErrQuitStakePoolCannotQuit ErrCannotQuit
+    | ErrQuitStakePoolRootKey ErrWithRootKey
     deriving (Generic, Eq, Show)
 
 -- | Errors that can occur when fetching the reward balance of a wallet

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

@@ -115,6 +115,7 @@ import Cardano.Wallet.Api.Types
     , ApiAddressInspectData
     , ApiAddressT
     , ApiByronWallet
+    , ApiCoinSelectionCertT
     , ApiCoinSelectionT
     , ApiFee
     , ApiNetworkClock
@@ -123,6 +124,7 @@ import Cardano.Wallet.Api.Types
     , ApiPoolId
     , ApiPostRandomAddressData
     , ApiPutAddressesDataT
+    , ApiSelectCoinsActionDataT
     , ApiSelectCoinsDataT
     , ApiT
     , ApiTransactionT
@@ -304,6 +306,7 @@ type InspectAddress = "addresses"
 
 type CoinSelections n =
     SelectCoins n
+    :<|> SelectCoinsAction n
 
 -- | https://input-output-hk.github.io/cardano-wallet/api/#operation/selectCoins
 type SelectCoins n = "wallets"
@@ -313,6 +316,13 @@ type SelectCoins n = "wallets"
     :> ReqBody '[JSON] (ApiSelectCoinsDataT n)
     :> Post '[JSON] (ApiCoinSelectionT n)
 
+type SelectCoinsAction n = "wallets"
+    :> Capture "walletId" (ApiT WalletId)
+    :> "coin-selections"
+    :> "random"
+    :> ReqBody '[JSON] (ApiSelectCoinsActionDataT n)
+    :> Post '[JSON] (ApiCoinSelectionCertT n)
+
 {-------------------------------------------------------------------------------
                                   Transactions
 

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

@@ -49,6 +49,7 @@ module Cardano.Wallet.Api.Server
     , getUTxOsStatistics
     , getWallet
     , joinStakePool
+    , selectCoinsStakePool
     , listAddresses
     , listTransactions
     , getTransaction
@@ -345,6 +346,8 @@ import Data.Generics.Labels
     ()
 import Data.List
     ( isInfixOf, isSubsequenceOf, sortOn )
+import Data.List.NonEmpty
+    ( NonEmpty )
 import Data.Map.Strict
     ( Map )
 import Data.Maybe
@@ -417,11 +420,13 @@ import System.Random
 import Type.Reflection
     ( Typeable )
 
+import qualified Cardano.Api.Typed as Cardano
 import qualified Cardano.Wallet as W
 import qualified Cardano.Wallet.Api.Types as Api
 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
+import qualified Cardano.Wallet.Primitive.CoinSelection as C
 import qualified Cardano.Wallet.Primitive.Slotting as S
 import qualified Cardano.Wallet.Primitive.Types as W
 import qualified Cardano.Wallet.Registry as Registry
@@ -1119,6 +1124,50 @@ selectCoins ctx gen (ApiT wid) body =
         let outs = coerceCoin <$> body ^. #payments
         liftHandler $ W.selectCoinsExternal @_ @s @t @k wrk wid gen outs withdrawal Nothing
 
+selectCoinsStakePool
+    :: forall ctx s t n k e.
+        ( Buildable (ErrValidateSelection t)
+        , s ~ SeqState n k
+        , HardDerivation k
+        , AddressIndexDerivationType k ~ 'Soft
+        , WalletKey k
+        , ctx ~ ApiLayer s t k
+        , e ~ ErrValidateSelection t
+        )
+    => ctx
+    -> IO (Set PoolId)
+       -- ^ Known pools
+       -- We could maybe replace this with a @IO (PoolId -> Bool)@
+    -> (PoolId -> IO PoolLifeCycleStatus)
+    -> PoolId
+    -> WalletId
+    -> Passphrase "raw"
+    -> Handler (Api.ApiCoinSelectionCert n)
+selectCoinsStakePool ctx knownPools getPoolStatus pid wid pwd = do
+    poolStatus <- liftIO (getPoolStatus pid)
+    pools <- liftIO knownPools
+    curEpoch <- getCurrentEpoch ctx
+
+    (cs, certs, _) <- withWorkerCtx ctx wid liftE liftE $
+        \wrk -> liftHandler $
+            W.getStakePoolCoinSelection
+                @_ @s @t @k wrk
+                curEpoch pools pid poolStatus wid pwd
+    utx <- liftHandler $ UnsignedTx
+            <$> ensureNonEmpty (C.inputs cs) ErrSelectCoinsExternalUnableToAssignInputs
+            <*> ensureNonEmpty (C.outputs cs) ErrSelectCoinsExternalUnableToAssignOutputs
+    pure $ mkApiCoinSelectionCert certs utx
+  where
+    -- TODO: factor out
+    ensureNonEmpty
+        :: forall a. [a]
+        -> (WalletId -> ErrSelectCoinsExternal e)
+        -> ExceptT (ErrSelectCoinsExternal e) IO (NonEmpty a)
+    ensureNonEmpty mxs err = case NE.nonEmpty mxs of
+        Nothing -> throwE $ err wid
+        Just xs -> pure xs
+
+
 {-------------------------------------------------------------------------------
                                     Addresses
 -------------------------------------------------------------------------------}
@@ -1769,24 +1818,37 @@ rndStateChange ctx (ApiT wid) pwd =
             pure (xprv, preparePassphrase scheme pwd)
 
 -- | Makes an 'ApiCoinSelection' from the given 'UnsignedTx'.
-mkApiCoinSelection :: forall n. UnsignedTx -> ApiCoinSelection n
+mkApiCoinSelection :: forall (n :: NetworkDiscriminant). UnsignedTx -> ApiCoinSelection n
 mkApiCoinSelection (UnsignedTx inputs outputs) =
     ApiCoinSelection
         (mkApiCoinSelectionInput <$> inputs)
-        (mkAddressAmount <$> outputs)
-  where
-    mkAddressAmount :: TxOut -> AddressAmount (ApiT Address, Proxy n)
-    mkAddressAmount (TxOut addr (Coin c)) =
-        AddressAmount (ApiT addr, Proxy @n) (Quantity $ fromIntegral c)
-
-    mkApiCoinSelectionInput :: (TxIn, TxOut) -> ApiCoinSelectionInput n
-    mkApiCoinSelectionInput (TxIn txid index, TxOut addr (Coin c)) =
-        ApiCoinSelectionInput
-            { id = ApiT txid
-            , index = index
-            , address = (ApiT addr, Proxy @n)
-            , amount = Quantity $ fromIntegral c
-            }
+        (mkAddressAmount @n <$> outputs)
+
+mkAddressAmount
+    :: forall (n :: NetworkDiscriminant). TxOut -> AddressAmount (ApiT Address, Proxy n)
+mkAddressAmount (TxOut addr (Coin c)) =
+    AddressAmount (ApiT addr, Proxy @n) (Quantity $ fromIntegral c)
+
+mkApiCoinSelectionInput
+    :: forall (n :: NetworkDiscriminant). (TxIn, TxOut) -> ApiCoinSelectionInput n
+mkApiCoinSelectionInput (TxIn txid index, TxOut addr (Coin c)) =
+    ApiCoinSelectionInput
+        { id = ApiT txid
+        , index = index
+        , address = (ApiT addr, Proxy @n)
+        , amount = Quantity $ fromIntegral c
+        }
+
+-- | Makes an 'ApiCoinSelection' from the given 'UnsignedTx'.
+mkApiCoinSelectionCert
+    :: forall (n :: NetworkDiscriminant). [Cardano.Certificate]
+    -> UnsignedTx
+    -> Api.ApiCoinSelectionCert n
+mkApiCoinSelectionCert certs (UnsignedTx inputs outputs) =
+    Api.ApiCoinSelectionCert
+        (mkApiCoinSelectionInput <$> inputs)
+        (mkAddressAmount @n <$> outputs)
+        (ApiT <$> certs)
 
 mkApiTransaction
     :: forall n m. Monad m