prepare foundation to support withdrawals witnesses in standard trans…

…action

I've once again changed a bit the transaction layer to be more aligned with the recent changes (now takes a full coin selection).
Also, it now requires a reward account to be given; this is relatively 'unsound' for Byron and Icarus wallet since they have no
reward account, yet, the account is only used when a non-null withdrawal is provided which should never happen for these wallet types
since they aren't receiving rewards at all.

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

@@ -47,7 +47,6 @@ import Cardano.Wallet.Primitive.Types
     , SealedTx (..)
     , SlotId (..)
     , Tx (..)
-    , TxIn (..)
     , TxOut (..)
     )
 import Cardano.Wallet.Transaction
@@ -68,8 +67,6 @@ import Data.Coerce
     ( coerce )
 import Data.Either.Combinators
     ( maybeToRight )
-import Data.Maybe
-    ( isJust )
 import Data.Proxy
     ( Proxy )
 import Data.Quantity
@@ -115,18 +112,23 @@ newTransactionLayer _proxy protocolMagic = TransactionLayer
     }
   where
     _mkStdTx
-        :: (Address -> Maybe (k 'AddressK XPrv, Passphrase "encryption"))
+        :: (k 'AddressK XPrv, Passphrase "encryption")
+            -- Reward account
+        -> (Address -> Maybe (k 'AddressK XPrv, Passphrase "encryption"))
+            -- Key store
         -> SlotId
-        -> [(TxIn, TxOut)]
-        -> [TxOut]
+            -- Tip of the chain, for TTL
+        -> CoinSelection
+            -- A balanced coin selection where all change addresses have been
+            -- assigned.
         -> Either ErrMkTx (Tx, SealedTx)
-    _mkStdTx keyFrom _slotId inps outs = do
-        let tx = (fst <$> inps, outs)
+    _mkStdTx _rewardAcnt keyFrom _slotId cs = do
+        let tx = (fst <$> CS.inputs cs, CS.outputs cs)
         let sigData = blake2b256 $ CBOR.toStrictByteString $ CBOR.encodeTx tx
-        witnesses <- forM inps $ \(_, TxOut addr _) ->
+        witnesses <- forM (CS.inputs cs) $ \(_, TxOut addr _) ->
             mkWitness protocolMagic sigData <$> lookupPrivateKey addr
         pure
-            ( Tx (Hash sigData) (second coin <$> inps) outs
+            ( Tx (Hash sigData) (second coin <$> CS.inputs cs) (CS.outputs cs)
             , SealedTx $ CBOR.toStrictByteString $ CBOR.encodeSignedTx tx witnesses
             )
       where

lib/byron/test/unit/Cardano/Wallet/Byron/TransactionSpec.hs

@@ -496,8 +496,10 @@ goldenTestSignedTx proxy pm nOuts xprvs expected = it title $ do
     let keyFrom a = (,mempty) <$> Map.lookup a s
     let inps = mkInput <$> zip addrs [0..]
     let outs = take nOuts $ mkOutput <$> cycle addrs
+    let cs = mempty { inputs = inps, outputs = outs }
     let curSlot = error "current slot not needed in byron mkStdTx"
-    let res = mkStdTx (newTransactionLayer proxy pm) keyFrom curSlot inps outs
+    let rewardAcnt = error "reward account not needed in byron mkStdTx"
+    let res = mkStdTx (newTransactionLayer proxy pm) rewardAcnt keyFrom curSlot cs
     case res of
         Left e -> fail (show e)
         Right (_tx, SealedTx bytes) ->

lib/core/src/Cardano/Wallet.hs

@@ -1366,6 +1366,8 @@ signPayment
         , HasNetworkLayer t ctx
         , IsOwned s k
         , GenChange s
+        , HardDerivation k
+        , Bounded (Index (AddressIndexDerivationType k) 'AddressK)
         )
     => ctx
     -> WalletId
@@ -1375,6 +1377,7 @@ signPayment
     -> ExceptT ErrSignPayment IO (Tx, TxMeta, UTCTime, SealedTx)
 signPayment ctx wid argGenChange pwd cs = db & \DBLayer{..} -> do
     withRootKey @_ @s ctx wid pwd ErrSignPaymentWithRootKey $ \xprv scheme -> do
+        let pwdP = preparePassphrase scheme pwd
         nodeTip <- withExceptT ErrSignPaymentNetwork $ currentNodeTip nl
         mapExceptT atomically $ do
             cp <- withExceptT ErrSignPaymentNoSuchWallet $ withNoSuchWallet wid $
@@ -1383,9 +1386,10 @@ signPayment ctx wid argGenChange pwd cs = db & \DBLayer{..} -> do
             withExceptT ErrSignPaymentNoSuchWallet $
                 putCheckpoint (PrimaryKey wid) (updateState s' cp)
 
-            let keyFrom = isOwned (getState cp) (xprv, preparePassphrase scheme pwd)
+            let keyFrom = isOwned (getState cp) (xprv, pwdP)
+            let rewardAcnt = deriveRewardAccount @k pwdP xprv
             (tx, sealedTx) <- withExceptT ErrSignPaymentMkTx $ ExceptT $ pure $
-                mkStdTx tl keyFrom (nodeTip ^. #slotId) (inputs cs') (outputs cs')
+                mkStdTx tl (rewardAcnt, pwdP) keyFrom (nodeTip ^. #slotId) cs'
 
             let gp = blockchainParameters cp
             let (time, meta) = mkTxMeta gp (currentTip cp) s' cs'
@@ -1402,6 +1406,8 @@ signTx
         , HasDBLayer s k ctx
         , HasNetworkLayer t ctx
         , IsOwned s k
+        , HardDerivation k
+        , Bounded (Index (AddressIndexDerivationType k) 'AddressK)
         )
     => ctx
     -> WalletId
@@ -1410,17 +1416,19 @@ signTx
     -> ExceptT ErrSignPayment IO (Tx, TxMeta, UTCTime, SealedTx)
 signTx ctx wid pwd (UnsignedTx inpsNE outsNE) = db & \DBLayer{..} -> do
     withRootKey @_ @s ctx wid pwd ErrSignPaymentWithRootKey $ \xprv scheme -> do
+        let pwdP = preparePassphrase scheme pwd
         nodeTip <- withExceptT ErrSignPaymentNetwork $ currentNodeTip nl
         mapExceptT atomically $ do
             cp <- withExceptT ErrSignPaymentNoSuchWallet $ withNoSuchWallet wid $
                 readCheckpoint (PrimaryKey wid)
 
-            let keyFrom = isOwned (getState cp) (xprv, preparePassphrase scheme pwd)
+            let cs = mempty { inputs = inps, outputs = outs }
+            let keyFrom = isOwned (getState cp) (xprv, pwdP)
+            let rewardAcnt = deriveRewardAccount @k pwdP xprv
             (tx, sealedTx) <- withExceptT ErrSignPaymentMkTx $ ExceptT $ pure $
-                mkStdTx tl keyFrom (nodeTip ^. #slotId) inps outs
+                mkStdTx tl (rewardAcnt, pwdP) keyFrom (nodeTip ^. #slotId) cs
 
             let gp = blockchainParameters cp
-            let cs = mempty { inputs = inps, outputs = outs }
             let (time, meta) = mkTxMeta gp (currentTip cp) (getState cp) cs
             return (tx, meta, time, sealedTx)
   where
@@ -1504,27 +1512,27 @@ signDelegation ctx wid argGenChange pwd coinSel action = db & \DBLayer{..} -> do
             withExceptT ErrSignDelegationNoSuchWallet $
                 putCheckpoint (PrimaryKey wid) (updateState s' cp)
 
-            let rewardAcc = deriveRewardAccount @k pwdP xprv
+            let rewardAcnt = deriveRewardAccount @k pwdP xprv
             let keyFrom = isOwned (getState cp) (xprv, pwdP)
             (tx, sealedTx) <- withExceptT ErrSignDelegationMkTx $ ExceptT $ pure $
                 case action of
-                    Join poolId ->
+                    RegisterKeyAndJoin poolId ->
                         mkDelegationJoinTx tl poolId
-                            (rewardAcc, pwdP)
+                            (rewardAcnt, pwdP)
                             keyFrom
                             (nodeTip ^. #slotId)
                             coinSel'
 
-                    RegisterKeyAndJoin poolId ->
+                    Join poolId ->
                         mkDelegationJoinTx tl poolId
-                            (rewardAcc, pwdP)
+                            (rewardAcnt, pwdP)
                             keyFrom
                             (nodeTip ^. #slotId)
                             coinSel'
 
                     Quit ->
                         mkDelegationQuitTx tl
-                            (rewardAcc, pwdP)
+                            (rewardAcnt, pwdP)
                             keyFrom
                             (nodeTip ^. #slotId)
                             coinSel'

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

@@ -1117,6 +1117,8 @@ postTransaction
         , GenChange s
         , IsOwned s k
         , ctx ~ ApiLayer s t k
+        , HardDerivation k
+        , Bounded (Index (AddressIndexDerivationType k) 'AddressK)
         )
     => ctx
     -> ArgGenChange s
@@ -1325,7 +1327,11 @@ getMigrationInfo ctx (ApiT wid) = do
         W.selectCoinsForMigration @_ @s @t @k wrk wid
 
 migrateWallet
-    :: forall s t k n p. IsOwned s k
+    :: forall s t k n p.
+        ( IsOwned s k
+        , HardDerivation k
+        , Bounded (Index (AddressIndexDerivationType k) 'AddressK)
+        )
     => ApiLayer s t k
         -- ^ Source wallet context
     -> ApiT WalletId

lib/core/src/Cardano/Wallet/Primitive/AddressDerivation/Byron.hs

@@ -98,7 +98,9 @@ import GHC.Generics
 import GHC.TypeLits
     ( KnownNat )
 
+
 import qualified Cardano.Byron.Codec.Cbor as CBOR
+import qualified Cardano.Wallet.Primitive.AddressDerivation as W
 import qualified Codec.CBOR.Encoding as CBOR
 import qualified Codec.CBOR.Write as CBOR
 import qualified Crypto.KDF.PBKDF2 as PBKDF2
@@ -312,6 +314,23 @@ changePassphraseRnd (Passphrase oldPwd) (Passphrase newPwd) key = ByronKey
                                  HD derivation
 -------------------------------------------------------------------------------}
 
+-- TODO
+-- This instance is unsound. It only exists because we need to derive the
+-- reward account in the wallet engine when making transaction (in case there
+-- are any withdrawals).
+--
+-- With 'ByronKey', withdrawals will always be `0`, and the result of this
+-- function shouldn't be evaluated (relying on lazyness here). If they do, then
+-- we're doing something wrong.
+instance W.HardDerivation ByronKey where
+    type AddressIndexDerivationType ByronKey = 'WholeDomain
+
+    deriveAccountPrivateKey _ _ _ = error
+        "unsound evaluation of 'deriveAccountPrivateKey' in the context of Byron key"
+
+    deriveAddressPrivateKey _ _ _ _ = error
+        "unsound evaluation of 'deriveAddressPrivateKey' in the context of Byron key"
+
 -- | Derives account private key from the given root private key, using
 -- derivation scheme 1.
 --

lib/core/src/Cardano/Wallet/Transaction.hs

@@ -36,14 +36,7 @@ import Cardano.Wallet.Primitive.CoinSelection
 import Cardano.Wallet.Primitive.Fee
     ( Fee, FeePolicy )
 import Cardano.Wallet.Primitive.Types
-    ( Address (..)
-    , PoolId
-    , SealedTx (..)
-    , SlotId (..)
-    , Tx (..)
-    , TxIn (..)
-    , TxOut (..)
-    )
+    ( Address (..), PoolId, SealedTx (..), SlotId (..), Tx (..) )
 import Data.ByteString
     ( ByteString )
 import Data.Quantity
@@ -55,10 +48,15 @@ import Data.Word
 
 data TransactionLayer t k = TransactionLayer
     { mkStdTx
-        :: (Address -> Maybe (k 'AddressK XPrv, Passphrase "encryption"))
+        :: (k 'AddressK XPrv, Passphrase "encryption")
+            -- Reward account
+        -> (Address -> Maybe (k 'AddressK XPrv, Passphrase "encryption"))
+            -- Key store
         -> SlotId
-        -> [(TxIn, TxOut)]
-        -> [TxOut]
+            -- Tip of the chain, for TTL
+        -> CoinSelection
+            -- A balanced coin selection where all change addresses have been
+            -- assigned.
         -> Either ErrMkTx (Tx, SealedTx)
         -- ^ Construct a standard transaction
         --
@@ -113,11 +111,13 @@ data TransactionLayer t k = TransactionLayer
         -- ^ An initial selection where 'deposit' and/or 'reclaim' have been set
         -- accordingly.
 
-    , minimumFee :: FeePolicy -> Maybe DelegationAction -> CoinSelection -> Fee
+    , minimumFee
+        :: FeePolicy -> Maybe DelegationAction -> CoinSelection -> Fee
         -- ^ Compute a minimal fee amount necessary to pay for a given
         -- coin-selection.
 
-    , estimateMaxNumberOfInputs :: Quantity "byte" Word16 -> Word8 -> Word8
+    , estimateMaxNumberOfInputs
+        :: Quantity "byte" Word16 -> Word8 -> Word8
         -- ^ Calculate a "theoretical" maximum number of inputs given a maximum
         -- transaction size and desired number of outputs.
         --

lib/core/test/unit/Cardano/WalletSpec.hs

@@ -617,11 +617,11 @@ setupFixture (wid, wname, wstate) = do
 -- implements a fake signer that still produces sort of witnesses
 dummyTransactionLayer :: TransactionLayer DummyTarget JormungandrKey
 dummyTransactionLayer = TransactionLayer
-    { mkStdTx = \keyFrom _slot inps outs -> do
-        let inps' = map (second coin) inps
-        let tid = mkTxId inps' outs
-        let tx = Tx tid inps' outs
-        wit <- forM inps $ \(_, TxOut addr _) -> do
+    { mkStdTx = \_ keyFrom _slot cs -> do
+        let inps' = map (second coin) (CS.inputs cs)
+        let tid = mkTxId inps' (CS.outputs cs)
+        let tx = Tx tid inps' (CS.outputs cs)
+        wit <- forM (CS.inputs cs) $ \(_, TxOut addr _) -> do
             (xprv, Passphrase pwd) <- withEither
                 (ErrKeyNotFoundForAddress addr) $ keyFrom addr
             let (Hash sigData) = txId tx

lib/jormungandr/src/Cardano/Wallet/Jormungandr/Transaction.hs

@@ -83,10 +83,10 @@ newTransactionLayer
     => Hash "Genesis"
     -> TransactionLayer t k
 newTransactionLayer block0H = TransactionLayer
-    { mkStdTx = \keyFrom _ inps outs ->
+    { mkStdTx = \_rewardAcnt keyFrom _ cs ->
         mkFragment
             ( MkFragmentSimpleTransaction (txWitnessTagFor @k)
-            ) keyFrom inps outs
+            ) keyFrom (CS.inputs cs) (CS.outputs cs)
 
     , mkDelegationJoinTx = \pool accXPrv keyFrom _ cs ->
         let acc = ChimericAccount . xpubPublicKey . getRawKey . publicKey . fst $ accXPrv

lib/jormungandr/test/integration/Test/Integration/Jormungandr/Scenario/API/Transactions.hs

@@ -108,6 +108,7 @@ import Test.QuickCheck
     ( generate, vector )
 
 import qualified Cardano.Wallet.Api.Link as Link
+import qualified Cardano.Wallet.Primitive.CoinSelection as CS
 import qualified Codec.Binary.Bech32 as Bech32
 import qualified Codec.Binary.Bech32.TH as Bech32
 import qualified Data.ByteArray as BA
@@ -515,15 +516,18 @@ fixtureExternalTx ctx toSend = do
             , nOutputs = 1
             , nChanges = 1
             }
-    let theInps =
-            [ (TxIn theTxId 0, TxOut addrSrc (Coin (fromIntegral amt))) ]
-    let theOuts =
-            [ TxOut addrDest' (Coin (fromIntegral toSend))
-            , TxOut addrChng (Coin (fromIntegral $ amt - toSend - fee))
-            ]
+    let cs = mempty
+            { CS.inputs =
+                [ (TxIn theTxId 0, TxOut addrSrc (Coin (fromIntegral amt))) ]
+            , CS.outputs =
+                [ TxOut addrDest' (Coin (fromIntegral toSend))
+                , TxOut addrChng (Coin (fromIntegral $ amt - toSend - fee))
+                ]
+            }
     tl <- newTransactionLayer <$> getBlock0H
+    let rewardAcnt = error "rewardAcnt unused"
     let curSlot = error "current slot not needed in jormungandr mkStdTx"
-    let (Right (tx, bin)) = mkStdTx tl keystore curSlot theInps theOuts
+    let (Right (tx, bin)) = mkStdTx tl rewardAcnt keystore curSlot cs
 
     return ExternalTxFixture
         { srcWallet = wSrc

lib/jormungandr/test/unit/Cardano/Wallet/Jormungandr/TransactionSpec.hs

@@ -502,7 +502,9 @@ goldenTestStdTx
     -> ByteString
     -> SpecWith ()
 goldenTestStdTx tl keystore inps outs bytes' = it title $ do
-    let tx = mkStdTx tl keystore (SlotId 0 0) inps outs
+    let cs = mempty { inputs = inps, outputs = outs }
+    let rewardAcnt = error "unused"
+    let tx = mkStdTx tl rewardAcnt keystore (SlotId 0 0) cs
     let bytes = hex . getSealedTx . snd <$> tx
     bytes `shouldBe` Right bytes'
   where
@@ -571,16 +573,20 @@ unknownInputTest
 unknownInputTest _ block0 = it title $ do
     let addr = paymentAddress @n $ publicKey $ fst $
             xprvSeqFromSeed "address-number-0"
-    let res = mkStdTx tl keyFrom (SlotId 0 0) inps outs
+    let res = mkStdTx tl rewardAcnt keyFrom (SlotId 0 0) cs
           where
             tl = newTransactionLayer @JormungandrKey block0
+            rewardAcnt = error "unused"
             keyFrom = const Nothing
-            inps =
-                [ ( TxIn (Hash "arbitrary") 0
-                  , TxOut addr (Coin 0)
-                  )
-                ]
-            outs = []
+            cs = mempty
+                { inputs =
+                    [ ( TxIn (Hash "arbitrary") 0
+                      , TxOut addr (Coin 0)
+                      )
+                    ]
+                , outputs =
+                    []
+                }
     res `shouldBe` Left (ErrKeyNotFoundForAddress addr)
   where
     title = "Unknown input address yields an error ("