[CBR-313] Refactor runCoinSelT to not assemble a TxAux

This commit separates out the concern of running the coin selection vs
the concern of assembling the final TxAux.

Author: adinapoli-iohk

src/Cardano/Wallet/Kernel/CoinSelection/FromGeneric.hs

@@ -12,7 +12,7 @@ module Cardano.Wallet.Kernel.CoinSelection.FromGeneric (
   , CoinSelectionOptions(..)
   , newOptions
     -- * Transaction building
-  , MkTx
+  , CoinSelFinalResult(..)
   , mkStdTx
     -- * Coin selection policies
   , random
@@ -166,26 +166,23 @@ feeOptions CoinSelectionOptions{..} = FeeOptions{
 -------------------------------------------------------------------------------}
 
 -- | Build a transaction
-type MkTx m = NonEmpty (Core.TxIn, Core.TxOutAux) -- ^ Transaction inputs
-           -> NonEmpty Core.TxOutAux              -- ^ Transaction outputs
-           -> [Core.Coin]                         -- ^ Generated change.
-           -> m (Either CoinSelHardErr Core.TxAux)
 
 -- | Construct a standard transaction
 --
 -- " Standard " here refers to the fact that we do not deal with redemption,
 -- multisignature transactions, etc.
 mkStdTx :: Monad m
         => Core.ProtocolMagic
-        -> ([Core.Coin] -> m [Core.TxOutAux])
-        -- ^ Function to turn a list of change into proper Core.TxOutAux.
-        -- This function is likely going to do some IO like creating and
-        -- persisting change addresses into the database.
         -> (Core.Address -> Either CoinSelHardErr Core.SafeSigner)
-        -> MkTx m
-mkStdTx pm genChange hdwSigners inps outs change = do
-    chng <- genChange change
-    let allOuts = foldl' (flip NE.cons) outs chng
+        -> NonEmpty (Core.TxIn, Core.TxOutAux)
+        -- ^ Selected inputs
+        -> NonEmpty Core.TxOutAux
+        -- ^ Selected outputs
+        -> [Core.TxOutAux]
+        -- ^ A list of change addresess, in the form of 'TxOutAux'(s).
+        -> m (Either CoinSelHardErr Core.TxAux)
+mkStdTx pm hdwSigners inps outs change = do
+    let allOuts = foldl' (flip NE.cons) outs change
     return $ Core.makeMPubKeyTxAddrs pm hdwSigners (fmap repack inps) allOuts
   where
     -- Repack a utxo-derived tuple into a format suitable for
@@ -201,6 +198,14 @@ mkStdTx pm genChange hdwSigners inps outs change = do
 type PickUtxo m = Core.Coin  -- ^ Fee to still cover
                -> CoinSelT Core.Utxo CoinSelHardErr m (Core.TxIn, Core.TxOutAux)
 
+data CoinSelFinalResult = CoinSelFinalResult {
+      csrInputs  :: NonEmpty (Core.TxIn, Core.TxOutAux)
+      -- ^ Picked inputs
+    , csrOutputs :: NonEmpty Core.TxOutAux
+      -- ^ Picked outputs
+    , csrChange  :: [Core.Coin]
+    }
+
 -- | Run coin selection
 --
 -- NOTE: Final UTxO is /not/ returned: coin selection runs /outside/ any wallet
@@ -214,12 +219,11 @@ type PickUtxo m = Core.Coin  -- ^ Fee to still cover
 runCoinSelT :: forall m. Monad m
             => CoinSelectionOptions
             -> PickUtxo m
-            -> MkTx m
             -> (forall utxo. PickFromUtxo utxo
                   => NonEmpty (Output (Dom utxo))
                   -> CoinSelT utxo CoinSelHardErr m [CoinSelResult (Dom utxo)])
-            -> CoinSelPolicy Core.Utxo m Core.TxAux
-runCoinSelT opts pickUtxo mkTx policy request utxo = do
+            -> CoinSelPolicy Core.Utxo m CoinSelFinalResult
+runCoinSelT opts pickUtxo policy request utxo = do
     mSelection <- unwrapCoinSelT policy' utxo
     case mSelection of
       Left err -> return (Left err)
@@ -235,7 +239,9 @@ runCoinSelT opts pickUtxo mkTx policy request utxo = do
                                []   -> error "runCoinSelT: empty list of outputs"
                                o:os -> o :| os
         -- TODO: We should shuffle allOuts
-        mkTx allInps originalOuts (concatMap coinSelChange css)
+        return . Right $ CoinSelFinalResult allInps
+                                            originalOuts
+                                            (concatMap coinSelChange css)
   where
     policy' :: CoinSelT Core.Utxo CoinSelHardErr m
                  ([CoinSelResult Cardano], SelectedUtxo Cardano)
@@ -313,11 +319,10 @@ validateOutput out =
 -- | Random input selection policy
 random :: forall m. MonadRandom m
        => CoinSelectionOptions
-       -> MkTx m          -- ^ Build and sign transaction
        -> Word64          -- ^ Maximum number of inputs
-       -> CoinSelPolicy Core.Utxo m Core.TxAux
-random opts mkTx maxInps =
-      runCoinSelT opts pickUtxo mkTx
+       -> CoinSelPolicy Core.Utxo m CoinSelFinalResult
+random opts maxInps =
+      runCoinSelT opts pickUtxo
     $ Random.random Random.PrivacyModeOn maxInps . NE.toList
   where
     -- We ignore the size of the fee, and just pick randomly
@@ -329,11 +334,10 @@ random opts mkTx maxInps =
 -- NOTE: Not for production use.
 largestFirst :: forall m. Monad m
              => CoinSelectionOptions
-             -> MkTx m
              -> Word64
-             -> CoinSelPolicy Core.Utxo m Core.TxAux
-largestFirst opts mkTx maxInps =
-      runCoinSelT opts pickUtxo mkTx
+             -> CoinSelPolicy Core.Utxo m CoinSelFinalResult
+largestFirst opts maxInps =
+      runCoinSelT opts pickUtxo
     $ LargestFirst.largestFirst maxInps . NE.toList
   where
     pickUtxo :: PickUtxo m

src/Cardano/Wallet/Kernel/Transactions.hs

@@ -6,7 +6,6 @@ module Cardano.Wallet.Kernel.Transactions (
     , NewTransactionError(..)
     , PaymentError(..)
     , EstimateFeesError(..)
-    , mkSigner
     , cardanoFee
     -- * Internal & testing use only
     , newTransaction
@@ -19,16 +18,20 @@ import           Control.Retry (RetryPolicyM, RetryStatus, applyPolicy,
                      fullJitterBackoff, limitRetries, retrying)
 import           Crypto.Random (MonadRandom (..))
 import qualified Data.Set as Set
+import qualified Data.Vector as V
+import           System.Random.MWC (GenIO, asGenIO, initialize, uniformVector)
 import           Test.QuickCheck (Arbitrary (..))
 
 import           Formatting (bprint, build, sformat, (%))
 import qualified Formatting.Buildable
 
 import qualified Data.ByteArray as ByteArray
-import qualified Pos.Binary as Bi
+import qualified Data.ByteString as B
 
+import qualified Cardano.Wallet.Kernel.Addresses as Kernel
 import           Cardano.Wallet.Kernel.CoinSelection.FromGeneric (Cardano,
-                     CoinSelectionOptions, estimateCardanoFee, mkStdTx)
+                     CoinSelFinalResult (..), CoinSelectionOptions,
+                     estimateCardanoFee, mkStdTx)
 import qualified Cardano.Wallet.Kernel.CoinSelection.FromGeneric as CoinSelection
 import           Cardano.Wallet.Kernel.CoinSelection.Generic
                      (CoinSelHardErr (..))
@@ -37,12 +40,15 @@ import           Cardano.Wallet.Kernel.DB.HdWallet
 import qualified Cardano.Wallet.Kernel.DB.HdWallet as HD
 import           Cardano.Wallet.Kernel.DB.HdWallet.Read
                      (readHdAddressByCardanoAddress)
+import           Cardano.Wallet.Kernel.Types (AccountId (..), WalletId (..))
 import           Cardano.Wallet.Kernel.Util (paymentAmount, utxoBalance,
                      utxoRestrictToInputs)
 
 import           Cardano.Wallet.Kernel (getWalletSnapshot, newPending)
 import           Cardano.Wallet.Kernel.DB.Read as Getters
-import           Cardano.Wallet.Kernel.Internal (ActiveWallet (..))
+import           Cardano.Wallet.Kernel.Internal (ActiveWallet (..),
+                     walletKeystore)
+import qualified Cardano.Wallet.Kernel.Keystore as Keystore
 
 import           Pos.Core (Address, Coin, Tx (..), TxAux (..), TxOut (..),
                      TxOutAux (..), unsafeSubCoin)
@@ -85,19 +91,16 @@ instance Buildable PaymentError where
 -- seconds, as well as internally retrying up to 5 times to propagate the
 -- transaction via 'newPending'.
 pay :: ActiveWallet
-    -> IO Address
-    -- ^ A computation to generate change 'Address'es.
-    -> (Address -> Either CoinSelHardErr SafeSigner)
+    -> PassPhrase
     -> CoinSelectionOptions
     -> HdAccountId
-    -- ^ The source @(root, account) from where the payment was
-    -- originated
+    -- ^ The source HD Account from where the payment was originated
     -> NonEmpty (Address, Coin)
     -- ^ The payees
     -> IO (Either PaymentError Tx)
-pay activeWallet genChangeAddr signAddress opts accountId payees = do
+pay activeWallet spendingPassword opts accountId payees = do
         retrying retryPolicy shouldRetry $ \rs -> do
-            tx <- newTransaction activeWallet genChangeAddr signAddress opts accountId payees
+            (tx, _) <- newTransaction activeWallet spendingPassword opts accountId payees
             case tx of
                  Left e      -> return (Left $ PaymentNewTransactionError e)
                  Right txAux -> do
@@ -131,58 +134,98 @@ pay activeWallet genChangeAddr signAddress opts accountId payees = do
 
 -- | Creates a new 'TxAux' without submitting it to the network.
 newTransaction :: ActiveWallet
-               -> IO Address
-               -- ^ A computation to generate change 'Address'es.
-               -> (Address -> Either CoinSelHardErr SafeSigner)
-               -- ^ A function to sign each Address
+               -> PassPhrase
+               -- ^ The spending password.
                -> CoinSelectionOptions
                -- ^ The options describing how to tune the coin selection.
                -> HdAccountId
-               -- ^ The source @(root, account) from where the payment was
-               -- originated
+               -- ^ The source HD account from where the payment should originate
                -> NonEmpty (Address, Coin)
                -- ^ The payees
-               -> IO (Either NewTransactionError TxAux)
-newTransaction ActiveWallet{..} genChangeAddr signAddress options accountId payees = do
-    snapshot <- getWalletSnapshot walletPassive
-    let toTxOuts = fmap (\(a,c) -> TxOutAux (TxOut a c))
-    let genChangeOuts css = forM css $ \change -> do
-            changeAddr <- liftIO genChangeAddr
-            return TxOutAux {
-                toaOut = TxOut {
-                    txOutAddress = changeAddr
-                  , txOutValue   = change
-                  }
-              }
-    let mkTx = mkStdTx walletProtocolMagic genChangeOuts signAddress
+               -> IO (Either NewTransactionError TxAux, Utxo)
+newTransaction ActiveWallet{..} spendingPassword options accountId payees = do
+
     -- | NOTE(adn) This number was computed out of the work Matt Noonan did
     -- on the size estimation. See [CBR-318].
     let maxInputs = 350
+
+    snapshot <- getWalletSnapshot walletPassive
     let availableUtxo = accountAvailableUtxo snapshot accountId
-    freshCounter <- newIORef 1
-    let initialSeed = encodeUtf8 @Text @ByteString . sformat build $ hash payees
-    res <- flip runReaderT (initialSeed, freshCounter) . buildPayment $
+
+    initialEnv <- newEnvironment
+
+    -- STEP 1: Run coin selection.
+    res <- flip runReaderT initialEnv . buildPayment $
            CoinSelection.random options
-                                mkTx
                                 maxInputs
-                                (toTxOuts payees)
+                                (fmap toTxOut payees)
                                 availableUtxo
     case res of
-         Left err -> return . Left . CoinSelectionFailed $ err
-         Right t  -> return . Right $ t
+         Left err -> return (Left . CoinSelectionFailed $ err, availableUtxo)
+         Right (CoinSelFinalResult inputs outputs coins) -> do
+             -- STEP 2: Generate the change addresses needed.
+             changeAddresses   <- genChangeOuts coins
+
+             -- STEP 3: Perform the signing and forge the final TxAux.
+             let keystore = walletPassive ^. walletKeystore
+             mbEsk <- Keystore.lookup (WalletIdHdRnd $ accountId ^. hdAccountIdParent) keystore
+             let allWallets    = hdWallets snapshot
+                 signAddress   = mkSigner spendingPassword mbEsk allWallets
+                 mkTx          = mkStdTx walletProtocolMagic signAddress
+
+             (, availableUtxo) . bimap CoinSelectionFailed identity
+                 <$> mkTx inputs outputs changeAddresses
+
+    where
+        -- Generate an initial seed for the random generator using the hash of
+        -- the payees, which ensure that the coin selection (and the fee estimation)
+        -- is \"pseudo deterministic\" and replicable.
+        newEnvironment :: IO Env
+        newEnvironment =
+            let initialSeed = V.fromList . map fromIntegral
+                                         . B.unpack
+                                         . encodeUtf8 @Text @ByteString
+                                         . sformat build
+                                         $ hash payees
+            in Env <$> initialize initialSeed
+
+        toTxOut :: (Address, Coin) -> TxOutAux
+        toTxOut (a, c) = TxOutAux (TxOut a c)
+
+        -- | Generates the list of change outputs from a list of change coins.
+        genChangeOuts :: MonadIO m => [Coin] -> m [TxOutAux]
+        genChangeOuts css = forM css $ \change -> do
+            changeAddr <- liftIO genChangeAddr
+            return TxOutAux {
+                toaOut = TxOut {
+                    txOutAddress = changeAddr
+                  , txOutValue   = change
+                  }
+              }
+
+        -- | Monadic computation to generate a new change 'Address'. This will
+        -- run after coin selection, when we create the final transaction as
+        -- part of 'mkTx'.
+        genChangeAddr :: IO Address
+        genChangeAddr = do
+            res <- Kernel.createAddress spendingPassword
+                                        (AccountIdHdRnd accountId)
+                                        walletPassive
+            case res of
+                 Right addr -> pure addr
+                 Left err   -> throwM err
 
 -- | Special monad used to process the payments, which randomness is derived
 -- from a fixed seed obtained from hashing the payees. This guarantees that
 -- when we estimate the fees and later create a transaction, the coin selection
 -- will always yield the same value, making the process externally-predicatable.
 newtype PayMonad a = PayMonad {
-      buildPayment :: ReaderT (ByteString, IORef Word16) IO a
-    } deriving ( Functor
-               , Applicative
-               , Monad
-               , MonadIO
-               , MonadReader (ByteString, IORef Word16)
-               )
+      buildPayment :: ReaderT Env IO a
+    } deriving ( Functor , Applicative , Monad , MonadIO, MonadReader Env)
+
+-- | This 'Env' datatype is necessary to convince GHC that indeed we have
+-- a 'MonadReader' instance defined on 'GenIO' for the 'PayMonad'.
+newtype Env = Env { getEnv :: GenIO }
 
 -- | \"Invalid\" 'MonadRandom' instance for 'PayMonad' which generates
 -- randomness using the hash of 'NonEmpty (Address, Coin)' as fixed seed,
