update 'postTransaction' handler to handle payments and withdrawals

lib/byron/src/Cardano/Wallet/Byron/Transaction.hs

@@ -112,7 +112,7 @@ newTransactionLayer _proxy protocolMagic = TransactionLayer
     }
   where
     _mkStdTx
-        :: (k 'AddressK XPrv, Passphrase "encryption")
+        :: (XPrv, Passphrase "encryption")
             -- Reward account
         -> (Address -> Maybe (k 'AddressK XPrv, Passphrase "encryption"))
             -- Key store

lib/core/src/Cardano/Wallet.hs

@@ -90,6 +90,7 @@ module Cardano.Wallet
     , ErrWalletNotResponding (..)
 
     -- ** Address
+    , createChangeAddress
     , createRandomAddress
     , importRandomAddresses
     , listAddresses
@@ -960,9 +961,9 @@ someChimericAccount
         , k ~ ShelleyKey
         )
     => SomeMnemonic
-    -> ChimericAccount
+    -> (XPrv, ChimericAccount)
 someChimericAccount mw =
-    toChimericAccount @s (publicKey acctK)
+    (getRawKey acctK, toChimericAccount @s (publicKey acctK))
   where
     rootK = Shelley.generateKeyFromSeed (mw, Nothing) mempty
     acctK = deriveRewardAccount mempty rootK
@@ -1071,6 +1072,25 @@ listAddresses ctx wid normalize = db & \DBLayer{..} -> do
     db = ctx ^. dbLayer @s @k
     primaryKey = PrimaryKey wid
 
+createChangeAddress
+    :: forall ctx s k.
+        ( HasDBLayer s k ctx
+        , GenChange s
+        )
+    => ctx
+    -> WalletId
+    -> ArgGenChange s
+    -> ExceptT ErrNoSuchWallet IO Address
+createChangeAddress ctx wid argGenChange = db & \DBLayer{..} -> do
+    mapExceptT atomically $ do
+        cp <- withNoSuchWallet wid (readCheckpoint pk)
+        let (addr, s') = genChange argGenChange (getState cp)
+        putCheckpoint pk (updateState s' cp)
+        pure addr
+  where
+    db = ctx ^. dbLayer @s @k
+    pk = PrimaryKey wid
+
 createRandomAddress
     :: forall ctx s k n.
         ( HasDBLayer s k ctx
@@ -1493,10 +1513,7 @@ signPayment
     => ctx
     -> WalletId
     -> ArgGenChange s
-    -> ( (k 'RootK XPrv, Passphrase "encryption")
-        ->
-         (k 'AddressK XPrv, Passphrase "encryption")
-       )
+    -> ((k 'RootK XPrv, Passphrase "encryption") -> (XPrv, Passphrase "encryption"))
        -- ^ Reward account derived from the root key (or somewhere else).
     -> Passphrase "raw"
     -> CoinSelection
@@ -1535,6 +1552,7 @@ signTx
         , IsOwned s k
         , HardDerivation k
         , Bounded (Index (AddressIndexDerivationType k) 'AddressK)
+        , WalletKey k
         )
     => ctx
     -> WalletId
@@ -1551,7 +1569,7 @@ signTx ctx wid pwd (UnsignedTx inpsNE outsNE) = db & \DBLayer{..} -> do
 
             let cs = mempty { inputs = inps, outputs = outs }
             let keyFrom = isOwned (getState cp) (xprv, pwdP)
-            let rewardAcnt = deriveRewardAccount @k pwdP xprv
+            let rewardAcnt = getRawKey $ deriveRewardAccount @k pwdP xprv
             (tx, sealedTx) <- withExceptT ErrSignPaymentMkTx $ ExceptT $ pure $
                 mkStdTx tl (rewardAcnt, pwdP) keyFrom (nodeTip ^. #slotNo) cs
 
@@ -1620,6 +1638,7 @@ signDelegation
         , GenChange s
         , HardDerivation k
         , AddressIndexDerivationType k ~ 'Soft
+        , WalletKey k
         )
     => ctx
     -> WalletId
@@ -1640,7 +1659,7 @@ signDelegation ctx wid argGenChange pwd coinSel action = db & \DBLayer{..} -> do
             withExceptT ErrSignDelegationNoSuchWallet $
                 putCheckpoint (PrimaryKey wid) (updateState s' cp)
 
-            let rewardAcnt = deriveRewardAccount @k pwdP xprv
+            let rewardAcnt = getRawKey $ deriveRewardAccount @k pwdP xprv
             let keyFrom = isOwned (getState cp) (xprv, pwdP)
             (tx, sealedTx) <- withExceptT ErrSignDelegationMkTx $ ExceptT $ pure $
                 case action of
@@ -1840,6 +1859,7 @@ joinStakePool
         , GenChange s
         , HardDerivation k
         , AddressIndexDerivationType k ~ 'Soft
+        , WalletKey k
         )
     => ctx
     -> W.EpochNo
@@ -1896,6 +1916,7 @@ quitStakePool
         , GenChange s
         , HardDerivation k
         , AddressIndexDerivationType k ~ 'Soft
+        , WalletKey k
         )
     => ctx
     -> WalletId

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

@@ -194,8 +194,8 @@ import Cardano.Wallet.Api.Types
     , KnownDiscovery (..)
     , MinWithdrawal (..)
     , PostExternalTransactionData (..)
-    , PostTransactionData
-    , PostTransactionFeeData
+    , PostPaymentOrWithdrawalData (..)
+    , PostPaymentOrWithdrawalFeeData (..)
     , WalletBalance (..)
     , WalletOrAccountPostData (..)
     , WalletPostData (..)
@@ -330,6 +330,8 @@ import Data.Generics.Labels
     ()
 import Data.List
     ( isInfixOf, isSubsequenceOf, sortOn )
+import Data.List.NonEmpty
+    ( NonEmpty (..) )
 import Data.Map.Strict
     ( Map )
 import Data.Maybe
@@ -627,7 +629,6 @@ mkShelleyWallet
         ( ctx ~ ApiLayer s t k
         , s ~ SeqState n k
         , IsOurs s Address
-        , IsOurs s ChimericAccount
         , HasWorkerRegistry s k ctx
         )
     => MkApiWallet ctx s ApiWallet
@@ -726,7 +727,6 @@ mkLegacyWallet
         , KnownDiscovery s
         , HasNetworkLayer t ctx
         , IsOurs s Address
-        , IsOurs s ChimericAccount
         )
     => ctx
     -> WalletId
@@ -1183,41 +1183,80 @@ postTransaction
         , HardDerivation k
         , Bounded (Index (AddressIndexDerivationType k) 'AddressK)
         , HasRewardAccount s k
+        , WalletKey k
         )
     => ctx
     -> ArgGenChange s
     -> ApiT WalletId
     -> Bool
-    -> PostTransactionData n
+    -> PostPaymentOrWithdrawalData n
     -> Handler (ApiTransaction n)
-postTransaction ctx genChange (ApiT wid) withdrawRewards body = do
-    let outs = coerceCoin <$> (body ^. #payments)
-    let pwd = coerce $ getApiT $ body ^. #passphrase
+postTransaction ctx genChange (ApiT wid) withdrawRewards = \case
+    PostPaymentOrWithdrawalData (Left body) -> do
+        let pwd = coerce $ getApiT $ body ^. #passphrase
+        let src = getApiMnemonicT $ body ^. #source
+        let (xprv, acct) = W.someChimericAccount src
+
+        selection <- withWorkerCtx ctx wid liftE liftE $ \wrk -> do
+            withdrawal <- if withdrawRewards
+                then do
+                    raw <- liftHandler $ W.queryRewardBalance @_ @t wrk acct
+                    liftIO $ W.readNextWithdrawal @_ @s @t @k wrk wid raw
+                else pure (Quantity 0)
+
+            -- TODO:
+            -- Fail when there's nothing to withdraw to not do a useless
+            -- transaction.
+
+            addr <- liftHandler $ W.createChangeAddress @_ @s @k wrk wid genChange
+            let outs = (TxOut addr (Coin 1)) :| []
+            liftHandler $ W.selectCoinsForPayment @_ @s @t wrk wid outs withdrawal
+
+        let mkRewardAccount _ = (xprv, mempty)
+        (tx, meta, time, wit) <- withWorkerCtx ctx wid liftE liftE $ \wrk -> liftHandler $
+            W.signPayment @_ @s @t @k wrk wid genChange mkRewardAccount pwd selection
+
+        withWorkerCtx ctx wid liftE liftE $ \wrk -> liftHandler $
+            W.submitTx @_ @s @t @k wrk wid (tx, meta, wit)
 
-    selection <- withWorkerCtx ctx wid liftE liftE $ \wrk -> do
-        withdrawal <- if withdrawRewards
-            then do
-                acct <- liftHandler $ W.readChimericAccount @_ @s @k wrk wid
-                raw <- liftHandler $ W.queryRewardBalance @_ @t wrk acct
-                liftIO $ W.readNextWithdrawal @_ @s @t @k wrk wid raw
-            else pure (Quantity 0)
-        liftHandler $ W.selectCoinsForPayment @_ @s @t wrk wid outs withdrawal
+        liftIO $ mkApiTransaction
+            ti
+            (txId tx)
+            (fmap Just <$> selection ^. #inputs)
+            (tx ^. #outputs)
+            (tx ^. #withdrawals)
+            (meta, time)
+            #pendingSince
 
-    let mkRewardAccount (rootK, pwdP) = (deriveRewardAccount @k pwdP rootK, pwdP)
-    (tx, meta, time, wit) <- withWorkerCtx ctx wid liftE liftE $ \wrk -> liftHandler $
-        W.signPayment @_ @s @t @k wrk wid genChange mkRewardAccount pwd selection
+    PostPaymentOrWithdrawalData (Right body) -> do
+        let pwd = coerce $ getApiT $ body ^. #passphrase
+        let outs = coerceCoin <$> (body ^. #payments)
 
-    withWorkerCtx ctx wid liftE liftE $ \wrk -> liftHandler $
-        W.submitTx @_ @s @t @k wrk wid (tx, meta, wit)
+        selection <- withWorkerCtx ctx wid liftE liftE $ \wrk -> do
+            withdrawal <- if withdrawRewards
+                then do
+                    acct <- liftHandler $ W.readChimericAccount @_ @s @k wrk wid
+                    raw <- liftHandler $ W.queryRewardBalance @_ @t wrk acct
+                    liftIO $ W.readNextWithdrawal @_ @s @t @k wrk wid raw
+                else pure (Quantity 0)
+            liftHandler $ W.selectCoinsForPayment @_ @s @t wrk wid outs withdrawal
 
-    liftIO $ mkApiTransaction
-        ti
-        (txId tx)
-        (fmap Just <$> selection ^. #inputs)
-        (tx ^. #outputs)
-        (tx ^. #withdrawals)
-        (meta, time)
-        #pendingSince
+        let mkRewardAccount (rootK, pwdP) =
+                (getRawKey $ deriveRewardAccount @k pwdP rootK, pwdP)
+        (tx, meta, time, wit) <- withWorkerCtx ctx wid liftE liftE $ \wrk -> liftHandler $
+            W.signPayment @_ @s @t @k wrk wid genChange mkRewardAccount pwd selection
+
+        withWorkerCtx ctx wid liftE liftE $ \wrk -> liftHandler $
+            W.submitTx @_ @s @t @k wrk wid (tx, meta, wit)
+
+        liftIO $ mkApiTransaction
+            ti
+            (txId tx)
+            (fmap Just <$> selection ^. #inputs)
+            (tx ^. #outputs)
+            (tx ^. #withdrawals)
+            (meta, time)
+            #pendingSince
   where
     ti :: TimeInterpreter IO
     ti = timeInterpreter (ctx ^. networkLayer @t)
@@ -1302,19 +1341,23 @@ postTransactionFee
     => ctx
     -> ApiT WalletId
     -> Bool
-    -> PostTransactionFeeData n
+    -> PostPaymentOrWithdrawalFeeData n
     -> Handler ApiFee
-postTransactionFee ctx (ApiT wid) withdrawRewards body = do
-    let outs = coerceCoin <$> (body ^. #payments)
-    withWorkerCtx ctx wid liftE liftE $ \wrk -> do
-        withdrawal <- if withdrawRewards
-            then do
-                acct <- liftHandler $ W.readChimericAccount @_ @s @k wrk wid
-                raw <- liftHandler $ W.queryRewardBalance @_ @t wrk acct
-                liftIO $ W.readNextWithdrawal @_ @s @t @k wrk wid raw
-            else pure $ Quantity 0
-        fee <- liftHandler $ W.estimateFeeForPayment @_ @s @t @k wrk wid outs withdrawal
-        pure $ apiFee fee
+postTransactionFee ctx (ApiT wid) withdrawRewards = \case
+    PostPaymentOrWithdrawalFeeData (Left _body) -> do
+        fail "TODO: postTransactionFee for withdrawals."
+
+    PostPaymentOrWithdrawalFeeData (Right body) -> do
+        let outs = coerceCoin <$> (body ^. #payments)
+        withWorkerCtx ctx wid liftE liftE $ \wrk -> do
+            withdrawal <- if withdrawRewards
+                then do
+                    acct <- liftHandler $ W.readChimericAccount @_ @s @k wrk wid
+                    raw <- liftHandler $ W.queryRewardBalance @_ @t wrk acct
+                    liftIO $ W.readNextWithdrawal @_ @s @t @k wrk wid raw
+                else pure $ Quantity 0
+            fee <- liftHandler $ W.estimateFeeForPayment @_ @s @t @k wrk wid outs withdrawal
+            pure $ apiFee fee
 
 joinStakePool
     :: forall ctx s t n k.
@@ -1324,6 +1367,7 @@ joinStakePool
         , GenChange s
         , HardDerivation k
         , AddressIndexDerivationType k ~ 'Soft
+        , WalletKey k
         , ctx ~ ApiLayer s t k
         )
     => ctx
@@ -1385,6 +1429,7 @@ quitStakePool
         , HasNetworkLayer t ctx
         , HardDerivation k
         , AddressIndexDerivationType k ~ 'Soft
+        , WalletKey k
         , ctx ~ ApiLayer s t k
         )
     => ctx
@@ -1446,6 +1491,7 @@ migrateWallet
         , HardDerivation k
         , Bounded (Index (AddressIndexDerivationType k) 'AddressK)
         , PaymentAddress n ByronKey
+        , WalletKey k
         )
     => ApiLayer s t k
         -- ^ Source wallet context

lib/core/src/Cardano/Wallet/Primitive/Model.hs

@@ -291,7 +291,7 @@ availableBalance pending =
 
 -- | Total balance = 'balance' . 'totalUTxO' +? rewards
 totalBalance
-    :: (IsOurs s Address, IsOurs s ChimericAccount)
+    :: IsOurs s Address
     => Set Tx
     -> Quantity "lovelace" Natural
     -> Wallet s
@@ -301,12 +301,9 @@ totalBalance pending (Quantity rewards) s =
   where
     hasPendingWithdrawals =
         not $ Set.null $ Set.filter
-            (any ourChimericAccount . Map.keys . withdrawals)
+            (not . Map.null . withdrawals)
             pending
 
-    ourChimericAccount acct =
-        evalState (state (isOurs acct)) (getState s)
-
 -- | Available UTxO = @pending ⋪ utxo@
 availableUTxO
     :: Set Tx
@@ -368,14 +365,6 @@ prefilterBlock b u0 = runState $ do
         state (isOurs $ dlgCertAccount cert) <&> \case
             False -> Nothing
             True -> Just cert
-    ourChimericAccount
-        :: IsOurs s ChimericAccount
-        => (ChimericAccount, Coin)
-        -> State s (Maybe Natural)
-    ourChimericAccount (acct, Coin c) =
-        state (isOurs acct) <&> \case
-            False -> Nothing
-            True -> Just $ fromIntegral c
     mkTxMeta :: Natural -> Direction -> TxMeta
     mkTxMeta amt dir = TxMeta
         { status = InLedger
@@ -385,17 +374,17 @@ prefilterBlock b u0 = runState $ do
         , amount = Quantity amt
         }
     applyTx
-        :: (IsOurs s Address, IsOurs s ChimericAccount)
+        :: (IsOurs s Address)
         => ([(Tx, TxMeta)], UTxO)
         -> Tx
         -> State s ([(Tx, TxMeta)], UTxO)
     applyTx (!txs, !u) tx = do
         ourU <- state $ utxoOurs tx
         let ourIns = Set.fromList (inputs tx) `Set.intersection` dom (u <> ourU)
         let u' = (u <> ourU) `excluding` ourIns
-        ourWithdrawals <- mapMaybeM ourChimericAccount $ Map.toList $ withdrawals tx
+        let wdrls = fromIntegral . getCoin <$> Map.elems (withdrawals tx)
         let received = balance ourU
-        let spent = balance (u `restrictedBy` ourIns) + sum ourWithdrawals
+        let spent = balance (u `restrictedBy` ourIns) + sum wdrls
         let hasKnownInput = ourIns /= mempty
         let hasKnownOutput = ourU /= mempty
         return $ if hasKnownOutput && not hasKnownInput then