From 6b13278bbe0c07b092039be1163b45923ca858ce Mon Sep 17 00:00:00 2001 From: Heinrich Apfelmus Date: Tue, 29 Oct 2024 15:32:31 +0100 Subject: [PATCH 1/7] Adapt to latest `cardano-wallet-agda` --- cabal.project | 4 ++-- .../src/Cardano/Wallet/Deposit/Pure.hs | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/cabal.project b/cabal.project index 1244d0b1410..5245230409a 100644 --- a/cabal.project +++ b/cabal.project @@ -157,8 +157,8 @@ source-repository-package source-repository-package type: git location: https://github.com/cardano-foundation/cardano-wallet-agda - tag: 20b263d494ee91d2f353e2645c045f728d7eb076 - --sha256: 1j8mph2frsxqwq5ajsfhg0ixwxrs73dls34kbf0s0gh0y1gchvkb + tag: 04fb3e743ab874811d6c6850a218eee8bf110866 + --sha256: 1m1kxinqir9a5i261ph7lah5wpy9qic9yqk47x54q65zws8r4ply subdir: lib/customer-deposit-wallet-pure lib/cardano-wallet-read diff --git a/lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/Pure.hs b/lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/Pure.hs index 1799b42bed9..b6440fa16ac 100644 --- a/lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/Pure.hs +++ b/lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/Pure.hs @@ -217,7 +217,7 @@ fromXPubAndGenesis xpub knownCustomerCount genesisData = { walletTip = Read.GenesisPoint , addresses = Address.fromXPubAndCount network xpub knownCustomerCount - , utxoHistory = UTxOHistory.empty initialUTxO + , utxoHistory = UTxOHistory.fromOrigin initialUTxO , txHistory = mempty , submissions = Sbm.empty , rootXSignKey = Nothing From 303c4a9fc1e7e6ce6e5451753bd14db09c089ec0 Mon Sep 17 00:00:00 2001 From: Heinrich Apfelmus Date: Mon, 28 Oct 2024 16:42:47 +0100 Subject: [PATCH 2/7] Change argument of `signTx` from `Write.TxBody` to `Write.Tx` --- .../rest/Cardano/Wallet/Deposit/REST.hs | 10 +++++----- .../src/Cardano/Wallet/Deposit/IO.hs | 8 ++++---- .../src/Cardano/Wallet/Deposit/Pure.hs | 16 +++++++++------- .../test/scenario/Test/Scenario/Blockchain.hs | 6 +++--- .../Scenario/Wallet/Deposit/Exchanges.lhs.md | 6 +++--- 5 files changed, 24 insertions(+), 22 deletions(-) diff --git a/lib/customer-deposit-wallet/rest/Cardano/Wallet/Deposit/REST.hs b/lib/customer-deposit-wallet/rest/Cardano/Wallet/Deposit/REST.hs index 6731cb4a1c0..c4f2f95d32f 100644 --- a/lib/customer-deposit-wallet/rest/Cardano/Wallet/Deposit/REST.hs +++ b/lib/customer-deposit-wallet/rest/Cardano/Wallet/Deposit/REST.hs @@ -44,7 +44,7 @@ module Cardano.Wallet.Deposit.REST -- ** Writing to the blockchain , createPayment , getBIP32PathsForOwnedInputs - , signTxBody + , signTx , walletExists , walletPublicIdentity , deleteWallet @@ -409,12 +409,12 @@ createPayment createPayment = onWalletInstance . WalletIO.createPayment getBIP32PathsForOwnedInputs - :: Write.TxBody + :: Write.Tx -> WalletResourceM [BIP32Path] getBIP32PathsForOwnedInputs = onWalletInstance . WalletIO.getBIP32PathsForOwnedInputs -signTxBody - :: Write.TxBody +signTx + :: Write.Tx -> WalletResourceM (Maybe Write.Tx) -signTxBody = onWalletInstance . WalletIO.signTxBody +signTx = onWalletInstance . WalletIO.signTx diff --git a/lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/IO.hs b/lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/IO.hs index 9ed07f8c392..20f9885c8df 100644 --- a/lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/IO.hs +++ b/lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/IO.hs @@ -33,7 +33,7 @@ module Cardano.Wallet.Deposit.IO -- ** Writing to the blockchain , createPayment , getBIP32PathsForOwnedInputs - , signTxBody + , signTx , WalletStore , walletPublicIdentity ) where @@ -293,12 +293,12 @@ createPayment a w = Wallet.createPayment a <$> readWalletState w getBIP32PathsForOwnedInputs - :: Write.TxBody -> WalletInstance -> IO [BIP32Path] + :: Write.Tx -> WalletInstance -> IO [BIP32Path] getBIP32PathsForOwnedInputs a w = Wallet.getBIP32PathsForOwnedInputs a <$> readWalletState w -signTxBody :: Write.TxBody -> WalletInstance -> IO (Maybe Write.Tx) -signTxBody txbody w = Wallet.signTxBody txbody <$> readWalletState w +signTx :: Write.Tx -> WalletInstance -> IO (Maybe Write.Tx) +signTx a w = Wallet.signTx a <$> readWalletState w {----------------------------------------------------------------------------- Logging diff --git a/lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/Pure.hs b/lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/Pure.hs index b6440fa16ac..548b8f90144 100644 --- a/lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/Pure.hs +++ b/lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/Pure.hs @@ -42,7 +42,7 @@ module Cardano.Wallet.Deposit.Pure , BIP32Path (..) , DerivationType (..) , getBIP32PathsForOwnedInputs - , signTxBody + , signTx , addTxSubmission , listTxsInSubmission @@ -352,13 +352,15 @@ createPayment = undefined -- needs balanceTx -- needs to sign the transaction -getBIP32PathsForOwnedInputs - :: Write.TxBody -> WalletState -> [BIP32Path] -getBIP32PathsForOwnedInputs txbody w = +getBIP32PathsForOwnedInputs :: Write.Tx -> WalletState -> [BIP32Path] +getBIP32PathsForOwnedInputs tx w = getBIP32Paths w . resolveInputAddresses - $ Write.spendInputs txbody <> Write.collInputs txbody + $ Write.spendInputs txBody <> Write.collInputs txBody where + txBody :: Write.TxBody + txBody = undefined tx + resolveInputAddresses :: Set Read.TxIn -> [Read.Address] resolveInputAddresses ins = map (Read.address . snd) @@ -369,8 +371,8 @@ getBIP32Paths :: WalletState -> [Read.Address] -> [BIP32Path] getBIP32Paths w = mapMaybe $ Address.getBIP32Path (addresses w) -signTxBody :: Write.TxBody -> WalletState -> Maybe Write.Tx -signTxBody _txbody _w = undefined +signTx :: Write.Tx -> WalletState -> Maybe Write.Tx +signTx _tx _w = undefined addTxSubmission :: Write.Tx -> WalletState -> WalletState addTxSubmission _tx _w = undefined diff --git a/lib/customer-deposit-wallet/test/scenario/Test/Scenario/Blockchain.hs b/lib/customer-deposit-wallet/test/scenario/Test/Scenario/Blockchain.hs index 0463bed8d6e..56c3ddbb946 100644 --- a/lib/customer-deposit-wallet/test/scenario/Test/Scenario/Blockchain.hs +++ b/lib/customer-deposit-wallet/test/scenario/Test/Scenario/Blockchain.hs @@ -122,14 +122,14 @@ payFromFaucet env destinations = Map.fromList $ zip [toEnum 0..] $ map toTxOut destinations , Write.collRet = Nothing } - tx = signTx (xprv (faucet env)) [] txBody + tx = signTx (xprv (faucet env)) [] $ Write.mkTx txBody {----------------------------------------------------------------------------- Transaction submission ------------------------------------------------------------------------------} -signTx :: XPrv -> [BIP32Path] -> Write.TxBody -> Write.Tx -signTx _ _ = Write.mkTx +signTx :: XPrv -> [BIP32Path] -> Write.Tx -> Write.Tx +signTx _ _ = id submitTx :: ScenarioEnv -> Write.Tx -> IO () submitTx env tx = do diff --git a/lib/customer-deposit-wallet/test/scenario/Test/Scenario/Wallet/Deposit/Exchanges.lhs.md b/lib/customer-deposit-wallet/test/scenario/Test/Scenario/Wallet/Deposit/Exchanges.lhs.md index 99f4c8bb5ab..ee75b8e53ff 100644 --- a/lib/customer-deposit-wallet/test/scenario/Test/Scenario/Wallet/Deposit/Exchanges.lhs.md +++ b/lib/customer-deposit-wallet/test/scenario/Test/Scenario/Wallet/Deposit/Exchanges.lhs.md @@ -204,9 +204,9 @@ scenarioCreatePayment xprv env destination w = do assert $ value1 == (coin <> coin) -- createPayment - Just txBody <- Wallet.createPayment [(destination, coin)] w - paths <- Wallet.getBIP32PathsForOwnedInputs txBody w - let tx = signTx xprv paths txBody + Right txUnsigned <- Wallet.createPayment [(destination, coin)] w + paths <- Wallet.getBIP32PathsForOwnedInputs txUnsigned w + let tx = signTx xprv paths txUnsigned submitTx env tx -- funds have been moved out of the wallet From 905e18ef2007f66a619a235916ce90795f387cfe Mon Sep 17 00:00:00 2001 From: Heinrich Apfelmus Date: Mon, 21 Oct 2024 18:18:48 +0200 Subject: [PATCH 3/7] Implement `createPayment`, pure --- .../customer-deposit-wallet.cabal | 4 + .../src/Cardano/Wallet/Deposit/Pure.hs | 120 +++++++++++++++++- .../src/Cardano/Wallet/Deposit/Read.hs | 14 +- 3 files changed, 132 insertions(+), 6 deletions(-) diff --git a/lib/customer-deposit-wallet/customer-deposit-wallet.cabal b/lib/customer-deposit-wallet/customer-deposit-wallet.cabal index 8a923a85c93..dbc7e41e718 100644 --- a/lib/customer-deposit-wallet/customer-deposit-wallet.cabal +++ b/lib/customer-deposit-wallet/customer-deposit-wallet.cabal @@ -57,6 +57,7 @@ library , cardano-balance-tx , cardano-crypto , cardano-ledger-api + , cardano-ledger-core , cardano-strict-containers , cardano-wallet , cardano-wallet-network-layer @@ -67,16 +68,19 @@ library , customer-deposit-wallet-pure , delta-store , delta-types + , digest , fingertree , io-classes , microlens , monoidal-containers , mtl + , MonadRandom , mwc-random , OddWord , random , text , time + , transformers exposed-modules: Cardano.Wallet.Deposit.IO diff --git a/lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/Pure.hs b/lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/Pure.hs index 548b8f90144..caec08e1f14 100644 --- a/lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/Pure.hs +++ b/lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/Pure.hs @@ -2,6 +2,7 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} module Cardano.Wallet.Deposit.Pure @@ -38,7 +39,9 @@ module Cardano.Wallet.Deposit.Pure , getTxHistoryByTime -- ** Writing to the blockchain + , ErrCreatePayment (..) , createPayment + , BIP32Path (..) , DerivationType (..) , getBIP32PathsForOwnedInputs @@ -93,6 +96,15 @@ import Cardano.Wallet.Deposit.Read , TxId , WithOrigin ) +import Control.Monad.Trans.Except + ( runExceptT + ) +import Data.Bifunctor + ( first + ) +import Data.Digest.CRC32 + ( crc32 + ) import Data.Foldable ( fold , foldl' @@ -127,6 +139,8 @@ import qualified Cardano.Wallet.Deposit.Pure.UTxO as UTxO import qualified Cardano.Wallet.Deposit.Pure.UTxO.UTxOHistory as UTxOHistory import qualified Cardano.Wallet.Deposit.Read as Read import qualified Cardano.Wallet.Deposit.Write as Write +import qualified Cardano.Wallet.Read.Hash as Hash +import qualified Control.Monad.Random.Strict as Random import qualified Data.Delta as Delta import qualified Data.List as L import qualified Data.Map.Strict as Map @@ -139,11 +153,18 @@ type Customer = Address.Customer data WalletState = WalletState { walletTip :: Read.ChainPoint + -- ^ The wallet includes information from all blocks until + -- and including this one. , addresses :: !Address.AddressState + -- ^ Addresses and public keys known to this wallet. , utxoHistory :: !UTxOHistory.UTxOHistory + -- ^ UTxO of this wallet, with support for rollbacks. , txHistory :: !TxHistory + -- ^ (Summarized) transaction history of this wallet. , submissions :: Sbm.TxSubmissions + -- ^ Queue of pending transactions. , rootXSignKey :: Maybe XPrv + -- ^ Maybe a private key for signing transactions. -- , info :: !WalletInfo } @@ -342,15 +363,99 @@ wonders interval = {----------------------------------------------------------------------------- Operations - Writing to blockchain + Constructing transactions ------------------------------------------------------------------------------} +data ErrCreatePayment + = ErrCreatePaymentNotRecentEra (Read.EraValue Read.Era) + | ErrCreatePaymentBalanceTx (Write.ErrBalanceTx Write.Conway) + deriving (Eq, Show) +-- | Create a payment to a list of destinations. createPayment - :: [(Address, Write.Value)] -> WalletState -> Maybe Write.TxBody -createPayment = undefined + :: Read.EraValue Read.PParams + -> Write.TimeTranslation + -> [(Address, Write.Value)] + -> WalletState + -> Either ErrCreatePayment Write.Tx +createPayment (Read.EraValue (Read.PParams pparams :: Read.PParams era)) a b w = + case Read.theEra :: Read.Era era of + Read.Conway -> + first ErrCreatePaymentBalanceTx + $ createPaymentConway pparams a b w + era' -> Left $ ErrCreatePaymentNotRecentEra (Read.EraValue era') + +-- | In the Conway era: Create a payment to a list of destinations. +createPaymentConway + :: Write.PParams Write.Conway + -> Write.TimeTranslation + -> [(Address, Write.Value)] + -> WalletState + -> Either (Write.ErrBalanceTx Write.Conway) Write.Tx +createPaymentConway pparams timeTranslation destinations w = + fmap (Read.Tx . fst) + . flip Random.evalRand (pilferRandomGen w) + . runExceptT + . balance + (availableUTxO w) + (addresses w) + . mkPartialTx + $ paymentTxBody + where + paymentTxBody :: Write.TxBody + paymentTxBody = Write.TxBody + { spendInputs = mempty + , collInputs = mempty + , txouts = + Map.fromList $ zip [(toEnum 0)..] $ map (uncurry Write.mkTxOut) destinations + , collRet = Nothing + } --- needs balanceTx --- needs to sign the transaction + mkPartialTx :: Write.TxBody -> Write.PartialTx Write.Conway + mkPartialTx txbody = Write.PartialTx + { tx = Read.unTx $ Write.mkTx txbody + , extraUTxO = mempty :: Write.UTxO Write.Conway + , redeemers = mempty + , stakeKeyDeposits = Write.StakeKeyDepositMap mempty + , timelockKeyWitnessCounts = Write.TimelockKeyWitnessCounts mempty + } + + balance utxo addressState = + Write.balanceTx + pparams + timeTranslation + Write.AllKeyPaymentCredentials + (Write.constructUTxOIndex $ Write.toConwayUTxO utxo) + (changeAddressGen addressState) + () + + changeAddressGen s = Write.ChangeAddressGen + { Write.genChangeAddress = + first Read.decompactAddr . Address.newChangeAddress s + , Write.maxLengthChangeAddress = + Read.decompactAddr $ Address.mockMaxLengthChangeAddress s + } + +-- | Use entropy contained in the current 'WalletState' +-- to construct a pseudorandom seed. +-- (NOT a viable source of cryptographic randomness.) +-- +-- Possible downsides of this approach: +-- +-- 1. security/privacy +-- 2. concurrency +-- 3. retries for different coin selections +pilferRandomGen :: WalletState -> Random.StdGen +pilferRandomGen = + Random.mkStdGen . fromEnum . fromChainPoint . walletTip + where + fromChainPoint (Read.GenesisPoint) = 0 + fromChainPoint (Read.BlockPoint _ headerHash) = + crc32 $ Hash.hashToBytes headerHash + +{----------------------------------------------------------------------------- + Operations + Signing transactions +------------------------------------------------------------------------------} getBIP32PathsForOwnedInputs :: Write.Tx -> WalletState -> [BIP32Path] getBIP32PathsForOwnedInputs tx w = @@ -374,6 +479,11 @@ getBIP32Paths w = signTx :: Write.Tx -> WalletState -> Maybe Write.Tx signTx _tx _w = undefined +{----------------------------------------------------------------------------- + Operations + Pending transactions +------------------------------------------------------------------------------} + addTxSubmission :: Write.Tx -> WalletState -> WalletState addTxSubmission _tx _w = undefined diff --git a/lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/Read.hs b/lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/Read.hs index e07113a452b..d3b04076f21 100644 --- a/lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/Read.hs +++ b/lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/Read.hs @@ -8,9 +8,11 @@ -- -- TODO: Match this up with the @Read@ hierarchy. module Cardano.Wallet.Deposit.Read - ( Read.IsEra + ( Read.IsEra (..) + , Read.Era (..) , Read.EraValue (..) , Read.Conway + , Read.getEra , Read.SlotNo , Read.ChainPoint (..) @@ -22,6 +24,9 @@ module Cardano.Wallet.Deposit.Read , KeyHash , NetworkTag (..) , mkEnterpriseAddress + , Addr + , compactAddr + , decompactAddr , Ix , Read.TxIn @@ -43,6 +48,8 @@ module Cardano.Wallet.Deposit.Read , mockNextBlock , Read.mockRawHeaderHash + , Read.PParams (..) + , Read.GenesisData , Read.GenesisHash , Read.mockGenesisDataMainnet @@ -53,6 +60,11 @@ module Cardano.Wallet.Deposit.Read import Prelude +import Cardano.Ledger.Address + ( Addr + , compactAddr + , decompactAddr + ) import Cardano.Wallet.Address.Encoding ( Credential (..) , EnterpriseAddr (..) From 4710c063e93772b65b6ce2208e1a7ef37e31154e Mon Sep 17 00:00:00 2001 From: Heinrich Apfelmus Date: Mon, 28 Oct 2024 16:06:14 +0100 Subject: [PATCH 4/7] Add `currentPParams` to `NetworkEnv` --- .../src/Cardano/Wallet/Deposit/IO/Network/Mock.hs | 2 ++ .../src/Cardano/Wallet/Deposit/IO/Network/Type.hs | 3 +++ lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/Read.hs | 1 + 3 files changed, 6 insertions(+) diff --git a/lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/IO/Network/Mock.hs b/lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/IO/Network/Mock.hs index 218e8604974..5f1bec3e963 100644 --- a/lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/IO/Network/Mock.hs +++ b/lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/IO/Network/Mock.hs @@ -89,6 +89,8 @@ newNetworkEnvMock = do -- brief delay to account for asynchronous chain followers threadDelay 100 pure $ Right () + , currentPParams = + pure $ Read.EraValue Read.mockPParamsConway , getTimeInterpreter = pure Time.mockTimeInterpreter , slotsToUTCTimes = pure . Time.unsafeSlotsToUTCTimes diff --git a/lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/IO/Network/Type.hs b/lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/IO/Network/Type.hs index bf094edc5b2..246a97a6870 100644 --- a/lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/IO/Network/Type.hs +++ b/lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/IO/Network/Type.hs @@ -60,6 +60,9 @@ data NetworkEnv m block = NetworkEnv :: Write.Tx -> m (Either ErrPostTx ()) -- ^ Post a transaction to the Cardano network. + , currentPParams + :: m (Read.EraValue Read.PParams) + -- ^ Current protocol paramters. , getTimeInterpreter :: m Time.TimeInterpreter -- ^ Get the current 'TimeInterpreter' from the Cardano node. diff --git a/lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/Read.hs b/lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/Read.hs index d3b04076f21..2ff13425859 100644 --- a/lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/Read.hs +++ b/lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/Read.hs @@ -49,6 +49,7 @@ module Cardano.Wallet.Deposit.Read , Read.mockRawHeaderHash , Read.PParams (..) + , Read.mockPParamsConway , Read.GenesisData , Read.GenesisHash From eb891da1064e398260fce7d973f53120327a57e5 Mon Sep 17 00:00:00 2001 From: Heinrich Apfelmus Date: Mon, 28 Oct 2024 14:38:28 +0100 Subject: [PATCH 5/7] Add `toTimeTranslationPure` --- .../src/Cardano/Wallet/Deposit/Time.hs | 5 ++++- .../Wallet/Primitive/Slotting/TimeTranslation.hs | 14 +++++++++++++- 2 files changed, 17 insertions(+), 2 deletions(-) diff --git a/lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/Time.hs b/lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/Time.hs index 87d97d53a84..815322becdb 100644 --- a/lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/Time.hs +++ b/lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/Time.hs @@ -34,7 +34,7 @@ import Cardano.Wallet.Primitive.Slotting , mkSingleEraInterpreter ) import Cardano.Wallet.Primitive.Slotting.TimeTranslation - ( toTimeTranslation + ( toTimeTranslationPure ) import Cardano.Wallet.Primitive.Types.SlottingParameters ( ActiveSlotCoefficient (..) @@ -92,6 +92,9 @@ mockSlottingParameters = SlottingParameters {----------------------------------------------------------------------------- TimeInterpreter ------------------------------------------------------------------------------} +toTimeTranslation :: TimeInterpreter -> Write.TimeTranslation +toTimeTranslation = toTimeTranslationPure + unsafeSlotsToUTCTimes :: Set.Set Slot -> Map.Map Slot (WithOrigin UTCTime) unsafeSlotsToUTCTimes slots = Map.fromList $ do diff --git a/lib/wallet/src/Cardano/Wallet/Primitive/Slotting/TimeTranslation.hs b/lib/wallet/src/Cardano/Wallet/Primitive/Slotting/TimeTranslation.hs index 4fa04d3c62d..057e2bc0f7b 100644 --- a/lib/wallet/src/Cardano/Wallet/Primitive/Slotting/TimeTranslation.hs +++ b/lib/wallet/src/Cardano/Wallet/Primitive/Slotting/TimeTranslation.hs @@ -1,5 +1,6 @@ module Cardano.Wallet.Primitive.Slotting.TimeTranslation - ( toTimeTranslation + ( toTimeTranslation + , toTimeTranslationPure ) where import Prelude @@ -18,6 +19,9 @@ import Control.Monad.Trans.Except , runExcept , runExceptT ) +import Data.Functor.Identity + ( Identity (runIdentity) + ) import Internal.Cardano.Write.Tx.TimeTranslation ( TimeTranslation , timeTranslationFromEpochInfo @@ -34,3 +38,11 @@ toTimeTranslation timeInterpreter = do runExceptT (toEpochInfo timeInterpreter) >>= either throwIO (pure . hoistEpochInfo runExcept) pure $ timeTranslationFromEpochInfo (getSystemStart timeInterpreter) info + +toTimeTranslationPure + :: TimeInterpreter Identity + -> TimeTranslation +toTimeTranslationPure ti = + timeTranslationFromEpochInfo + (getSystemStart ti) + (hoistEpochInfo runExcept $ runIdentity $ toEpochInfo ti) From 80aeecda9b06b56491355b4aa73ec66862c130fd Mon Sep 17 00:00:00 2001 From: Heinrich Apfelmus Date: Mon, 28 Oct 2024 17:43:32 +0100 Subject: [PATCH 6/7] Implement `createPayment`, IO --- .../rest/Cardano/Wallet/Deposit/REST.hs | 3 ++- .../src/Cardano/Wallet/Deposit/IO.hs | 15 ++++++++++++--- 2 files changed, 14 insertions(+), 4 deletions(-) diff --git a/lib/customer-deposit-wallet/rest/Cardano/Wallet/Deposit/REST.hs b/lib/customer-deposit-wallet/rest/Cardano/Wallet/Deposit/REST.hs index c4f2f95d32f..cdfbb22bb36 100644 --- a/lib/customer-deposit-wallet/rest/Cardano/Wallet/Deposit/REST.hs +++ b/lib/customer-deposit-wallet/rest/Cardano/Wallet/Deposit/REST.hs @@ -72,6 +72,7 @@ import Cardano.Wallet.Deposit.IO.Resource ) import Cardano.Wallet.Deposit.Pure ( Customer + , ErrCreatePayment , Word31 , fromXPubAndGenesis ) @@ -405,7 +406,7 @@ getTxHistoryByTime = onWalletInstance WalletIO.getTxHistoryByTime createPayment :: [(Address, Read.Value)] - -> WalletResourceM (Maybe Write.TxBody) + -> WalletResourceM (Either ErrCreatePayment Write.Tx) createPayment = onWalletInstance . WalletIO.createPayment getBIP32PathsForOwnedInputs diff --git a/lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/IO.hs b/lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/IO.hs index 20f9885c8df..6450db75339 100644 --- a/lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/IO.hs +++ b/lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/IO.hs @@ -85,6 +85,7 @@ import Data.Time import qualified Cardano.Wallet.Deposit.IO.Network.Type as Network import qualified Cardano.Wallet.Deposit.Pure as Wallet import qualified Cardano.Wallet.Deposit.Read as Read +import qualified Cardano.Wallet.Deposit.Time as Time import qualified Cardano.Wallet.Deposit.Write as Write import qualified Control.Concurrent.Async as Async import qualified Data.DBVar as DBVar @@ -288,9 +289,17 @@ rollBackward w point = ------------------------------------------------------------------------------} createPayment - :: [(Address, Read.Value)] -> WalletInstance -> IO (Maybe Write.TxBody) -createPayment a w = - Wallet.createPayment a <$> readWalletState w + :: [(Address, Read.Value)] + -> WalletInstance + -> IO (Either Wallet.ErrCreatePayment Write.Tx) +createPayment a w = do + timeTranslation <- + Time.toTimeTranslation <$> Network.getTimeInterpreter network + pparams <- + Network.currentPParams network + Wallet.createPayment pparams timeTranslation a <$> readWalletState w + where + network = networkEnv $ bootEnv $ env w getBIP32PathsForOwnedInputs :: Write.Tx -> WalletInstance -> IO [BIP32Path] From 842e571d49fd1f2dcdced5cad5554432d9a1f7db Mon Sep 17 00:00:00 2001 From: Heinrich Apfelmus Date: Tue, 29 Oct 2024 15:15:33 +0100 Subject: [PATCH 7/7] Make `createPayment` scenario executable MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit … and pending, waiting for `getCustomerDeposits` to support `rollForward` --- .../src/Cardano/Wallet/Deposit/Write.hs | 3 +- .../Scenario/Wallet/Deposit/Exchanges.lhs.md | 3 +- .../Test/Scenario/Wallet/Deposit/Run.hs | 40 +++++++++++++++---- 3 files changed, 36 insertions(+), 10 deletions(-) diff --git a/lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/Write.hs b/lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/Write.hs index 77f1717a918..6e054bd7819 100644 --- a/lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/Write.hs +++ b/lib/customer-deposit-wallet/src/Cardano/Wallet/Deposit/Write.hs @@ -96,8 +96,9 @@ data TxBody = TxBody } deriving (Show) +-- | Inject a number of ADA, i.e. a million lovelace. mkAda :: Integer -> Value -mkAda = Read.injectCoin . Read.CoinC +mkAda = Read.injectCoin . Read.CoinC . (* 1000000) mkTxOut :: Address -> Value -> TxOut mkTxOut = Read.mkBasicTxOut diff --git a/lib/customer-deposit-wallet/test/scenario/Test/Scenario/Wallet/Deposit/Exchanges.lhs.md b/lib/customer-deposit-wallet/test/scenario/Test/Scenario/Wallet/Deposit/Exchanges.lhs.md index ee75b8e53ff..13b9da3de80 100644 --- a/lib/customer-deposit-wallet/test/scenario/Test/Scenario/Wallet/Deposit/Exchanges.lhs.md +++ b/lib/customer-deposit-wallet/test/scenario/Test/Scenario/Wallet/Deposit/Exchanges.lhs.md @@ -39,6 +39,7 @@ import Cardano.Wallet.Deposit.Read ( Address , Value , TxId + , lessOrEqual ) import Test.Scenario.Blockchain ( ScenarioEnv @@ -211,7 +212,7 @@ scenarioCreatePayment xprv env destination w = do -- funds have been moved out of the wallet value2 <- Wallet.availableBalance w - assert $ value2 <> coin == value1 + assert $ (value2 <> coin) `lessOrEqual` value1 -- but the original deposit amount is still recorded txsummaries <- getCustomerDeposits customer w diff --git a/lib/customer-deposit-wallet/test/scenario/Test/Scenario/Wallet/Deposit/Run.hs b/lib/customer-deposit-wallet/test/scenario/Test/Scenario/Wallet/Deposit/Run.hs index d0b61699b0b..19e991e5dc3 100644 --- a/lib/customer-deposit-wallet/test/scenario/Test/Scenario/Wallet/Deposit/Run.hs +++ b/lib/customer-deposit-wallet/test/scenario/Test/Scenario/Wallet/Deposit/Run.hs @@ -11,7 +11,8 @@ module Test.Scenario.Wallet.Deposit.Run import Prelude import Cardano.Crypto.Wallet - ( XPub + ( XPrv + , XPub , generate , toXPub ) @@ -19,6 +20,7 @@ import Test.Hspec ( SpecWith , describe , it + , pendingWith ) import Test.Hspec.Extra ( aroundAll @@ -34,7 +36,9 @@ import Test.Scenario.Blockchain ) import qualified Cardano.Wallet.Deposit.IO as Wallet +import qualified Cardano.Wallet.Deposit.Read as Read import qualified Data.ByteString.Char8 as B8 +import qualified Data.ByteString.Short as SBS import qualified Test.Scenario.Wallet.Deposit.Exchanges as Exchanges main :: IO () @@ -45,30 +49,50 @@ main = scenarios :: SpecWith ScenarioEnv scenarios = do describe "Scenarios for centralized exchanges" $ do - it "Restore a wallet" $ \env -> + it "0. Restore a wallet" $ \env -> withWalletEnvMock env $ Exchanges.scenarioRestore xpub - it "Start a wallet" $ \env -> + it "0. Start a wallet" $ \env -> withWalletEnvMock env $ \w -> do Exchanges.scenarioRestore xpub w Exchanges.scenarioStart w - it "Assign an address to a customer ID" $ \env -> do + it "1. Assign an address to a customer ID" $ \env -> do withWalletEnvMock env $ \walletEnv -> - Wallet.withWalletInit walletEnv xpub 32 + Wallet.withWalletInit walletEnv (freshXPub 1) 32 Exchanges.scenarioCreateAddressList + it "4. Create payments to a different wallet" $ \env -> do + pendingWith "Waiting for getCustomerDeposits to support rollForward" + withWalletEnvMock env $ \walletEnv -> + Wallet.withWalletInit walletEnv xpub 32 + $ Exchanges.scenarioCreatePayment xprv env mockAddress + describe "Temporary tests" $ do it "Wallet receives funds that are sent to customer address" $ \env -> do withWalletEnvMock env $ \walletEnv -> - Wallet.withWalletInit walletEnv xpub 8 $ + Wallet.withWalletInit walletEnv (freshXPub 0) 8 $ testBalance env xpub :: XPub -xpub = +xpub = toXPub xprv + +xprv :: XPrv +xprv = generate (B8.pack "random seed for a testing xpub lala") B8.empty + +freshXPub :: Integer -> XPub +freshXPub i = toXPub - $ generate (B8.pack "random seed for a testing xpub lala") B8.empty + $ generate + (B8.pack $ "random seed for a testing xpub lala" <> show i) + B8.empty + +mockAddress :: Read.Address +mockAddress = + Read.mkEnterpriseAddress + Read.MainnetTag + (SBS.pack $ replicate 32 0) testBalance :: ScenarioEnv -> Wallet.WalletInstance -> IO ()