SCP-2316: Reorganise wallet API

IntersectMBO · Jun 8, 2021 · 0b678fe · 0b678fe
1 parent b93a161
commit 0b678fe
Show file tree

Hide file tree

Showing 10 changed files with 247 additions and 341 deletions.
diff --git 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
@@ -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,15 +115,15 @@ handleOwnPubKey =
 
 handleSlotNotifications ::
     forall effs.
-    ( Member WalletEffect effs
+    ( Member NodeClientEffect effs
     , Member (LogObserve (LogMessage Text)) effs
     , Member (LogMsg RequestHandlerLogMsg) effs
     )
     => RequestHandler effs Slot Slot
 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
@@ -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
@@ -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 ::