Try passing down private key of monetary policy

lib/core/src/Cardano/Wallet.hs

@@ -161,6 +161,7 @@ module Cardano.Wallet
     -- ** Root Key
     , withRootKey
     , derivePublicKey
+    , derivePrivateKey
     , readPublicAccountKey
     , signMetadataWith
     , ErrWithRootKey (..)
@@ -1459,8 +1460,9 @@ signTransaction
     -> Passphrase "raw"
     -> TransactionCtx
     -> SelectionResult TokenBundle
+    -> Maybe (k 'AddressK XPrv, Passphrase "encryption")
     -> ExceptT ErrSignPayment IO (Tx, TxMeta, UTCTime, SealedTx)
-signTransaction ctx wid argChange mkRwdAcct pwd txCtx sel = db & \DBLayer{..} -> do
+signTransaction ctx wid argChange mkRwdAcct pwd txCtx sel extraWit = db & \DBLayer{..} -> do
     era <- liftIO $ currentNodeEra nl
     withRootKey @_ @s ctx wid pwd ErrSignPaymentWithRootKey $ \xprv scheme -> do
         let pwdP = preparePassphrase scheme pwd
@@ -1476,7 +1478,7 @@ signTransaction ctx wid argChange mkRwdAcct pwd txCtx sel = db & \DBLayer{..} ->
             let rewardAcnt = mkRwdAcct (xprv, pwdP)
 
             (tx, sealedTx) <- withExceptT ErrSignPaymentMkTx $ ExceptT $ pure $
-                mkTransaction tl era rewardAcnt keyFrom pp txCtx sel'
+                mkTransaction tl era rewardAcnt keyFrom pp txCtx sel' extraWit
 
             (time, meta) <- liftIO $ mkTxMeta ti (currentTip cp) s' txCtx sel'
             return (tx, meta, time, sealedTx)
@@ -2143,6 +2145,36 @@ derivePublicKey ctx wid role_ ix = db & \DBLayer{..} -> do
   where
     db = ctx ^. dbLayer @IO @s @k
 
+derivePrivateKey 
+    :: forall ctx s k n.
+        ( HasDBLayer IO s k ctx
+        , HardDerivation k
+        , AddressIndexDerivationType k ~ 'Soft
+        , s ~ SeqState n k
+        )
+    => ctx
+    -> WalletId
+    -> Passphrase "raw"
+    -> (Role, DerivationIndex)
+    -> ExceptT ErrSignMetadataWith IO (k 'AddressK XPrv, Passphrase "encryption")
+derivePrivateKey ctx wid pwd (role_, ix) = db & \DBLayer{..} -> do
+    addrIx <- withExceptT ErrSignMetadataWithInvalidIndex $ guardSoftIndex ix
+
+    cp <- mapExceptT atomically
+        $ withExceptT ErrSignMetadataWithNoSuchWallet
+        $ withNoSuchWallet wid
+        $ readCheckpoint wid
+
+    withRootKey @ctx @s @k ctx wid pwd ErrSignMetadataWithRootKey
+        $ \rootK scheme -> do
+            let encPwd = preparePassphrase scheme pwd
+            let DerivationPrefix (_, _, acctIx) = derivationPrefix (getState cp)
+            let acctK = deriveAccountPrivateKey encPwd rootK acctIx
+            let addrK = deriveAddressPrivateKey encPwd acctK role_ addrIx
+            pure (addrK, encPwd)
+  where
+    db = ctx ^. dbLayer @IO @s @k
+
 -- | Retrieve public account key of a wallet.
 readPublicAccountKey
     :: forall ctx s k n.

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

@@ -110,6 +110,7 @@ module Cardano.Wallet.Api.Server
 
 import Prelude
 
+import Cardano.Wallet.DB.Sqlite.Types ()
 import Cardano.Address.Script (KeyHash, Script(RequireSignatureOf))
 import Cardano.Address.Derivation
     ( XPrv, XPub, xpubPublicKey, xpubToBytes )
@@ -1735,7 +1736,7 @@ postTransaction ctx genChange (ApiT wid) body = do
         sel <- liftHandler
             $ W.selectAssets @_ @s @k wrk w txCtx outs (const Prelude.id)
         (tx, txMeta, txTime, sealedTx) <- liftHandler
-            $ W.signTransaction @_ @s @k wrk wid genChange mkRwdAcct pwd txCtx sel
+            $ W.signTransaction @_ @s @k wrk wid genChange mkRwdAcct pwd txCtx sel Nothing
         liftHandler
             $ W.submitTx @_ @s @k wrk wid (tx, txMeta, sealedTx)
         pure (sel, tx, txMeta, txTime)
@@ -1893,7 +1894,7 @@ joinStakePool ctx knownPools getPoolStatus apiPoolId (ApiT wid) body = do
             $ W.selectAssetsNoOutputs @_ @s @k wrk wid wal txCtx
             $ const Prelude.id
         (tx, txMeta, txTime, sealedTx) <- liftHandler
-            $ W.signTransaction @_ @s @k wrk wid genChange mkRwdAcct pwd txCtx sel
+            $ W.signTransaction @_ @s @k wrk wid genChange mkRwdAcct pwd txCtx sel Nothing
         liftHandler
             $ W.submitTx @_ @s @k wrk wid (tx, txMeta, sealedTx)
 
@@ -1976,7 +1977,7 @@ quitStakePool ctx (ApiT wid) body = do
             $ W.selectAssetsNoOutputs @_ @s @k wrk wid wal txCtx
             $ const Prelude.id
         (tx, txMeta, txTime, sealedTx) <- liftHandler
-            $ W.signTransaction @_ @s @k wrk wid genChange mkRwdAcct pwd txCtx sel
+            $ W.signTransaction @_ @s @k wrk wid genChange mkRwdAcct pwd txCtx sel Nothing
         liftHandler
             $ W.submitTx @_ @s @k wrk wid (tx, txMeta, sealedTx)
 
@@ -3323,6 +3324,7 @@ forgeToken
         ( ctx ~ ApiLayer s k
         , s ~ SeqState n k
         , Bounded (Index (AddressIndexDerivationType k) 'AddressK)
+        , AddressIndexDerivationType k ~ 'Soft
         , WalletKey k
         , GenChange s
         , HardDerivation k
@@ -3332,6 +3334,8 @@ forgeToken
         , Typeable n
         , Typeable s
         , PaymentAddress n k
+        , CompareDiscovery s
+        , KnownAddresses s
         )
     => ctx
     -> ArgGenChange s
@@ -3362,6 +3366,7 @@ forgeToken ctx genChange (ApiT wid) body = do
 
         -- Get the public key of the monetary policy
         addrXPub <- liftHandler $ W.derivePublicKey @_ @s @k @n wrk wid MultisigScript derivationIndex
+        addrXPrv <- liftHandler $ W.derivePrivateKey @_ @s @k @n wrk wid pwd (MultisigScript, derivationIndex)
 
         -- Use that public key to generate a monetary policy
         let
@@ -3380,6 +3385,8 @@ forgeToken ctx genChange (ApiT wid) body = do
           payAddrXPub :: Address
           payAddrXPub = paymentAddress @n @k addrXPub
 
+        liftIO $ putStrLn $ T.unpack $ toText keyHash
+
         -- Transfer the minted assets to the payment address
         -- associated with the monetary policy
         let assets = TokenMap.singleton assetId assetQty
@@ -3395,21 +3402,21 @@ forgeToken ctx genChange (ApiT wid) body = do
                 }
 
         w <- liftHandler $ W.readWalletUTxOIndex @_ @s @k wrk wid
-        liftIO $ putStrLn $ "Starting SEL..."
+        -- liftIO $ putStrLn $ "Starting SEL..."
         sel <- liftHandler
             $ W.selectAssets @_ @s @k wrk w txCtx outs (const Prelude.id)
-        liftIO $ putStrLn $ "Finished SEL"
-        liftIO $ putStrLn $ show sel
+        -- liftIO $ putStrLn $ "Finished SEL"
+        -- liftIO $ putStrLn $ show sel
 
         -- let outputsCovered' = fmap (\txout -> case txout of
         --          (TxOut addr (TokenBundle.TokenBundle coin tokens)) | addr == payAddrXPub && tokens == mempty -> TxOut addr (TokenBundle.TokenBundle coin (TokenMap.singleton assetId assetQty))
         --          otherwise -> txout
         --          ) (outputsCovered sel)
 
         (tx, txMeta, txTime, sealedTx) <- liftHandler
-            $ W.signTransaction @_ @s @k wrk wid genChange mkRwdAcct pwd txCtx sel
-        liftIO $ putStrLn $ "Finished SIGN"
-        liftIO $ putStrLn $ show tx
+            $ W.signTransaction @_ @s @k wrk wid genChange mkRwdAcct pwd txCtx sel (Just addrXPrv)
+        -- liftIO $ putStrLn $ "Finished SIGN"
+        -- liftIO $ putStrLn $ show tx
         liftHandler
             $ W.submitTx @_ @s @k wrk wid (tx, txMeta, sealedTx)
         pure (sel, tx, txMeta, txTime)

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

@@ -94,6 +94,8 @@ data TransactionLayer k = TransactionLayer
         -> SelectionResult TxOut
             -- A balanced coin selection where all change addresses have been
             -- assigned.
+        -> Maybe (k 'AddressK XPrv, Passphrase "encryption")
+            -- Extra witness
         -> Either ErrMkTx (Tx, SealedTx)
         -- ^ Construct a standard transaction
         --

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

@@ -1082,7 +1082,7 @@ setupFixture (wid, wname, wstate) = do
 -- implements a fake signer that still produces sort of witnesses
 dummyTransactionLayer :: TransactionLayer ShelleyKey
 dummyTransactionLayer = TransactionLayer
-    { mkTransaction = \_era _stakeCredentials keystore _pp _ctx cs -> do
+    { mkTransaction = \_era _stakeCredentials keystore _pp _ctx cs extraWit -> do
         let inps' = NE.toList $ second txOutCoin <$> inputsSelected cs
         let tid = mkTxId inps' (outputsCovered cs) mempty Nothing
         let tx = Tx tid Nothing inps' (outputsCovered cs) mempty Nothing

lib/shelley/src/Cardano/Wallet/Shelley/Transaction.hs

@@ -281,9 +281,10 @@ mkTx
     -> Coin
     -- ^ Explicit fee amount
     -> Maybe (NE.NonEmpty (Address, TokenMap))
+    -> Maybe (k 'AddressK XPrv, Passphrase "encryption")
     -> ShelleyBasedEra era
     -> Either ErrMkTx (Tx, SealedTx)
-mkTx networkId payload ttl (rewardAcnt, pwdAcnt) keyFrom wdrl cs fees mForgeOuts era = do
+mkTx networkId payload ttl (rewardAcnt, pwdAcnt) keyFrom wdrl cs fees mForgeOuts extraWit era = do
     let TxPayload md certs mkExtraWits = payload
     let wdrls = mkWithdrawals
             networkId
@@ -304,16 +305,18 @@ mkTx networkId payload ttl (rewardAcnt, pwdAcnt) keyFrom wdrl cs fees mForgeOuts
                       [mkShelleyWitness unsigned (rewardAcnt, pwdAcnt)]
 
             mintBurnWits <- do
-              let
-                list :: [(Address, TokenMap)]
-                list = maybe [] (NE.toList) mForgeOuts
+            --   let
+            --     list :: [(Address, TokenMap)]
+            --     list = maybe [] (NE.toList) mForgeOuts
 
-                uniqueAddrs :: [Address]
-                uniqueAddrs = nub . fmap fst $ list
+            --     uniqueAddrs :: [Address]
+            --     uniqueAddrs = nub . fmap fst $ list
 
-              forM uniqueAddrs $ \addr -> do
-                (k, pwd) <- lookupPrivateKey keyFrom addr
-                pure $ mkShelleyWitness unsigned (getRawKey k, pwd)
+            --   forM uniqueAddrs $ \addr -> do
+            --     (k, pwd) <- lookupPrivateKey keyFrom addr
+                pure $ case extraWit of
+                  Nothing -> []
+                  Just (wit, pwd) -> [mkShelleyWitness unsigned (getRawKey wit, pwd)]
 
             pure $ mkExtraWits unsigned <> F.toList addrWits <> wdrlsWits <> mintBurnWits
 
@@ -340,7 +343,7 @@ newTransactionLayer
     => NetworkId
     -> TransactionLayer k
 newTransactionLayer networkId = TransactionLayer
-    { mkTransaction = \era stakeCreds keystore pp ctx selection -> do
+    { mkTransaction = \era stakeCreds keystore pp ctx selection extraWit -> do
         let ttl   = txTimeToLive ctx
         let wdrl  = withdrawalToCoin $ view #txWithdrawal ctx
         let delta = selectionDelta txOutCoin selection
@@ -350,7 +353,7 @@ newTransactionLayer networkId = TransactionLayer
                 withShelleyBasedEra era $ do
                     let payload = TxPayload (view #txMetadata ctx) mempty mempty
                     let fees = delta
-                    mkTx networkId payload ttl stakeCreds keystore wdrl selection fees forge
+                    mkTx networkId payload ttl stakeCreds keystore wdrl selection fees forge extraWit
 
             Just action -> do
                 withShelleyBasedEra era $ do
@@ -365,7 +368,7 @@ newTransactionLayer networkId = TransactionLayer
                                 unsafeSubtractCoin selection delta (stakeKeyDeposit pp)
                             _ ->
                                 delta
-                    mkTx networkId payload ttl stakeCreds keystore wdrl selection fees forge
+                    mkTx networkId payload ttl stakeCreds keystore wdrl selection fees forge extraWit
 
     , initSelectionCriteria = _initSelectionCriteria @k
 
@@ -688,7 +691,7 @@ data TxSkeleton = TxSkeleton
     , txInputCount :: !Int
     , txOutputs :: ![TxOut]
     , txChange :: ![Set AssetId]
-    , txMintBurnInfo :: Maybe (NE.NonEmpty (Address, TokenMap))
+    , txMintBurnInfo :: !(Maybe (NE.NonEmpty (Address, TokenMap)))
     }
     deriving (Eq, Show)
 
@@ -705,6 +708,7 @@ emptyTxSkeleton txWitnessTag = TxSkeleton
     , txInputCount = 0
     , txOutputs = []
     , txChange = []
+    , txMintBurnInfo = Nothing
     }
 
 -- | Constructs a transaction skeleton from wallet primitive types.