@@ -191,13 +234,10 @@ newtype PayMonad a = PayMonad {
 -- which is yet deterministically reproduceable by feeding the same set of
 -- payees.
 instance MonadRandom PayMonad where
-    getRandomBytes _ = do
-        (initialSeed, counterRef) <- ask
-        counterValue <- readIORef counterRef
-        let randVal = ByteArray.convert . mappend (Bi.serialize' counterValue)
-                                        $ initialSeed
-        modifyIORef' counterRef succ
-        return randVal
+    getRandomBytes len = do
+        gen <- asks getEnv
+        randomBytes <- liftIO (asGenIO (flip uniformVector len) gen)
+        return $ ByteArray.convert (B.pack $ V.toList randomBytes)
 
 {-------------------------------------------------------------------------------
   Estimating fees
@@ -213,22 +253,17 @@ instance Arbitrary EstimateFeesError where
     arbitrary = EstFeesTxCreationFailed <$> arbitrary
 
 estimateFees :: ActiveWallet
-             -> IO Address
-             -- ^ A computation to generate a new change 'Address.
-             -> (Address -> Either CoinSelHardErr SafeSigner)
-             -- ^ A function to sign each Address
+             -> PassPhrase
+             -- ^ The spending password.
              -> CoinSelectionOptions
              -- ^ The options describing how to tune the coin selection.
              -> HdAccountId
-             -- ^ The source @(root, account) from where the payment was
-             -- originated
+             -- ^ The source HD Account from where the payment should originate
              -> NonEmpty (Address, Coin)
              -- ^ The payees
              -> IO (Either EstimateFeesError Coin)
-estimateFees activeWallet@ActiveWallet{..} genChangeAddr signAddress options accountId payees = do
-    snapshot         <- getWalletSnapshot walletPassive
-    let originalUtxo = accountAvailableUtxo snapshot accountId
-    res <- newTransaction activeWallet genChangeAddr signAddress options accountId payees
+estimateFees activeWallet@ActiveWallet{..} spendingPassword options accountId payees = do
+    (res, originalUtxo) <- newTransaction activeWallet spendingPassword options accountId payees
     case res of
          Left e  -> return . Left . EstFeesTxCreationFailed $ e
          Right tx -> -- calculate the fee as the difference between inputs and outputs.