diff --git a/plutus-contract/src/Plutus/Contract/Trace.hs b/plutus-contract/src/Plutus/Contract/Trace.hs index a1461e4b24d..82cd7e12a76 100644 --- a/plutus-contract/src/Plutus/Contract/Trace.hs +++ b/plutus-contract/src/Plutus/Contract/Trace.hs @@ -77,10 +77,9 @@ import Ledger.Value (Value) import Plutus.Trace.Emulator.Types (EmulatedWalletEffects) import Wallet.API (ChainIndexEffect) -import Wallet.Effects (ContractRuntimeEffect, WalletEffect) +import Wallet.Effects (ContractRuntimeEffect, NodeClientEffect, WalletEffect) import Wallet.Emulator (EmulatorState, Wallet) import qualified Wallet.Emulator as EM -import Wallet.Emulator.LogMessages (TxBalanceMsg) import qualified Wallet.Emulator.MultiAgent as EM import Wallet.Emulator.Notify (EmulatorNotifyLogMsg (..)) import Wallet.Types (ContractInstanceId, EndpointDescription (..), @@ -119,7 +118,7 @@ handleSlotNotifications :: ( HasAwaitSlot s , Member (LogObserve (LogMessage Text)) effs , Member (LogMsg RequestHandlerLogMsg) effs - , Member WalletEffect effs + , Member NodeClientEffect effs ) => RequestHandler effs (Handlers s) (Event s) handleSlotNotifications = @@ -155,7 +154,6 @@ handlePendingTransactions :: , Member (LogMsg RequestHandlerLogMsg) effs , Member WalletEffect effs , Member ChainIndexEffect effs - , Member (LogMsg TxBalanceMsg) effs ) => RequestHandler effs (Handlers s) (Event s) handlePendingTransactions = @@ -192,8 +190,8 @@ handleAddressChangedAtQueries :: ( HasWatchAddress s , Member (LogObserve (LogMessage Text)) effs , Member (LogMsg RequestHandlerLogMsg) effs - , Member WalletEffect effs , Member ChainIndexEffect effs + , Member NodeClientEffect effs ) => RequestHandler effs (Handlers s) (Event s) handleAddressChangedAtQueries = diff --git a/plutus-contract/src/Plutus/Contract/Trace/RequestHandler.hs b/plutus-contract/src/Plutus/Contract/Trace/RequestHandler.hs index 9e58b5a4c9e..9b447092dea 100644 --- a/plutus-contract/src/Plutus/Contract/Trace/RequestHandler.hs +++ b/plutus-contract/src/Plutus/Contract/Trace/RequestHandler.hs @@ -56,9 +56,10 @@ import Plutus.Contract.Effects.Instance (OwnIdRequest) import Plutus.Contract.Effects.UtxoAt (UtxoAtAddress (..)) import qualified Plutus.Contract.Wallet as Wallet import Wallet.API (WalletAPIError) -import Wallet.Effects (ChainIndexEffect, ContractRuntimeEffect, WalletEffect) +import Wallet.Effects (ChainIndexEffect, ContractRuntimeEffect, NodeClientEffect, + WalletEffect) import qualified Wallet.Effects -import Wallet.Emulator.LogMessages (RequestHandlerLogMsg (..), TxBalanceMsg) +import Wallet.Emulator.LogMessages (RequestHandlerLogMsg (..)) import Wallet.Types (AddressChangeRequest (..), AddressChangeResponse, ContractInstanceId, Notification, NotificationError, slotRange, targetSlot) @@ -114,7 +115,7 @@ handleOwnPubKey = handleSlotNotifications :: forall effs. - ( Member WalletEffect effs + ( Member NodeClientEffect effs , Member (LogObserve (LogMessage Text)) effs , Member (LogMsg RequestHandlerLogMsg) effs ) @@ -122,7 +123,7 @@ handleSlotNotifications :: handleSlotNotifications = RequestHandler $ \targetSlot_ -> surroundDebug @Text "handleSlotNotifications" $ do - currentSlot <- Wallet.Effects.walletSlot + currentSlot <- Wallet.Effects.getClientSlot logDebug $ SlotNoficationTargetVsCurrent targetSlot_ currentSlot guard (currentSlot >= targetSlot_) pure currentSlot @@ -132,7 +133,6 @@ handlePendingTransactions :: ( Member WalletEffect effs , Member (LogObserve (LogMessage Text)) effs , Member (LogMsg RequestHandlerLogMsg) effs - , Member (LogMsg TxBalanceMsg) effs , Member ChainIndexEffect effs ) => RequestHandler effs UnbalancedTx (Either WalletAPIError Tx) @@ -177,13 +177,13 @@ handleAddressChangedAtQueries :: forall effs. ( Member (LogObserve (LogMessage Text)) effs , Member (LogMsg RequestHandlerLogMsg) effs - , Member WalletEffect effs , Member ChainIndexEffect effs + , Member NodeClientEffect effs ) => RequestHandler effs AddressChangeRequest AddressChangeResponse handleAddressChangedAtQueries = RequestHandler $ \req -> surroundDebug @Text "handleAddressChangedAtQueries" $ do - current <- Wallet.Effects.walletSlot + current <- Wallet.Effects.getClientSlot let target = targetSlot req logDebug $ HandleAddressChangedAt current (slotRange req) -- If we ask the chain index for transactions that were confirmed in diff --git a/plutus-contract/src/Plutus/Contract/Wallet.hs b/plutus-contract/src/Plutus/Contract/Wallet.hs index 0f2c8471e85..b50409a6c66 100644 --- a/plutus-contract/src/Plutus/Contract/Wallet.hs +++ b/plutus-contract/src/Plutus/Contract/Wallet.hs @@ -9,39 +9,17 @@ -- | Turn 'UnbalancedTx' values into transactions using the -- wallet API. module Plutus.Contract.Wallet( - balanceWallet - , balanceTx + balanceTx , handleTx , WAPI.startWatching ) where -import Control.Lens -import Control.Monad ((>=>)) -import Control.Monad.Freer (Eff, Member) -import Control.Monad.Freer.Error (Error, throwError) -import Control.Monad.Freer.Extras.Log (LogMsg, logDebug, logInfo) -import Data.Bifunctor (second) -import Data.Foldable (fold, traverse_) -import qualified Data.Map as Map -import Data.Monoid (Sum (..)) -import qualified Data.Set as Set -import Data.String (IsString (fromString)) -import qualified Ledger as L -import qualified Ledger.Ada as Ada -import Ledger.AddressMap (UtxoMap) -import qualified Ledger.AddressMap as AM -import Ledger.Constraints.OffChain (UnbalancedTx (..)) -import qualified Ledger.Index as Index -import Ledger.Tx (Tx (..)) -import qualified Ledger.Tx as Tx -import Ledger.Value (Value) -import qualified Ledger.Value as Value -import qualified PlutusTx.Prelude as P -import Wallet.API (PubKey, WalletAPIError) -import qualified Wallet.API as WAPI +import Control.Monad ((>=>)) +import Control.Monad.Freer (Eff, Member) +import Ledger.Constraints.OffChain (UnbalancedTx (..)) +import Ledger.Tx (Tx (..)) +import qualified Wallet.API as WAPI import Wallet.Effects -import qualified Wallet.Emulator as E -import Wallet.Emulator.LogMessages (TxBalanceMsg (..)) {- Note [Submitting transactions from Plutus contracts] @@ -79,162 +57,9 @@ be submitted to the network, the contract backend needs to -} --- | Balance an unbalanced transaction in a 'WalletEffects' context. See note --- [Submitting transactions from Plutus contracts]. -balanceWallet :: - ( Member WalletEffect effs - , Member (Error WalletAPIError) effs - , Member ChainIndexEffect effs - , Member (LogMsg TxBalanceMsg) effs - ) - => UnbalancedTx - -> Eff effs Tx -balanceWallet utx = do - pk <- ownPubKey - outputs <- ownOutputs - - utxWithFees <- validateTxAndAddFees outputs pk utx - - logInfo $ BalancingUnbalancedTx utxWithFees - balanceTx outputs pk utxWithFees - -lookupValue :: - ( Member WalletEffect effs - , Member (Error WalletAPIError) effs - , Member ChainIndexEffect effs - ) - => Tx.TxIn -> Eff effs Value -lookupValue outputRef = do - walletIndex <- WAPI.ownOutputs - chainIndex <- AM.outRefMap <$> WAPI.watchedAddresses - let txout = (walletIndex <> chainIndex) ^. at (Tx.txInRef outputRef) - case txout of - Just out -> pure $ Tx.txOutValue $ Tx.txOutTxOut out - Nothing -> - WAPI.throwOtherError $ "Unable to find TxOut for " <> fromString (show outputRef) - --- | Balance an unbalanced transaction by adding public key inputs --- and outputs and by adding enough collateral inputs. -balanceTx :: - ( Member WalletEffect effs - , Member (Error WalletAPIError) effs - , Member ChainIndexEffect effs - , Member (LogMsg TxBalanceMsg) effs - ) - => UtxoMap - -- ^ Unspent transaction outputs that may be used to balance the - -- left hand side (inputs) of the transaction. - -> PubKey - -- ^ Public key, used to balance the right hand side (outputs) of - -- the transaction. - -> UnbalancedTx - -- ^ The unbalanced transaction - -> Eff effs Tx -balanceTx utxo pk UnbalancedTx{unBalancedTxTx} = do - inputValues <- traverse lookupValue (Set.toList $ Tx.txInputs unBalancedTxTx) - collateral <- traverse lookupValue (Set.toList $ Tx.txCollateral unBalancedTxTx) - let fees = L.txFee unBalancedTxTx - left = L.txForge unBalancedTxTx <> fold inputValues - right = fees <> foldMap (view Tx.outValue) (unBalancedTxTx ^. Tx.outputs) - remainingFees = fees P.- fold collateral -- TODO: add collateralPercent - balance = left P.- right - (neg, pos) = Value.split balance - - tx' <- if Value.isZero pos - then do - logDebug NoOutputsAdded - pure unBalancedTxTx - else do - logDebug $ AddingPublicKeyOutputFor pos - pure $ addOutputs pk pos unBalancedTxTx - - tx'' <- if Value.isZero neg - then do - logDebug NoInputsAdded - pure tx' - else do - logDebug $ AddingInputsFor neg - addInputs utxo pk neg tx' - - if remainingFees `Value.leq` P.zero - then do - logDebug NoCollateralInputsAdded - pure tx'' - else do - logDebug $ AddingCollateralInputsFor remainingFees - addCollateral utxo remainingFees tx'' - - --- | @addInputs mp pk vl tx@ selects transaction outputs worth at least --- @vl@ from the UTXO map @mp@ and adds them as inputs to @tx@. A public --- key output for @pk@ is added containing any leftover change. -addInputs - :: Member (Error WalletAPIError) effs - => UtxoMap - -> PubKey - -> Value - -> Tx - -> Eff effs Tx -addInputs mp pk vl tx = do - (spend, change) <- E.selectCoin (second (Tx.txOutValue . Tx.txOutTxOut) <$> Map.toList mp) vl - let - - addTxIns = - let ins = Set.fromList (Tx.pubKeyTxIn . fst <$> spend) - in over Tx.inputs (Set.union ins) - - addTxOuts = if Value.isZero change - then id - else addOutputs pk change - - pure $ tx & addTxOuts & addTxIns - -addOutputs :: PubKey -> Value -> Tx -> Tx -addOutputs pk vl tx = tx & over Tx.outputs (pko :) where - pko = Tx.pubKeyTxOut vl pk - -addCollateral - :: Member (Error WalletAPIError) effs - => UtxoMap - -> Value - -> Tx - -> Eff effs Tx -addCollateral mp vl tx = do - (spend, _) <- E.selectCoin (second (Tx.txOutValue . Tx.txOutTxOut) <$> Map.toList mp) vl - let addTxCollateral = - let ins = Set.fromList (Tx.pubKeyTxIn . fst <$> spend) - in over Tx.collateralInputs (Set.union ins) - pure $ tx & addTxCollateral - -validateTxAndAddFees :: - ( Member WalletEffect effs - , Member (Error WalletAPIError) effs - , Member ChainIndexEffect effs - , Member (LogMsg TxBalanceMsg) effs - ) - => UtxoMap - -> PubKey - -> UnbalancedTx - -> Eff effs UnbalancedTx -validateTxAndAddFees outputs pk utx = do - -- Balance and sign just for validation - tx <- balanceTx outputs pk utx - signedTx <- walletAddSignature tx - let utxoIndex = Index.UtxoIndex $ unBalancedTxUtxoIndex utx <> fmap Tx.txOutTxOut outputs - ((e, _), events) = Index.runValidation (Index.validateTransactionOffChain signedTx) utxoIndex - traverse_ (throwError . WAPI.ValidationError . snd) e - let scriptsSize = getSum $ foldMap (Sum . L.scriptSize . Index.sveScript) events - fee = Index.minFee tx <> Ada.lovelaceValueOf scriptsSize -- TODO: use protocol parameters - pure $ utx{ unBalancedTxTx = (unBalancedTxTx utx){ txFee = fee }} - -- | Balance an unabalanced transaction, sign it, and submit -- it to the chain in the context of a wallet. handleTx :: - ( Member WalletEffect effs - , Member ChainIndexEffect effs - , Member (LogMsg TxBalanceMsg) effs - , Member (Error WalletAPIError) effs - ) + (Member WalletEffect effs) => UnbalancedTx -> Eff effs Tx -handleTx = - balanceWallet >=> WAPI.signTxAndSubmit +handleTx = balanceTx >=> WAPI.signTxAndSubmit diff --git a/plutus-contract/src/Wallet/API.hs b/plutus-contract/src/Wallet/API.hs index ab71d2bc4ba..c02fb60bdde 100644 --- a/plutus-contract/src/Wallet/API.hs +++ b/plutus-contract/src/Wallet/API.hs @@ -15,14 +15,16 @@ {-# OPTIONS_GHC -Wno-orphans #-} {-# OPTIONS_GHC -fno-omit-interface-pragmas #-} {-# OPTIONS_GHC -fno-ignore-interface-pragmas #-} --- | The interface between the wallet and Plutus client code. +{- + +Mock wallet implementation + +-} module Wallet.API( WalletEffect, submitTxn, ownPubKey, - updatePaymentWithChange, - walletSlot, - ownOutputs, + balanceTx, NodeClientEffect, publishTx, getClientSlot, @@ -56,21 +58,15 @@ module Wallet.API( throwOtherError, ) where -import Control.Monad (void) +import Control.Monad (void) import Control.Monad.Freer -import qualified Data.Map as Map -import Data.Maybe (maybeToList) -import qualified Data.Set as Set -import Ledger hiding (inputs, out, value) +import Ledger hiding (inputs, out, value) +import Ledger.Constraints.OffChain (UnbalancedTx (..), emptyUnbalancedTx) import Wallet.Effects import Wallet.Emulator.Error -import Wallet.Types (emptyPayment) +import Wallet.Types (emptyPayment) -import Prelude hiding (Ordering (..)) - -createPaymentWithChange :: Member WalletEffect effs => Value -> Eff effs Payment -createPaymentWithChange v = - updatePaymentWithChange v emptyPayment +import Prelude hiding (Ordering (..)) -- | Transfer some funds to an address locked by a public key, returning the -- transaction that was submitted. @@ -79,12 +75,14 @@ payToPublicKey :: ) => SlotRange -> Value -> PubKey -> Eff effs Tx payToPublicKey range v pk = do - p <- createPaymentWithChange v - let other = pubKeyTxOut v pk - let tx = createTx range (paymentInputs p) (other : maybeToList (paymentChangeOutput p)) [] - p' <- updatePaymentWithChange (txFee tx) p - let tx' = createTx range (paymentInputs p') (other : maybeToList (paymentChangeOutput p')) [] - signTxAndSubmit tx' + let tx = mempty{txOutputs = [pubKeyTxOut v pk], txValidRange = range} + balanceTx emptyUnbalancedTx{unBalancedTxTx = tx} >>= signTxAndSubmit + -- p <- createPaymentWithChange v + -- let other = pubKeyTxOut v pk + -- let tx = createTx range (paymentInputs p) (other : maybeToList (paymentChangeOutput p)) [] + -- p' <- updatePaymentWithChange (txFee tx) p + -- let tx' = createTx range (paymentInputs p') (other : maybeToList (paymentChangeOutput p')) [] + -- signTxAndSubmit tx' -- | Transfer some funds to an address locked by a public key. payToPublicKey_ :: @@ -93,24 +91,6 @@ payToPublicKey_ :: => SlotRange -> Value -> PubKey -> Eff effs () payToPublicKey_ r v = void . payToPublicKey r v --- | Create a transaction, sign it with the wallet's private key, and submit it. --- TODO: This is here to make the calculation of fees easier for old-style contracts --- and should be removed when all contracts have been ported to the new API. -createTx :: - SlotRange - -> Set.Set TxIn - -> [TxOut] - -> [Datum] - -> Tx -createTx range ins outs datas = do - let tx = mempty - { txInputs = ins - , txOutputs = outs - , txValidRange = range - , txData = Map.fromList $ fmap (\ds -> (datumHash ds, ds)) datas - } - tx { txFee = minFee tx } - -- | Add the wallet's signature to the transaction and submit it. Returns -- the transaction with the wallet's signature. signTxAndSubmit :: diff --git a/plutus-contract/src/Wallet/Effects.hs b/plutus-contract/src/Wallet/Effects.hs index 460f65ea740..1e13739f169 100644 --- a/plutus-contract/src/Wallet/Effects.hs +++ b/plutus-contract/src/Wallet/Effects.hs @@ -17,9 +17,7 @@ module Wallet.Effects( , Payment(..) , submitTxn , ownPubKey - , updatePaymentWithChange - , walletSlot - , ownOutputs + , balanceTx , walletAddSignature -- * Node client , NodeClientEffect(..) @@ -39,18 +37,17 @@ module Wallet.Effects( , sendNotification ) where -import Control.Monad.Freer.TH (makeEffect) -import Ledger (Address, Block, PubKey, Slot, Tx, TxId, Value) -import Ledger.AddressMap (AddressMap, UtxoMap) -import Wallet.Types (AddressChangeRequest (..), AddressChangeResponse (..), Notification, - NotificationError, Payment (..)) +import Control.Monad.Freer.TH (makeEffect) +import Ledger (Address, Block, PubKey, Slot, Tx, TxId) +import Ledger.AddressMap (AddressMap) +import Ledger.Constraints.OffChain (UnbalancedTx) +import Wallet.Types (AddressChangeRequest (..), AddressChangeResponse (..), Notification, + NotificationError, Payment (..)) data WalletEffect r where SubmitTxn :: Tx -> WalletEffect () OwnPubKey :: WalletEffect PubKey - UpdatePaymentWithChange :: Value -> Payment -> WalletEffect Payment - WalletSlot :: WalletEffect Slot - OwnOutputs :: WalletEffect UtxoMap + BalanceTx :: UnbalancedTx -> WalletEffect Tx WalletAddSignature :: Tx -> WalletEffect Tx makeEffect ''WalletEffect diff --git a/plutus-contract/src/Wallet/Emulator/LogMessages.hs b/plutus-contract/src/Wallet/Emulator/LogMessages.hs index c753a76d87d..4d21df893b1 100644 --- a/plutus-contract/src/Wallet/Emulator/LogMessages.hs +++ b/plutus-contract/src/Wallet/Emulator/LogMessages.hs @@ -12,7 +12,7 @@ module Wallet.Emulator.LogMessages( import Data.Aeson (FromJSON, ToJSON) import Data.Text.Prettyprint.Doc (Pretty (..), hang, viaShow, vsep, (<+>)) import GHC.Generics (Generic) -import Ledger (Address) +import Ledger (Address, Tx, txId) import Ledger.Constraints.OffChain (UnbalancedTx) import Ledger.Slot (Slot, SlotRange) import Ledger.Value (Value) @@ -48,6 +48,8 @@ data TxBalanceMsg = | AddingInputsFor Value | NoCollateralInputsAdded | AddingCollateralInputsFor Value + | FinishedBalancing Tx + | SubmittingTx Tx deriving stock (Eq, Show, Generic) deriving anyclass (ToJSON, FromJSON) @@ -60,3 +62,5 @@ instance Pretty TxBalanceMsg where AddingInputsFor vl -> "Adding inputs for" <+> pretty vl NoCollateralInputsAdded -> "No collateral inputs added" AddingCollateralInputsFor vl -> "Adding collateral inputs for" <+> pretty vl + FinishedBalancing tx -> "Finished balancing." <+> pretty (txId tx) + SubmittingTx tx -> "Submitting tx:" <+> pretty (txId tx) diff --git a/plutus-contract/src/Wallet/Emulator/Wallet.hs b/plutus-contract/src/Wallet/Emulator/Wallet.hs index 1ed2a6b49ba..781000e1e95 100644 --- a/plutus-contract/src/Wallet/Emulator/Wallet.hs +++ b/plutus-contract/src/Wallet/Emulator/Wallet.hs @@ -16,40 +16,45 @@ module Wallet.Emulator.Wallet where import Control.Lens -import Control.Monad (foldM) +import Control.Monad (foldM) import Control.Monad.Freer import Control.Monad.Freer.Error +import Control.Monad.Freer.Extras.Log (LogMsg, logDebug, logInfo) import Control.Monad.Freer.State -import Control.Monad.Freer.TH (makeEffect) -import Control.Newtype.Generics (Newtype) -import Data.Aeson (FromJSON, ToJSON, ToJSONKey) +import Control.Monad.Freer.TH (makeEffect) +import Control.Newtype.Generics (Newtype) +import Data.Aeson (FromJSON, ToJSON, ToJSONKey) import Data.Bifunctor import Data.Foldable -import Data.Hashable (Hashable) -import qualified Data.Map as Map +import Data.Hashable (Hashable) +import qualified Data.Map as Map import Data.Maybe -import qualified Data.Set as Set -import qualified Data.Text as T +import Data.Semigroup (Sum (..)) +import qualified Data.Set as Set +import Data.String (IsString (..)) +import qualified Data.Text as T import Data.Text.Prettyprint.Doc -import GHC.Generics (Generic) +import GHC.Generics (Generic) import Ledger -import qualified Ledger.Ada as Ada -import qualified Ledger.AddressMap as AM -import Ledger.Credential (Credential (..)) -import qualified Ledger.Crypto as Crypto -import qualified Ledger.Value as Value -import Plutus.Contract.Checkpoint (CheckpointLogMsg) -import qualified PlutusTx.Prelude as PlutusTx -import Prelude as P -import Servant.API (FromHttpApiData (..), ToHttpApiData (..)) -import qualified Wallet.API as WAPI -import Wallet.Effects (ChainIndexEffect, NodeClientEffect, WalletEffect (..)) -import qualified Wallet.Effects as W -import Wallet.Emulator.Chain (ChainState (..)) -import Wallet.Emulator.ChainIndex (ChainIndexState) -import Wallet.Emulator.LogMessages (RequestHandlerLogMsg, TxBalanceMsg) -import Wallet.Emulator.NodeClient (NodeClientState, emptyNodeClientState) -import Wallet.Types (Payment (..)) +import qualified Ledger.Ada as Ada +import qualified Ledger.AddressMap as AM +import Ledger.Constraints.OffChain (UnbalancedTx (..)) +import qualified Ledger.Constraints.OffChain as U +import Ledger.Credential (Credential (..)) +import qualified Ledger.Crypto as Crypto +import qualified Ledger.Tx as Tx +import qualified Ledger.Value as Value +import Plutus.Contract.Checkpoint (CheckpointLogMsg) +import qualified PlutusTx.Prelude as PlutusTx +import Prelude as P +import Servant.API (FromHttpApiData (..), ToHttpApiData (..)) +import qualified Wallet.API as WAPI +import Wallet.Effects (ChainIndexEffect, NodeClientEffect, WalletEffect (..)) +import qualified Wallet.Effects as W +import Wallet.Emulator.Chain (ChainState (..)) +import Wallet.Emulator.ChainIndex (ChainIndexState, idxWatchedAddresses) +import Wallet.Emulator.LogMessages (RequestHandlerLogMsg, TxBalanceMsg (..)) +import Wallet.Emulator.NodeClient (NodeClientState, emptyNodeClientState) newtype SigningProcess = SigningProcess { unSigningProcess :: forall effs. (Member (Error WAPI.WalletAPIError) effs) => [PubKeyHash] -> Tx -> Eff effs Tx @@ -145,70 +150,164 @@ data PaymentArgs = -- ^ The value that must be covered by the payment's inputs } -handleUpdatePaymentWithChange :: - ( Member (Error WAPI.WalletAPIError) effs - ) - => PaymentArgs - -> Payment - -> Eff effs Payment -handleUpdatePaymentWithChange - PaymentArgs{availableFunds, ownPubKey, requestedValue} - Payment{paymentInputs=oldIns, paymentChangeOutput=changeOut} = do - let - -- These inputs have been already used, we won't touch them - usedFnds = Set.map txInRef oldIns - -- Optional, left over change. Replace a `Nothing` with a Value of 0. - oldChange = maybe (Ada.lovelaceValueOf 0) txOutValue changeOut - -- Available funds. - fnds = Map.withoutKeys availableFunds usedFnds - if requestedValue `Value.leq` oldChange - then - -- If the requested value is covered by the change we only need to update - -- the remaining change. - pure Payment - { paymentInputs = oldIns - , paymentChangeOutput = mkChangeOutput ownPubKey (oldChange PlutusTx.- requestedValue) - } - else do - -- If the requested value is not covered by the change, then we need to - -- select new inputs, after deducting the oldChange from the value. - (spend, change) <- - selectCoin - (second (txOutValue . txOutTxOut) <$> Map.toList fnds) - (requestedValue PlutusTx.- oldChange) - let ins = Set.fromList (pubKeyTxIn . fst <$> spend) - pure Payment - { paymentInputs = Set.union oldIns ins - , paymentChangeOutput = mkChangeOutput ownPubKey change - } - handleWallet :: ( Member NodeClientEffect effs , Member ChainIndexEffect effs , Member (State WalletState) effs , Member (Error WAPI.WalletAPIError) effs + , Member (LogMsg TxBalanceMsg) effs ) => WalletEffect ~> Eff effs handleWallet = \case - SubmitTxn tx -> W.publishTx tx + SubmitTxn tx -> do + logInfo $ SubmittingTx tx + W.publishTx tx OwnPubKey -> toPublicKey <$> gets _ownPrivateKey - UpdatePaymentWithChange vl pmt -> do - utxo <- W.watchedAddresses - ws <- get - let pubK = toPublicKey (ws ^. ownPrivateKey) - args = PaymentArgs - { availableFunds = utxo ^. AM.fundsAt (ownAddress ws) - , ownPubKey = pubK - , requestedValue = vl - } - handleUpdatePaymentWithChange args pmt - WalletSlot -> W.getClientSlot - OwnOutputs -> do - addr <- gets ownAddress - view (at addr . non mempty) <$> W.watchedAddresses - WalletAddSignature tx -> do - privKey <- gets _ownPrivateKey - pure (addSignature privKey tx) + BalanceTx utx -> do + logInfo $ BalancingUnbalancedTx utx + utxWithFees <- validateTxAndAddFees utx + -- balance to add fees + tx' <- handleBalanceTx (utx & U.tx . fee .~ (utxWithFees ^. U.tx . fee)) + handleAddSignature tx' + WalletAddSignature tx -> handleAddSignature tx + +handleAddSignature :: + Member (State WalletState) effs + => Tx + -> Eff effs Tx +handleAddSignature tx = do + privKey <- gets _ownPrivateKey + pure (addSignature privKey tx) + +validateTxAndAddFees :: + ( Member (Error WAPI.WalletAPIError) effs + , Member ChainIndexEffect effs + , Member (LogMsg TxBalanceMsg) effs + , Member (State WalletState) effs + ) + => UnbalancedTx + -> Eff effs UnbalancedTx +validateTxAndAddFees utx = do + ownPubKey <- gets (toPublicKey . view ownPrivateKey) + let addr = pubKeyAddress ownPubKey + ownOutputs <- view (at addr . non mempty) <$> W.watchedAddresses + -- Balance and sign just for validation + tx <- handleBalanceTx utx + signedTx <- handleAddSignature tx + let utxoIndex = Ledger.UtxoIndex $ unBalancedTxUtxoIndex utx <> fmap Tx.txOutTxOut ownOutputs + ((e, _), events) = Ledger.runValidation (Ledger.validateTransactionOffChain signedTx) utxoIndex + traverse_ (throwError . WAPI.ValidationError . snd) e + let scriptsSize = getSum $ foldMap (Sum . scriptSize . Ledger.sveScript) events + theFee = minFee tx <> Ada.lovelaceValueOf scriptsSize -- TODO: use protocol parameters + pure $ utx{ unBalancedTxTx = (unBalancedTxTx utx){ txFee = theFee }} + +lookupValue :: + ( Member (Error WAPI.WalletAPIError) effs + , Member ChainIndexEffect effs + , Member (State WalletState) effs + ) + => Map.Map TxOutRef TxOut + -> Tx.TxIn + -> Eff effs Value +lookupValue otherInputsMap outputRef = do + walletIndexMap <- fmap Tx.txOutTxOut . AM.outRefMap . view (chainIndex . idxWatchedAddresses) <$> get + chainIndexMap <- fmap Tx.txOutTxOut . AM.outRefMap <$> WAPI.watchedAddresses + let txout = (otherInputsMap <> walletIndexMap <> chainIndexMap) ^. at (Tx.txInRef outputRef) + case txout of + Just output -> pure $ Tx.txOutValue output + Nothing -> + WAPI.throwOtherError $ "Unable to find TxOut for " <> fromString (show outputRef) + +-- | balance an unbalanced transaction by adding missing inputs and outputs +handleBalanceTx :: + forall effs. + ( Member (State WalletState) effs + , Member ChainIndexEffect effs + , Member (Error WAPI.WalletAPIError) effs + , Member (LogMsg TxBalanceMsg) effs + ) + => UnbalancedTx + -> Eff effs Tx +handleBalanceTx UnbalancedTx{unBalancedTxTx, unBalancedTxUtxoIndex} = do + ownPubKey <- gets (toPublicKey . view ownPrivateKey) + let addr = pubKeyAddress ownPubKey + utxo <- view (at addr . non mempty) <$> W.watchedAddresses + inputValues <- traverse (lookupValue unBalancedTxUtxoIndex) (Set.toList $ Tx.txInputs unBalancedTxTx) + collateral <- traverse (lookupValue unBalancedTxUtxoIndex) (Set.toList $ Tx.txCollateral unBalancedTxTx) + let fees = txFee unBalancedTxTx + left = txForge unBalancedTxTx <> fold inputValues + right = fees <> foldMap (view Tx.outValue) (unBalancedTxTx ^. Tx.outputs) + remainingFees = fees PlutusTx.- fold collateral -- TODO: add collateralPercent + balance = left PlutusTx.- right + (neg, pos) = Value.split balance + + tx' <- if Value.isZero pos + then do + logDebug NoOutputsAdded + pure unBalancedTxTx + else do + logDebug $ AddingPublicKeyOutputFor pos + pure $ addOutputs ownPubKey pos unBalancedTxTx + + tx'' <- if Value.isZero neg + then do + logDebug NoInputsAdded + pure tx' + else do + logDebug $ AddingInputsFor neg + addInputs utxo ownPubKey neg tx' + + if remainingFees `Value.leq` PlutusTx.zero + then do + logDebug NoCollateralInputsAdded + logInfo $ FinishedBalancing tx'' + pure tx'' + else do + logDebug $ AddingCollateralInputsFor remainingFees + tx''' <- addCollateral utxo remainingFees tx'' + logInfo $ FinishedBalancing tx''' + pure tx''' + +addOutputs :: PubKey -> Value -> Tx -> Tx +addOutputs pk vl tx = tx & over Tx.outputs (pko :) where + pko = Tx.pubKeyTxOut vl pk + +addCollateral + :: Member (Error WAPI.WalletAPIError) effs + => AM.UtxoMap + -> Value + -> Tx + -> Eff effs Tx +addCollateral mp vl tx = do + (spend, _) <- selectCoin (second (Tx.txOutValue . Tx.txOutTxOut) <$> Map.toList mp) vl + let addTxCollateral = + let ins = Set.fromList (Tx.pubKeyTxIn . fst <$> spend) + in over Tx.collateralInputs (Set.union ins) + pure $ tx & addTxCollateral + +-- | @addInputs mp pk vl tx@ selects transaction outputs worth at least +-- @vl@ from the UTXO map @mp@ and adds them as inputs to @tx@. A public +-- key output for @pk@ is added containing any leftover change. +addInputs + :: Member (Error WAPI.WalletAPIError) effs + => AM.UtxoMap + -> PubKey + -> Value + -> Tx + -> Eff effs Tx +addInputs mp pk vl tx = do + (spend, change) <- selectCoin (second (Tx.txOutValue . Tx.txOutTxOut) <$> Map.toList mp) vl + let + + addTxIns = + let ins = Set.fromList (Tx.pubKeyTxIn . fst <$> spend) + in over Tx.inputs (Set.union ins) + + addTxOuts = if Value.isZero change + then id + else addOutputs pk change + + pure $ tx & addTxOuts & addTxIns -- Make a transaction output from a positive value. mkChangeOutput :: PubKey -> Value -> Maybe TxOut diff --git a/plutus-contract/test/Spec/golden/traceOutput - pubKeyTransactions.txt b/plutus-contract/test/Spec/golden/traceOutput - pubKeyTransactions.txt index 6978f605b16..93f88e49b82 100644 --- a/plutus-contract/test/Spec/golden/traceOutput - pubKeyTransactions.txt +++ b/plutus-contract/test/Spec/golden/traceOutput - pubKeyTransactions.txt @@ -1,13 +1,13 @@ Slot 00000: TxnValidate af5e6d25b5ecb26185289a03d50786b7ac4425b21849143ed7e18bcd70dc4db8 Slot 00000: SlotAdd Slot 1 -Slot 00001: W1: TxSubmit: b88eef8f6e6ecc1005a17b2f80fa8173e108457bb861ebf287a882f2517374a1 -Slot 00001: TxnValidate b88eef8f6e6ecc1005a17b2f80fa8173e108457bb861ebf287a882f2517374a1 +Slot 00001: W1: TxSubmit: 08b520ab0da26e5173cdbdc0502abbf477ae291c15fe7bd5c545d120a19bbee9 +Slot 00001: TxnValidate 08b520ab0da26e5173cdbdc0502abbf477ae291c15fe7bd5c545d120a19bbee9 Slot 00001: SlotAdd Slot 2 -Slot 00002: W2: TxSubmit: 3c2b8dffba39e446e7f0920c9fa0684addedd68a09f5a538b0617606386b01e1 -Slot 00002: TxnValidate 3c2b8dffba39e446e7f0920c9fa0684addedd68a09f5a538b0617606386b01e1 +Slot 00002: W2: TxSubmit: 5ac868341f5159808c7124cb9f00712cca711b9ec3b3c30a75c2224a3a1b9d98 +Slot 00002: TxnValidate 5ac868341f5159808c7124cb9f00712cca711b9ec3b3c30a75c2224a3a1b9d98 Slot 00002: SlotAdd Slot 3 -Slot 00003: W3: TxSubmit: 9b9bbd27ffb2c5ad5c742f2829de9db2b5c025dc3918652450a82c06519bc28c -Slot 00003: TxnValidate 9b9bbd27ffb2c5ad5c742f2829de9db2b5c025dc3918652450a82c06519bc28c +Slot 00003: W3: TxSubmit: 1307661064307d83be0f8e6ddfd208cc68047191a2aaabbd1bf1d39458f06eab +Slot 00003: TxnValidate 1307661064307d83be0f8e6ddfd208cc68047191a2aaabbd1bf1d39458f06eab Slot 00003: SlotAdd Slot 4 Slot 00004: SlotAdd Slot 5 Final balances diff --git a/plutus-contract/test/Spec/golden/traceOutput - pubKeyTransactions2.txt b/plutus-contract/test/Spec/golden/traceOutput - pubKeyTransactions2.txt index 794321496b2..d65c8417618 100644 --- a/plutus-contract/test/Spec/golden/traceOutput - pubKeyTransactions2.txt +++ b/plutus-contract/test/Spec/golden/traceOutput - pubKeyTransactions2.txt @@ -1,16 +1,16 @@ Slot 00000: TxnValidate af5e6d25b5ecb26185289a03d50786b7ac4425b21849143ed7e18bcd70dc4db8 Slot 00000: SlotAdd Slot 1 -Slot 00001: W1: TxSubmit: a7f674beb0b2b728d80cdf60ad2945556d0a91add3a0209ac60bc411871da826 -Slot 00001: TxnValidate a7f674beb0b2b728d80cdf60ad2945556d0a91add3a0209ac60bc411871da826 +Slot 00001: W1: TxSubmit: 1b44f67bae9de723473f4b9970fe1e34eb5b5e2de0e9e4b4b40d1c50ab4a7dd8 +Slot 00001: TxnValidate 1b44f67bae9de723473f4b9970fe1e34eb5b5e2de0e9e4b4b40d1c50ab4a7dd8 Slot 00001: SlotAdd Slot 2 -Slot 00002: W2: TxSubmit: 4fa93f6f251ef383a974ba52920cf85850c28ff33a9550fee88d92b3f8a9d81a -Slot 00002: TxnValidate 4fa93f6f251ef383a974ba52920cf85850c28ff33a9550fee88d92b3f8a9d81a +Slot 00002: W2: TxSubmit: a3b1510a86c66c5ee25b3bb705cb896c2567c174e4a0909ed790debe644777c6 +Slot 00002: TxnValidate a3b1510a86c66c5ee25b3bb705cb896c2567c174e4a0909ed790debe644777c6 Slot 00002: SlotAdd Slot 3 -Slot 00003: W3: TxSubmit: 087caad8d00f3b1201171cffcda723fc5079380828f39c63f3dc3e5a48b71752 -Slot 00003: TxnValidate 087caad8d00f3b1201171cffcda723fc5079380828f39c63f3dc3e5a48b71752 +Slot 00003: W3: TxSubmit: effaa00b0ebe75cecd3a6b4dcf0eecd04b65a522c9578eecb77de3e3fcc236c3 +Slot 00003: TxnValidate effaa00b0ebe75cecd3a6b4dcf0eecd04b65a522c9578eecb77de3e3fcc236c3 Slot 00003: SlotAdd Slot 4 -Slot 00004: W1: TxSubmit: 9933fe032fd1ede9744b248db221103a29e83f24ebb8274e8df19ff70b2ae541 -Slot 00004: TxnValidate 9933fe032fd1ede9744b248db221103a29e83f24ebb8274e8df19ff70b2ae541 +Slot 00004: W1: TxSubmit: e16be09fb31001f966e871f6d10d63793e21cd29606bd038c9b034dea5499ab2 +Slot 00004: TxnValidate e16be09fb31001f966e871f6d10d63793e21cd29606bd038c9b034dea5499ab2 Slot 00004: SlotAdd Slot 5 Slot 00005: SlotAdd Slot 6 Final balances diff --git a/plutus-ledger/src/Ledger/Constraints/OffChain.hs b/plutus-ledger/src/Ledger/Constraints/OffChain.hs index 80fe530fd9a..d81e056ac44 100644 --- a/plutus-ledger/src/Ledger/Constraints/OffChain.hs +++ b/plutus-ledger/src/Ledger/Constraints/OffChain.hs @@ -27,6 +27,9 @@ module Ledger.Constraints.OffChain( -- * Constraints resolution , SomeLookupsAndConstraints(..) , UnbalancedTx(..) + , tx + , requiredSignatories + , utxoIndex , emptyUnbalancedTx , MkTxError(..) , mkTx