[ADP-3344] Implement createPayment using balanceTx (#4814)

This pull request implements the `createPayment` function in terms of
`balanceTx`.

### Comments

* We make the scenario test for `createPayment` executable, but still
mark it as pending, as we need to wait for the `getCustomerDeposits`
function to support `rollForward`.

### Issue Number

ADP-3344

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

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

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
@@ -72,6 +72,7 @@ import Cardano.Wallet.Deposit.IO.Resource
     )
 import Cardano.Wallet.Deposit.Pure
     ( Customer
+    , ErrCreatePayment
     , Word31
     , fromXPubAndGenesis
     )
@@ -405,16 +406,16 @@ getTxHistoryByTime = onWalletInstance WalletIO.getTxHistoryByTime
 
 createPayment
     :: [(Address, Read.Value)]
-    -> WalletResourceM (Maybe Write.TxBody)
+    -> WalletResourceM (Either ErrCreatePayment Write.Tx)
 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

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
@@ -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,17 +289,25 @@ 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.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

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

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.

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,11 +39,13 @@ module Cardano.Wallet.Deposit.Pure
     , getTxHistoryByTime
 
       -- ** Writing to the blockchain
+    , ErrCreatePayment (..)
     , createPayment
+
     , BIP32Path (..)
     , DerivationType (..)
     , getBIP32PathsForOwnedInputs
-    , signTxBody
+    , signTx
     , addTxSubmission
     , listTxsInSubmission
 
@@ -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
     }
 
@@ -217,7 +238,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
@@ -342,23 +363,109 @@ 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
+        }
+
+    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
 
--- needs balanceTx
--- needs to sign the transaction
+{-----------------------------------------------------------------------------
+    Operations
+    Signing transactions
+------------------------------------------------------------------------------}
 
-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 +476,13 @@ 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
+
+{-----------------------------------------------------------------------------
+    Operations
+    Pending transactions
+------------------------------------------------------------------------------}
 
 addTxSubmission :: Write.Tx -> WalletState -> WalletState
 addTxSubmission _tx _w = undefined