From 30f2d383d03b4333ec532abd4fa393d6d9ba9f73 Mon Sep 17 00:00:00 2001 From: KtorZ Date: Tue, 28 Jul 2020 04:22:37 +0200 Subject: [PATCH] update 'postTransaction' handler to handle payments and withdrawals --- .../src/Cardano/Wallet/Byron/Transaction.hs | 2 +- lib/core/src/Cardano/Wallet.hs | 37 +++-- lib/core/src/Cardano/Wallet/Api/Server.hs | 128 ++++++++++++------ .../src/Cardano/Wallet/Primitive/Model.hs | 21 +-- lib/core/src/Cardano/Wallet/Transaction.hs | 6 +- .../Cardano/Wallet/Jormungandr/Transaction.hs | 10 +- .../src/Cardano/Wallet/Shelley/Transaction.hs | 6 +- 7 files changed, 133 insertions(+), 77 deletions(-) diff --git a/lib/byron/src/Cardano/Wallet/Byron/Transaction.hs b/lib/byron/src/Cardano/Wallet/Byron/Transaction.hs index 9fb5ea5197f..0b419259208 100644 --- a/lib/byron/src/Cardano/Wallet/Byron/Transaction.hs +++ b/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 diff --git a/lib/core/src/Cardano/Wallet.hs b/lib/core/src/Cardano/Wallet.hs index 7c48c6a41d5..beeb4eb1ac7 100644 --- a/lib/core/src/Cardano/Wallet.hs +++ b/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 diff --git a/lib/core/src/Cardano/Wallet/Api/Server.hs b/lib/core/src/Cardano/Wallet/Api/Server.hs index 7d81be8d279..b70ea8a6419 100644 --- a/lib/core/src/Cardano/Wallet/Api/Server.hs +++ b/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 diff --git a/lib/core/src/Cardano/Wallet/Primitive/Model.hs b/lib/core/src/Cardano/Wallet/Primitive/Model.hs index 2b13f9a68cd..45baec33e90 100644 --- a/lib/core/src/Cardano/Wallet/Primitive/Model.hs +++ b/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,7 +374,7 @@ 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) @@ -393,9 +382,9 @@ prefilterBlock b u0 = runState $ 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 diff --git a/lib/core/src/Cardano/Wallet/Transaction.hs b/lib/core/src/Cardano/Wallet/Transaction.hs index 4abfa094235..4fbd9eecc97 100644 --- a/lib/core/src/Cardano/Wallet/Transaction.hs +++ b/lib/core/src/Cardano/Wallet/Transaction.hs @@ -48,7 +48,7 @@ import Data.Word data TransactionLayer t k = TransactionLayer { mkStdTx - :: (k 'AddressK XPrv, Passphrase "encryption") + :: (XPrv, Passphrase "encryption") -- Reward account -> (Address -> Maybe (k 'AddressK XPrv, Passphrase "encryption")) -- Key store @@ -69,7 +69,7 @@ data TransactionLayer t k = TransactionLayer , mkDelegationJoinTx :: PoolId -- Pool Id to which we're planning to delegate - -> (k 'AddressK XPrv, Passphrase "encryption") + -> (XPrv, Passphrase "encryption") -- Reward account -> (Address -> Maybe (k 'AddressK XPrv, Passphrase "encryption")) -- Key store @@ -87,7 +87,7 @@ data TransactionLayer t k = TransactionLayer -- HD account keys are something different) , mkDelegationQuitTx - :: (k 'AddressK XPrv, Passphrase "encryption") + :: (XPrv, Passphrase "encryption") -- Reward account -> (Address -> Maybe (k 'AddressK XPrv, Passphrase "encryption")) -- Key store diff --git a/lib/jormungandr/src/Cardano/Wallet/Jormungandr/Transaction.hs b/lib/jormungandr/src/Cardano/Wallet/Jormungandr/Transaction.hs index ab4e8c97a40..4c4234431f8 100644 --- a/lib/jormungandr/src/Cardano/Wallet/Jormungandr/Transaction.hs +++ b/lib/jormungandr/src/Cardano/Wallet/Jormungandr/Transaction.hs @@ -17,7 +17,7 @@ module Cardano.Wallet.Jormungandr.Transaction import Prelude import Cardano.Address.Derivation - ( xpubPublicKey ) + ( toXPub, xpubPublicKey ) import Cardano.Wallet.Jormungandr.Binary ( Fragment (..) , MkFragment (..) @@ -89,23 +89,23 @@ newTransactionLayer block0H = TransactionLayer ) keyFrom (CS.inputs cs) (CS.outputs cs) , mkDelegationJoinTx = \pool accXPrv keyFrom _ cs -> - let acc = ChimericAccount . xpubPublicKey . getRawKey . publicKey . fst $ accXPrv + let acc = ChimericAccount . xpubPublicKey . toXPub . fst $ accXPrv in mkFragment ( MkFragmentStakeDelegation (txWitnessTagFor @k) (DlgFull pool) acc - (first getRawKey accXPrv) + accXPrv ) keyFrom (CS.inputs cs) (CS.outputs cs) , mkDelegationQuitTx = \accXPrv keyFrom _ cs -> - let acc = ChimericAccount . xpubPublicKey . getRawKey . publicKey . fst $ accXPrv + let acc = ChimericAccount . xpubPublicKey . toXPub . fst $ accXPrv in mkFragment ( MkFragmentStakeDelegation (txWitnessTagFor @k) DlgNone acc - (first getRawKey accXPrv) + accXPrv ) keyFrom (CS.inputs cs) (CS.outputs cs) , initDelegationSelection = const mempty diff --git a/lib/shelley/src/Cardano/Wallet/Shelley/Transaction.hs b/lib/shelley/src/Cardano/Wallet/Shelley/Transaction.hs index 4618fb1cbbe..f2765f16dc6 100644 --- a/lib/shelley/src/Cardano/Wallet/Shelley/Transaction.hs +++ b/lib/shelley/src/Cardano/Wallet/Shelley/Transaction.hs @@ -170,7 +170,7 @@ mkTx -> TxPayload Cardano.Shelley -> SlotNo -- ^ Time to Live - -> (k 'AddressK XPrv, Passphrase "encryption") + -> (XPrv, Passphrase "encryption") -- ^ Reward account -> (Address -> Maybe (k 'AddressK XPrv, Passphrase "encryption")) -> CoinSelection @@ -178,7 +178,7 @@ mkTx mkTx networkId (TxPayload certs mkExtraWits) timeToLive (rewardAcnt, pwdAcnt) keyFrom cs = do let wdrls = mkWithdrawals networkId - (toChimericAccountRaw . getRawKey . publicKey $ rewardAcnt) + (toChimericAccountRaw . toXPub $ rewardAcnt) (withdrawal cs) let unsigned = mkUnsignedTx timeToLive cs wdrls certs @@ -192,7 +192,7 @@ mkTx networkId (TxPayload certs mkExtraWits) timeToLive (rewardAcnt, pwdAcnt) ke let wdrlsWits | null wdrls = [] | otherwise = - [mkShelleyWitness unsigned (getRawKey rewardAcnt, pwdAcnt)] + [mkShelleyWitness unsigned (rewardAcnt, pwdAcnt)] pure $ mkExtraWits unsigned <> addrWits <> wdrlsWits