From 08bf43bea6ea82e10123fc79ada004c17aac17e3 Mon Sep 17 00:00:00 2001 From: Samuel Williams Date: Mon, 14 Feb 2022 11:02:53 +0000 Subject: [PATCH 1/9] Fully internalise balancing, fix tests --- README.md | 4 +- bot-plutus-interface.cabal | 4 +- .../{PreBalance.hs => Balance.hs} | 97 +++++------ src/BotPlutusInterface/CardanoCLI.hs | 47 ++---- src/BotPlutusInterface/Contract.hs | 17 +- test/Spec.hs | 4 +- .../{PreBalance.hs => Balance.hs} | 37 ++-- test/Spec/BotPlutusInterface/Contract.hs | 158 +++++++++++------- 8 files changed, 181 insertions(+), 187 deletions(-) rename src/BotPlutusInterface/{PreBalance.hs => Balance.hs} (76%) rename test/Spec/BotPlutusInterface/{PreBalance.hs => Balance.hs} (70%) diff --git a/README.md b/README.md index ed6cc5d3..16293e0f 100644 --- a/README.md +++ b/README.md @@ -125,13 +125,13 @@ The fake PAB consists of the following modules: - **BotPlutusInterface** main entry point - **BotPlutusInterface.Server** Servant server, handling http endpoint calls and websockets - **BotPlutusInterface.Contract** handling contract effects by creating the necessary files and calling cardano-cli commands (a few effects are mocked) -- **BotPlutusInterface.PreBalance** doing some preparations so the cli can process the rest (non-ada asset balancing, addig tx inputs, adding minimum lovelaces, add signatories) +- **BotPlutusInterface.Balance** doing some preparations so the cli can process the rest (non-ada asset balancing, addig tx inputs, adding minimum lovelaces, add signatories) - **BotPlutusInterface.CardanoCLI** wrappers for cardano-cli commands - For development purposes, I created an ssh wrapper, so I can call relay these commands through an ssh connection. This is not nice, unsafe, and pretty slow, avoid using it if you can. - **BotPlutusInterface.UtxoParser** parse the output of the `cardano-cli query utxo` command - **BotPlutusInterface.Files** functions for handling script, datum and redeemer files - **BotPlutusInterface.Types** configuration for the fake pab -- **BotPlutusInterface.PreBalance** prepare a transaction before sending to the cli for balancing. This includes: +- **BotPlutusInterface.Balance** prepare a transaction before sending to the cli for balancing. This includes: - adding tx inputs to cover fees and outputs - adding collaterals, - modifying tx outs to contain the minimum amount of lovelaces diff --git a/bot-plutus-interface.cabal b/bot-plutus-interface.cabal index ee05dc6b..8fdb8214 100644 --- a/bot-plutus-interface.cabal +++ b/bot-plutus-interface.cabal @@ -81,7 +81,7 @@ library BotPlutusInterface.Contract BotPlutusInterface.Effects BotPlutusInterface.Files - BotPlutusInterface.PreBalance + BotPlutusInterface.Balance BotPlutusInterface.Types BotPlutusInterface.UtxoParser @@ -143,7 +143,7 @@ test-suite bot-plutus-interface-test ghc-options: -fplugin-opt PlutusTx.Plugin:defer-errors other-modules: Spec.BotPlutusInterface.Contract - Spec.BotPlutusInterface.PreBalance + Spec.BotPlutusInterface.Balance Spec.BotPlutusInterface.UtxoParser Spec.MockContract diff --git a/src/BotPlutusInterface/PreBalance.hs b/src/BotPlutusInterface/Balance.hs similarity index 76% rename from src/BotPlutusInterface/PreBalance.hs rename to src/BotPlutusInterface/Balance.hs index e468ca9b..2829b67a 100644 --- a/src/BotPlutusInterface/PreBalance.hs +++ b/src/BotPlutusInterface/Balance.hs @@ -1,8 +1,8 @@ {-# LANGUAGE AllowAmbiguousTypes #-} -module BotPlutusInterface.PreBalance ( - preBalanceTx, - preBalanceTxIO, +module BotPlutusInterface.Balance ( + balanceTxStep, + balanceTxIO, ) where import BotPlutusInterface.CardanoCLI qualified as CardanoCLI @@ -10,12 +10,11 @@ import BotPlutusInterface.Effects (PABEffect, createDirectoryIfMissing, printLog import BotPlutusInterface.Files (DummyPrivKey, unDummyPrivateKey) import BotPlutusInterface.Files qualified as Files import BotPlutusInterface.Types (LogLevel (Debug), PABConfig) -import Cardano.Api.Shelley (Lovelace (Lovelace), ProtocolParameters (protocolParamUTxOCostPerWord)) import Control.Monad (foldM, void, zipWithM) import Control.Monad.Freer (Eff, Member) import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Either (EitherT, hoistEither, newEitherT, runEitherT) -import Data.Either.Combinators (maybeToRight, rightToMaybe) +import Data.Either.Combinators (rightToMaybe) import Data.Kind (Type) import Data.List (partition, (\\)) import Data.Map (Map) @@ -47,27 +46,26 @@ import Ledger.Tx ( TxOutRef (..), ) import Ledger.Tx qualified as Tx -import Ledger.Value (Value (Value), getValue) +import Ledger.Value (Value) import Ledger.Value qualified as Value import Plutus.V1.Ledger.Api ( Credential (PubKeyCredential, ScriptCredential), CurrencySymbol (..), TokenName (..), ) -import PlutusTx.AssocMap qualified as AssocMap import Prelude {- | Collect necessary tx inputs and collaterals, add minimum lovelace values and balance non ada assets -} -preBalanceTxIO :: +balanceTxIO :: forall (w :: Type) (effs :: [Type -> Type]). Member (PABEffect w) effs => PABConfig -> PubKeyHash -> UnbalancedTx -> Eff effs (Either Text Tx) -preBalanceTxIO pabConf ownPkh unbalancedTx = +balanceTxIO pabConf ownPkh unbalancedTx = runEitherT $ do utxos <- newEitherT $ CardanoCLI.utxosAt @w pabConf $ Ledger.pubKeyHashAddress (Ledger.PaymentPubKeyHash ownPkh) Nothing @@ -83,16 +81,23 @@ preBalanceTxIO pabConf ownPkh unbalancedTx = lift $ printLog @w Debug $ show utxoIndex - loop utxoIndex privKeys requiredSigs [] tx + -- Adds required collaterals, only needs to happen once + -- Also adds signatures for fee calculation + preBalancedTx <- hoistEither $ addTxCollaterals utxoIndex tx >>= addSignatories ownPkh privKeys requiredSigs + + -- Balance the tx + balancedTx <- loop utxoIndex privKeys [] preBalancedTx + + -- finally, we must update the signatories + hoistEither $ addSignatories ownPkh privKeys requiredSigs balancedTx where loop :: Map TxOutRef TxOut -> Map PubKeyHash DummyPrivKey -> - [PubKeyHash] -> [(TxOut, Integer)] -> Tx -> EitherT Text (Eff effs) Tx - loop utxoIndex privKeys requiredSigs prevMinUtxos tx = do + loop utxoIndex privKeys prevMinUtxos tx = do void $ lift $ Files.writeAll @w pabConf tx nextMinUtxos <- newEitherT $ @@ -102,20 +107,24 @@ preBalanceTxIO pabConf ownPkh unbalancedTx = lift $ printLog @w Debug $ "Min utxos: " ++ show minUtxos + -- Calculate fees by pre-balancing the tx, building it, and running the CLI on result txWithoutFees <- - hoistEither $ preBalanceTx pabConf.pcProtocolParams minUtxos 0 utxoIndex ownPkh privKeys requiredSigs tx + hoistEither $ balanceTxStep minUtxos 0 utxoIndex ownPkh tx lift $ createDirectoryIfMissing @w False (Text.unpack pabConf.pcTxFileDir) - newEitherT $ CardanoCLI.buildTx @w pabConf privKeys ownPkh (CardanoCLI.BuildRaw 0) txWithoutFees + newEitherT $ CardanoCLI.buildTx @w pabConf privKeys txWithoutFees fees <- newEitherT $ CardanoCLI.calculateMinFee @w pabConf txWithoutFees lift $ printLog @w Debug $ "Fees: " ++ show fees - balancedTx <- hoistEither $ preBalanceTx pabConf.pcProtocolParams minUtxos fees utxoIndex ownPkh privKeys requiredSigs tx + -- Rebalance the initial tx with the above fees + balancedTx <- hoistEither $ balanceTxStep minUtxos fees utxoIndex ownPkh tx + + let balanceTxWithFees = balancedTx {txFee = Ada.lovelaceValueOf fees} - if balancedTx == tx - then pure balancedTx - else loop utxoIndex privKeys requiredSigs minUtxos balancedTx + if balanceTxWithFees == tx + then pure balanceTxWithFees + else loop utxoIndex privKeys minUtxos balanceTxWithFees calculateMinUtxos :: forall (w :: Type) (effs :: [Type -> Type]). @@ -127,24 +136,17 @@ calculateMinUtxos :: calculateMinUtxos pabConf datums txOuts = zipWithM (fmap . (,)) txOuts <$> mapM (CardanoCLI.calculateMinUtxo @w pabConf datums) txOuts -preBalanceTx :: - ProtocolParameters -> +balanceTxStep :: [(TxOut, Integer)] -> Integer -> Map TxOutRef TxOut -> PubKeyHash -> - Map PubKeyHash DummyPrivKey -> - [PubKeyHash] -> Tx -> Either Text Tx -preBalanceTx pparams minUtxos fees utxos ownPkh privKeys requiredSigs tx = - addTxCollaterals utxos tx - >>= balanceTxIns pparams utxos fees - >>= balanceNonAdaOuts ownPkh utxos - >>= Right . addLovelaces minUtxos - >>= balanceTxIns pparams utxos fees -- Adding more inputs if required - >>= balanceNonAdaOuts ownPkh utxos - >>= addSignatories ownPkh privKeys requiredSigs +balanceTxStep minUtxos fees utxos ownPkh tx = + Right (addLovelaces minUtxos tx) + >>= balanceTxIns utxos fees + >>= handleChange ownPkh utxos fees -- | Getting the necessary utxos to cover the fees for the transaction collectTxIns :: Set TxIn -> Map TxOutRef TxOut -> Value -> Either Text (Set TxIn) @@ -202,18 +204,13 @@ addLovelaces minLovelaces tx = $ txOutputs tx in tx {txOutputs = lovelacesAdded} -balanceTxIns :: ProtocolParameters -> Map TxOutRef TxOut -> Integer -> Tx -> Either Text Tx -balanceTxIns pparams utxos fees tx = do - Lovelace utxoCost <- - maybeToRight "UTxOCostPerWord parameter not found" $ protocolParamUTxOCostPerWord pparams +balanceTxIns :: Map TxOutRef TxOut -> Integer -> Tx -> Either Text Tx +balanceTxIns utxos fees tx = do let txOuts = Tx.txOutputs tx nonMintedValue = mconcat (map Tx.txOutValue txOuts) `minus` txMint tx - -- An ada-only UTxO entry is 29 words. More details about min utxo calculation can be found here: - -- https://github.com/cardano-foundation/CIPs/tree/master/CIP-0028#rationale-for-parameter-choices - changeMinUtxo = 29 * utxoCost minSpending = mconcat - [ Ada.lovelaceValueOf (fees + changeMinUtxo) + [ Ada.lovelaceValueOf fees , nonMintedValue ] txIns <- collectTxIns (txInputs tx) utxos minSpending @@ -235,28 +232,28 @@ addTxCollaterals utxos tx = do _ -> Left "There are no utxos to be used as collateral" filterAdaOnly = Map.filter (isAdaOnly . txOutValue) --- | We need to balance non ada values, as the cardano-cli is unable to balance them (as of 2021/09/24) -balanceNonAdaOuts :: PubKeyHash -> Map TxOutRef TxOut -> Tx -> Either Text Tx -balanceNonAdaOuts ownPkh utxos tx = +-- | Ensures all change goes back to user +handleChange :: PubKeyHash -> Map TxOutRef TxOut -> Integer -> Tx -> Either Text Tx +handleChange ownPkh utxos fees tx = let changeAddr = Ledger.pubKeyHashAddress (Ledger.PaymentPubKeyHash ownPkh) Nothing txInRefs = map Tx.txInRef $ Set.toList $ txInputs tx inputValue = mconcat $ map Tx.txOutValue $ mapMaybe (`Map.lookup` utxos) txInRefs outputValue = mconcat $ map Tx.txOutValue $ txOutputs tx nonMintedOutputValue = outputValue `minus` txMint tx - nonAdaChange = filterNonAda inputValue `minus` filterNonAda nonMintedOutputValue + change = (inputValue `minus` nonMintedOutputValue) `minus` Ada.lovelaceValueOf fees outputs = case partition ((==) changeAddr . Tx.txOutAddress) $ txOutputs tx of ([], txOuts) -> TxOut { txOutAddress = changeAddr - , txOutValue = nonAdaChange + , txOutValue = change , txOutDatumHash = Nothing } : txOuts (txOut@TxOut {txOutValue = v} : txOuts, txOuts') -> - txOut {txOutValue = v <> nonAdaChange} : (txOuts <> txOuts') - in if isValueNat nonAdaChange - then Right $ if Value.isZero nonAdaChange then tx else tx {txOutputs = outputs} + txOut {txOutValue = v <> change} : (txOuts <> txOuts') + in if isValueNat change + then Right $ if Value.isZero change then tx else tx {txOutputs = outputs} else Left "Not enough inputs to balance tokens." {- | Add the required signatorioes to the transaction. Be aware the the signature itself is invalid, @@ -289,14 +286,6 @@ validateRange _ = True showText :: forall (a :: Type). Show a => a -> Text showText = Text.pack . show --- | Filter by key for Associated maps (why doesn't this exist?) -filterKey :: (k -> Bool) -> AssocMap.Map k v -> AssocMap.Map k v -filterKey f = AssocMap.mapMaybeWithKey $ \k v -> if f k then Just v else Nothing - --- | Filter a value to contain only non ada assets -filterNonAda :: Value -> Value -filterNonAda = Value . filterKey (/= Ada.adaSymbol) . getValue - minus :: Value -> Value -> Value minus x y = let negativeValues = map (\(c, t, a) -> (c, t, - a)) $ Value.flattenValue y diff --git a/src/BotPlutusInterface/CardanoCLI.hs b/src/BotPlutusInterface/CardanoCLI.hs index 7194befc..fea3ba04 100644 --- a/src/BotPlutusInterface/CardanoCLI.hs +++ b/src/BotPlutusInterface/CardanoCLI.hs @@ -2,7 +2,6 @@ {-# LANGUAGE NamedFieldPuns #-} module BotPlutusInterface.CardanoCLI ( - BuildMode (..), submitTx, calculateMinUtxo, calculateMinFee, @@ -80,6 +79,7 @@ import Ledger.TxId (TxId (..)) import Ledger.Value (Value) import Ledger.Value qualified as Value import Plutus.Contract.CardanoAPI (toCardanoAddress) +import Plutus.V1.Ledger.Ada (fromValue, getLovelace) import Plutus.V1.Ledger.Api ( BuiltinData, CurrencySymbol (..), @@ -190,27 +190,17 @@ calculateMinFee pabConf tx = , cmdOutParser = mapLeft Text.pack . parseOnly UtxoParser.feeParser . Text.pack } -data BuildMode = BuildRaw Integer | BuildAuto - deriving stock (Show) - -isRawBuildMode :: BuildMode -> Bool -isRawBuildMode (BuildRaw _) = True -isRawBuildMode _ = False - -- | Build a tx body and write it to disk buildTx :: forall (w :: Type) (effs :: [Type -> Type]). Member (PABEffect w) effs => PABConfig -> Map PubKeyHash DummyPrivKey -> - PubKeyHash -> - BuildMode -> Tx -> Eff effs (Either Text ()) -buildTx pabConf privKeys ownPkh buildMode tx = +buildTx pabConf privKeys tx = callCommand @w $ ShellArgs "cardano-cli" opts (const ()) where - ownAddr = Ledger.pubKeyHashAddress (Ledger.PaymentPubKeyHash ownPkh) Nothing requiredSigners = concatMap ( \pubKey -> @@ -226,20 +216,14 @@ buildTx pabConf privKeys ownPkh buildMode tx = (Map.keys (Ledger.txSignatures tx)) opts = mconcat - [ ["transaction", if isRawBuildMode buildMode then "build-raw" else "build", "--alonzo-era"] - , txInOpts pabConf buildMode (txInputs tx) + [ ["transaction", "build-raw", "--alonzo-era"] + , txInOpts pabConf (txInputs tx) , txInCollateralOpts (txCollateral tx) , txOutOpts pabConf (txData tx) (txOutputs tx) - , mintOpts pabConf buildMode (txMintScripts tx) (txRedeemers tx) (txMint tx) + , mintOpts pabConf (txMintScripts tx) (txRedeemers tx) (txMint tx) , validRangeOpts (txValidRange tx) , requiredSigners - , case buildMode of - BuildRaw fee -> ["--fee", showText fee] - BuildAuto -> - mconcat - [ ["--change-address", unsafeSerialiseAddress pabConf.pcNetwork ownAddr] - , networkOpt pabConf - ] + , ["--fee", showText . getLovelace . fromValue $ txFee tx] , mconcat [ ["--protocol-params-file", pabConf.pcProtocolParamsFile] , ["--out-file", txFilePath pabConf "raw" tx] @@ -289,8 +273,8 @@ submitTx pabConf tx = ) (const ()) -txInOpts :: PABConfig -> BuildMode -> Set TxIn -> [Text] -txInOpts pabConf buildMode = +txInOpts :: PABConfig -> Set TxIn -> [Text] +txInOpts pabConf = concatMap ( \(TxIn txOutRef txInType) -> mconcat @@ -315,9 +299,10 @@ txInOpts pabConf buildMode = [ "--tx-in-redeemer-file" , redeemerJsonFilePath pabConf (Ledger.redeemerHash redeemer) ] - , if isRawBuildMode buildMode - then ["--tx-in-execution-units", exBudgetToCliArg exBudget] - else [] + , + [ "--tx-in-execution-units" + , exBudgetToCliArg exBudget + ] ] Just ConsumePublicKeyAddress -> [] Just ConsumeSimpleScriptAddress -> [] @@ -331,8 +316,8 @@ txInCollateralOpts = concatMap (\(TxIn txOutRef _) -> ["--tx-in-collateral", txOutRefToCliArg txOutRef]) . Set.toList -- Minting options -mintOpts :: PABConfig -> BuildMode -> Set Scripts.MintingPolicy -> Redeemers -> Value -> [Text] -mintOpts pabConf buildMode mintingPolicies redeemers mintValue = +mintOpts :: PABConfig -> Set Scripts.MintingPolicy -> Redeemers -> Value -> [Text] +mintOpts pabConf mintingPolicies redeemers mintValue = mconcat [ mconcat $ concatMap @@ -348,9 +333,7 @@ mintOpts pabConf buildMode mintingPolicies redeemers mintValue = toOpts r = [ ["--mint-script-file", policyScriptFilePath pabConf curSymbol] , ["--mint-redeemer-file", redeemerJsonFilePath pabConf (Ledger.redeemerHash r)] - , if isRawBuildMode buildMode - then ["--mint-execution-units", exBudgetToCliArg (exBudget r)] - else [] + , ["--mint-execution-units", exBudgetToCliArg (exBudget r)] ] in mconcat $ maybeToList $ fmap toOpts redeemer ) diff --git a/src/BotPlutusInterface/Contract.hs b/src/BotPlutusInterface/Contract.hs index 6bae5367..67dc9c10 100644 --- a/src/BotPlutusInterface/Contract.hs +++ b/src/BotPlutusInterface/Contract.hs @@ -3,6 +3,7 @@ module BotPlutusInterface.Contract (runContract, handleContract) where +import BotPlutusInterface.Balance qualified as PreBalance import BotPlutusInterface.CardanoCLI qualified as CardanoCLI import BotPlutusInterface.Effects ( PABEffect, @@ -15,7 +16,6 @@ import BotPlutusInterface.Effects ( ) import BotPlutusInterface.Files (DummyPrivKey (FromSKey, FromVKey)) import BotPlutusInterface.Files qualified as Files -import BotPlutusInterface.PreBalance qualified as PreBalance import BotPlutusInterface.Types (ContractEnvironment (..), LogLevel (Debug, Warn), Tip (slot)) import Control.Lens ((^.)) import Control.Monad (void) @@ -135,7 +135,7 @@ handlePABReq contractEnv req = do ChainIndexQueryReq query -> ChainIndexQueryResp <$> queryChainIndex @w query BalanceTxReq unbalancedTx -> - BalanceTxResp <$> balanceTx @w contractEnv unbalancedTx + BalanceTxResp <$> balanceTxStep @w contractEnv unbalancedTx WriteBalancedTxReq tx -> WriteBalancedTxResp <$> writeBalancedTx @w contractEnv tx AwaitSlotReq s -> AwaitSlotResp <$> awaitSlot @w contractEnv s @@ -163,15 +163,15 @@ handlePABReq contractEnv req = do pure resp -- | This is not identical to the real balancing, we only do a pre-balance at this stage -balanceTx :: +balanceTxStep :: forall (w :: Type) (effs :: [Type -> Type]). Member (PABEffect w) effs => ContractEnvironment w -> UnbalancedTx -> Eff effs BalanceTxResponse -balanceTx contractEnv unbalancedTx = do +balanceTxStep contractEnv unbalancedTx = do eitherPreBalancedTx <- - PreBalance.preBalanceTxIO @w + PreBalance.balanceTxIO @w contractEnv.cePABConfig (contractEnv.cePABConfig.pcOwnPubKeyHash) unbalancedTx @@ -194,14 +194,13 @@ writeBalancedTx contractEnv (Right tx) = do void $ firstEitherT (Text.pack . show) $ newEitherT $ Files.writeAll @w pabConf tx privKeys <- newEitherT $ Files.readPrivateKeys @w pabConf - let ownPkh = pabConf.pcOwnPubKeyHash let requiredSigners = Map.keys $ tx ^. Tx.signatures - let skeys = Map.filter (\case FromSKey _ -> True; FromVKey _ -> False) privKeys - let signable = all ((`Map.member` skeys) . Ledger.pubKeyHash) requiredSigners + skeys = Map.filter (\case FromSKey _ -> True; FromVKey _ -> False) privKeys + signable = all ((`Map.member` skeys) . Ledger.pubKeyHash) requiredSigners lift $ CardanoCLI.uploadFiles @w pabConf - newEitherT $ CardanoCLI.buildTx @w pabConf privKeys ownPkh CardanoCLI.BuildAuto tx + newEitherT $ CardanoCLI.buildTx @w pabConf privKeys tx if signable then newEitherT $ CardanoCLI.signTx @w pabConf tx requiredSigners diff --git a/test/Spec.hs b/test/Spec.hs index 866f076f..409e70be 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,7 +1,7 @@ module Main (main) where +import Spec.BotPlutusInterface.Balance qualified import Spec.BotPlutusInterface.Contract qualified -import Spec.BotPlutusInterface.PreBalance qualified import Spec.BotPlutusInterface.UtxoParser qualified import Test.Tasty (TestTree, defaultMain, testGroup) import Prelude @@ -20,5 +20,5 @@ tests = "BotPlutusInterface" [ Spec.BotPlutusInterface.Contract.tests , Spec.BotPlutusInterface.UtxoParser.tests - , Spec.BotPlutusInterface.PreBalance.tests + , Spec.BotPlutusInterface.Balance.tests ] diff --git a/test/Spec/BotPlutusInterface/PreBalance.hs b/test/Spec/BotPlutusInterface/Balance.hs similarity index 70% rename from test/Spec/BotPlutusInterface/PreBalance.hs rename to test/Spec/BotPlutusInterface/Balance.hs index 9ff2663b..81540bb2 100644 --- a/test/Spec/BotPlutusInterface/PreBalance.hs +++ b/test/Spec/BotPlutusInterface/Balance.hs @@ -1,9 +1,6 @@ -module Spec.BotPlutusInterface.PreBalance (tests) where +module Spec.BotPlutusInterface.Balance (tests) where -import BotPlutusInterface.Files (DummyPrivKey (FromSKey)) -import BotPlutusInterface.PreBalance qualified as PreBalance -import Cardano.Api.Shelley (Lovelace (Lovelace), ProtocolParameters (protocolParamUTxOCostPerWord)) -import Data.Default (def) +import BotPlutusInterface.Balance qualified as Balance import Data.Map qualified as Map import Data.Set qualified as Set import Ledger qualified @@ -25,15 +22,12 @@ import Prelude tests :: TestTree tests = testGroup - "BotPlutusInterface.PreBalance" + "BotPlutusInterface.Balance" [ testCase "Add utxos to cover fees" addUtxosForFees , testCase "Add utxos to cover native tokens" addUtxosForNativeTokens , testCase "Add utxos to cover change min utxo" addUtxosForChange ] -privateKey1 :: DummyPrivKey -privateKey1 = FromSKey . Address.unPaymentPrivateKey . Wallet.paymentPrivateKey $ Wallet.knownMockWallet 1 - pkh1, pkh2 :: PubKeyHash pkh1 = Address.unPaymentPubKeyHash . Wallet.paymentPubKeyHash $ Wallet.knownMockWallet 1 pkh2 = Address.unPaymentPubKeyHash . Wallet.paymentPubKeyHash $ Wallet.knownMockWallet 2 @@ -67,13 +61,11 @@ addUtxosForFees = do minUtxo = [(txout, 1_000_000)] fees = 500_000 utxoIndex = Map.fromList [utxo1, utxo2, utxo3] - privKeys = Map.fromList [(pkh1, privateKey1)] - requiredSigs = [pkh1] ownPkh = pkh1 - prebalancedTx = - PreBalance.preBalanceTx def minUtxo fees utxoIndex ownPkh privKeys requiredSigs tx + balancedTx = + Balance.balanceTxStep minUtxo fees utxoIndex ownPkh tx - txInputs <$> prebalancedTx @?= Right (Set.fromList [txIn1, txIn2]) + txInputs <$> balancedTx @?= Right (Set.fromList [txIn1, txIn2]) addUtxosForNativeTokens :: Assertion addUtxosForNativeTokens = do @@ -82,13 +74,11 @@ addUtxosForNativeTokens = do minUtxo = [(txout, 1_000_000)] fees = 500_000 utxoIndex = Map.fromList [utxo1, utxo2, utxo3, utxo4] - privKeys = Map.fromList [(pkh1, privateKey1)] - requiredSigs = [pkh1] ownPkh = pkh1 - prebalancedTx = - PreBalance.preBalanceTx def minUtxo fees utxoIndex ownPkh privKeys requiredSigs tx + balancedTx = + Balance.balanceTxStep minUtxo fees utxoIndex ownPkh tx - txInputs <$> prebalancedTx @?= Right (Set.fromList [txIn1, txIn2, txIn3, txIn4]) + txInputs <$> balancedTx @?= Right (Set.fromList [txIn1, txIn2, txIn3, txIn4]) addUtxosForChange :: Assertion addUtxosForChange = do @@ -97,11 +87,8 @@ addUtxosForChange = do minUtxo = [(txout, 1_000_000)] fees = 500_000 utxoIndex = Map.fromList [utxo1, utxo2, utxo3] - privKeys = Map.fromList [(pkh1, privateKey1)] - requiredSigs = [pkh1] ownPkh = pkh1 - pparams = def {protocolParamUTxOCostPerWord = Just (Lovelace 1)} - prebalancedTx = - PreBalance.preBalanceTx pparams minUtxo fees utxoIndex ownPkh privKeys requiredSigs tx + balancedTx = + Balance.balanceTxStep minUtxo fees utxoIndex ownPkh tx - txInputs <$> prebalancedTx @?= Right (Set.fromList [txIn1, txIn2, txIn3]) + txInputs <$> balancedTx @?= Right (Set.fromList [txIn1, txIn2]) diff --git a/test/Spec/BotPlutusInterface/Contract.hs b/test/Spec/BotPlutusInterface/Contract.hs index fdd18463..351fe068 100644 --- a/test/Spec/BotPlutusInterface/Contract.hs +++ b/test/Spec/BotPlutusInterface/Contract.hs @@ -1,7 +1,7 @@ {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} -module Spec.BotPlutusInterface.Contract (tests) where +module Spec.BotPlutusInterface.Contract (tests, commandEqual) where import BotPlutusInterface.CardanoCLI (unsafeSerialiseAddress) import Cardano.Api (NetworkId (Mainnet)) @@ -11,6 +11,7 @@ import Data.Aeson.Extras (encodeByteString) import Data.Default (def) import Data.Kind (Type) import Data.Map qualified as Map +import Data.Maybe (fromMaybe) import Data.Monoid (Last (Last)) import Data.Row (Row) import Data.Set qualified as Set @@ -129,38 +130,41 @@ sendAda = do cardano-cli transaction build-raw --alonzo-era --tx-in ${inTxId}#0 --tx-in-collateral ${inTxId}#0 + --tx-out ${addr1}+250 --tx-out ${addr2}+1000 --required-signer ./signing-keys/signing-key-${pkh1'}.skey --fee 0 - --protocol-params-file ./protocol.json --out-file ./txs/tx-${outTxId}.raw + --protocol-params-file ./protocol.json --out-file ./txs/tx-? |] ) , ( 3 , [text| cardano-cli transaction calculate-min-fee - --tx-body-file ./txs/tx-${outTxId}.raw + --tx-body-file ./txs/tx-? --tx-in-count 1 - --tx-out-count 1 + --tx-out-count 2 --witness-count 1 --protocol-params-file ./protocol.json --mainnet |] ) - , - ( 6 + , -- Steps 4, 5 and 6 are near repeats of 1, 2 and 3, to ensure min utxo values are met + + ( 7 , [text| - cardano-cli transaction build --alonzo-era + cardano-cli transaction build-raw --alonzo-era --tx-in ${inTxId}#0 --tx-in-collateral ${inTxId}#0 + --tx-out ${addr1}+50 --tx-out ${addr2}+1000 --required-signer ./signing-keys/signing-key-${pkh1'}.skey - --change-address ${addr1} - --mainnet --protocol-params-file ./protocol.json --out-file ./txs/tx-${outTxId}.raw + --fee 200 + --protocol-params-file ./protocol.json --out-file ./txs/tx-${outTxId}.raw |] ) , - ( 7 + ( 8 , [text| cardano-cli transaction sign --tx-body-file ./txs/tx-${outTxId}.raw @@ -211,38 +215,40 @@ sendAdaStaking = do cardano-cli transaction build-raw --alonzo-era --tx-in ${inTxId}#0 --tx-in-collateral ${inTxId}#0 + --tx-out ${addr1}+250 --tx-out ${addr2Staking}+1000 --required-signer ./signing-keys/signing-key-${pkh1'}.skey --fee 0 - --protocol-params-file ./protocol.json --out-file ./txs/tx-${outTxId}.raw + --protocol-params-file ./protocol.json --out-file ./txs/tx-? |] ) , ( 3 , [text| cardano-cli transaction calculate-min-fee - --tx-body-file ./txs/tx-${outTxId}.raw + --tx-body-file ./txs/tx-? --tx-in-count 1 - --tx-out-count 1 + --tx-out-count 2 --witness-count 1 --protocol-params-file ./protocol.json --mainnet |] ) , - ( 6 + ( 7 , [text| - cardano-cli transaction build --alonzo-era + cardano-cli transaction build-raw --alonzo-era --tx-in ${inTxId}#0 --tx-in-collateral ${inTxId}#0 + --tx-out ${addr1}+50 --tx-out ${addr2Staking}+1000 --required-signer ./signing-keys/signing-key-${pkh1'}.skey - --change-address ${addr1} - --mainnet --protocol-params-file ./protocol.json --out-file ./txs/tx-${outTxId}.raw + --fee 200 + --protocol-params-file ./protocol.json --out-file ./txs/tx-${outTxId}.raw |] ) , - ( 7 + ( 8 , [text| cardano-cli transaction sign --tx-body-file ./txs/tx-${outTxId}.raw @@ -274,29 +280,30 @@ multisigSupport = do ( 3 , [text| cardano-cli transaction calculate-min-fee - --tx-body-file ./txs/tx-${outTxId}.raw + --tx-body-file ./txs/tx-? --tx-in-count 1 - --tx-out-count 1 + --tx-out-count 2 --witness-count 2 --protocol-params-file ./protocol.json --mainnet |] ) , - ( 6 + ( 7 , [text| - cardano-cli transaction build --alonzo-era + cardano-cli transaction build-raw --alonzo-era --tx-in ${inTxId}#0 --tx-in-collateral ${inTxId}#0 + --tx-out ${addr1}+50 --tx-out ${addr2}+1000 --required-signer ./signing-keys/signing-key-${pkh1'}.skey --required-signer ./signing-keys/signing-key-${pkh3'}.skey - --change-address ${addr1} - --mainnet --protocol-params-file ./protocol.json --out-file ./txs/tx-${outTxId}.raw + --fee 200 + --protocol-params-file ./protocol.json --out-file ./txs/tx-${outTxId}.raw |] ) , - ( 7 + ( 8 , [text| cardano-cli transaction sign --tx-body-file ./txs/tx-${outTxId}.raw @@ -334,16 +341,17 @@ withoutSigning = do assertCommandHistory state [ - ( 6 + ( 7 , [text| - cardano-cli transaction build --alonzo-era + cardano-cli transaction build-raw --alonzo-era --tx-in ${inTxId}#0 --tx-in-collateral ${inTxId}#0 + --tx-out ${addr1}+50 --tx-out ${addr2}+1000 --required-signer ./signing-keys/signing-key-${pkh1'}.skey --required-signer-hash ${pkh3'} - --change-address ${addr1} - --mainnet --protocol-params-file ./protocol.json --out-file ./txs/tx-${outTxId}.raw + --fee 200 + --protocol-params-file ./protocol.json --out-file ./txs/tx-${outTxId}.raw |] ) ] @@ -379,16 +387,16 @@ sendTokens = do assertCommandHistory state [ - ( 10 + ( 7 , [text| - cardano-cli transaction build --alonzo-era + cardano-cli transaction build-raw --alonzo-era --tx-in ${inTxId1}#0 --tx-in-collateral ${inTxId2}#1 - --tx-out ${addr1}+50 + 95 abcd1234.74657374546F6B656E + --tx-out ${addr1}+100 + 95 abcd1234.74657374546F6B656E --tx-out ${addr2}+1000 + 5 abcd1234.74657374546F6B656E --required-signer ./signing-keys/signing-key-${pkh1'}.skey - --change-address ${addr1} - --mainnet --protocol-params-file ./protocol.json --out-file ./txs/tx-${outTxId}.raw + --fee 200 + --protocol-params-file ./protocol.json --out-file ./txs/tx-${outTxId}.raw |] ) ] @@ -423,16 +431,16 @@ sendTokensWithoutName = do assertCommandHistory state [ - ( 10 + ( 7 , [text| - cardano-cli transaction build --alonzo-era + cardano-cli transaction build-raw --alonzo-era --tx-in ${inTxId1}#0 --tx-in-collateral ${inTxId2}#1 - --tx-out ${addr1}+50 + 95 abcd1234 + --tx-out ${addr1}+100 + 95 abcd1234 --tx-out ${addr2}+1000 + 5 abcd1234 --required-signer ./signing-keys/signing-key-${pkh1'}.skey - --change-address ${addr1} - --mainnet --protocol-params-file ./protocol.json --out-file ./txs/tx-${outTxId}.raw + --fee 200 + --protocol-params-file ./protocol.json --out-file ./txs/tx-${outTxId}.raw |] ) ] @@ -479,6 +487,7 @@ mintTokens = do cardano-cli transaction build-raw --alonzo-era --tx-in ${inTxId}#0 --tx-in-collateral ${inTxId}#0 + --tx-out ${addr1}+250 --tx-out ${addr2}+1000 + 5 ${curSymbol'}.74657374546F6B656E --mint-script-file ./result-scripts/policy-${curSymbol'}.plutus --mint-redeemer-file ./result-scripts/redeemer-${redeemerHash}.json @@ -486,22 +495,24 @@ mintTokens = do --mint 5 ${curSymbol'}.74657374546F6B656E --required-signer ./signing-keys/signing-key-${pkh1'}.skey --fee 0 - --protocol-params-file ./protocol.json --out-file ./txs/tx-${outTxId}.raw + --protocol-params-file ./protocol.json --out-file ./txs/tx-? |] ) , - ( 6 + ( 7 , [text| - cardano-cli transaction build --alonzo-era + cardano-cli transaction build-raw --alonzo-era --tx-in ${inTxId}#0 --tx-in-collateral ${inTxId}#0 + --tx-out ${addr1}+50 --tx-out ${addr2}+1000 + 5 ${curSymbol'}.74657374546F6B656E --mint-script-file ./result-scripts/policy-${curSymbol'}.plutus --mint-redeemer-file ./result-scripts/redeemer-${redeemerHash}.json + --mint-execution-units (297830,1100) --mint 5 ${curSymbol'}.74657374546F6B656E --required-signer ./signing-keys/signing-key-${pkh1'}.skey - --change-address ${addr1} - --mainnet --protocol-params-file ./protocol.json --out-file ./txs/tx-${outTxId}.raw + --fee 200 + --protocol-params-file ./protocol.json --out-file ./txs/tx-${outTxId}.raw |] ) ] @@ -571,27 +582,29 @@ spendToValidator = do cardano-cli transaction build-raw --alonzo-era --tx-in ${inTxId}#0 --tx-in-collateral ${inTxId}#0 + --tx-out ${addr1}+500 --tx-out ${valAddr'}+500 --tx-out-datum-embed-file ./result-scripts/datum-${datumHash'}.json --required-signer ./signing-keys/signing-key-${pkh1'}.skey - --fee 0 --protocol-params-file ./protocol.json --out-file ./txs/tx-${outTxId}.raw + --fee 0 + --protocol-params-file ./protocol.json --out-file ./txs/tx-? |] ) , - ( 6 + ( 7 , [text| - cardano-cli transaction build --alonzo-era + cardano-cli transaction build-raw --alonzo-era --tx-in ${inTxId}#0 --tx-in-collateral ${inTxId}#0 + --tx-out ${addr1}+300 --tx-out ${valAddr'}+500 --tx-out-datum-embed-file ./result-scripts/datum-${datumHash'}.json --required-signer ./signing-keys/signing-key-${pkh1'}.skey - --change-address ${addr1} - --mainnet --protocol-params-file ./protocol.json --out-file ./txs/tx-${outTxId}.raw + --fee 200 + --protocol-params-file ./protocol.json --out-file ./txs/tx-${outTxId}.raw |] ) ] - --tx-out-datum-file result-scripts/datum-${datumHash'}.json assertFiles state @@ -665,24 +678,27 @@ redeemFromValidator = do --tx-in-redeemer-file ./result-scripts/redeemer-${redeemerHash}.json --tx-in-execution-units (387149,1400) --tx-in-collateral ${inTxId}#0 + --tx-out ${addr1}+750 --tx-out ${addr2}+500 --required-signer ./signing-keys/signing-key-${pkh1'}.skey - --fee 0 --protocol-params-file ./protocol.json --out-file ./txs/tx-${outTxId}.raw + --fee 0 --protocol-params-file ./protocol.json --out-file ./txs/tx-? |] ) , - ( 6 + ( 7 , [text| - cardano-cli transaction build --alonzo-era + cardano-cli transaction build-raw --alonzo-era --tx-in ${inTxId}#1 --tx-in-script-file ./result-scripts/validator-${valHash'}.plutus --tx-in-datum-file ./result-scripts/datum-${datumHash'}.json --tx-in-redeemer-file ./result-scripts/redeemer-${redeemerHash}.json + --tx-in-execution-units (387149,1400) --tx-in-collateral ${inTxId}#0 + --tx-out ${addr1}+550 --tx-out ${addr2}+500 --required-signer ./signing-keys/signing-key-${pkh1'}.skey - --change-address ${addr1} - --mainnet --protocol-params-file ./protocol.json --out-file ./txs/tx-${outTxId}.raw + --fee 200 + --protocol-params-file ./protocol.json --out-file ./txs/tx-${outTxId}.raw |] ) ] @@ -752,26 +768,28 @@ withValidRange = do cardano-cli transaction build-raw --alonzo-era --tx-in ${inTxId}#0 --tx-in-collateral ${inTxId}#0 + --tx-out ${addr1}+250 --tx-out ${addr2}+1000 --invalid-before 47577202 --invalid-hereafter 50255602 --required-signer ./signing-keys/signing-key-${pkh1'}.skey --fee 0 - --protocol-params-file ./protocol.json --out-file ./txs/tx-${outTxId}.raw + --protocol-params-file ./protocol.json --out-file ./txs/tx-? |] ) , - ( 6 + ( 7 , [text| - cardano-cli transaction build --alonzo-era + cardano-cli transaction build-raw --alonzo-era --tx-in ${inTxId}#0 --tx-in-collateral ${inTxId}#0 + --tx-out ${addr1}+50 --tx-out ${addr2}+1000 --invalid-before 47577202 --invalid-hereafter 50255602 --required-signer ./signing-keys/signing-key-${pkh1'}.skey - --change-address ${addr1} - --mainnet --protocol-params-file ./protocol.json --out-file ./txs/tx-${outTxId}.raw + --fee 200 + --protocol-params-file ./protocol.json --out-file ./txs/tx-${outTxId}.raw |] ) ] @@ -851,9 +869,27 @@ assertCommandHistory :: forall (w :: Type). MockContractState w -> [(Int, Text)] assertCommandHistory state = mapM_ ( \(idx, expectedCmd) -> - (state ^? commandHistory . ix idx) @?= Just (Text.replace "\n" " " expectedCmd) + assertCommandEqual + ("command at index " ++ show idx ++ " was incorrect:") + (fromMaybe "" $ state ^? commandHistory . ix idx) + (Text.replace "\n" " " expectedCmd) ) +assertCommandEqual :: String -> Text -> Text -> Assertion +assertCommandEqual err actual expected + | commandEqual actual expected = return () + | otherwise = assertFailure $ err ++ "\nExpected:\n" ++ show expected ++ "\nGot:\n" ++ show actual + +commandEqual :: Text -> Text -> Bool +commandEqual "" "" = True +commandEqual "" _ = False +commandEqual _ "" = False +commandEqual actual expected = maybe False (\restAct -> commandEqual (dropToSpace restAct) (dropToSpace postExp)) mRestAct + where + (preExp, postExp) = Text.breakOn "?" expected + mRestAct = Text.stripPrefix preExp actual + dropToSpace = Text.dropWhile (/= ' ') + assertCommandCalled :: forall (w :: Type). MockContractState w -> Text -> Assertion assertCommandCalled state expectedCmd = assertBool From d5be991be27cb3d76ffe154be043391295262250 Mon Sep 17 00:00:00 2001 From: Samuel Williams Date: Mon, 14 Feb 2022 11:21:02 +0000 Subject: [PATCH 2/9] Slight refactor --- test/Spec/BotPlutusInterface/Contract.hs | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/test/Spec/BotPlutusInterface/Contract.hs b/test/Spec/BotPlutusInterface/Contract.hs index 351fe068..2503782f 100644 --- a/test/Spec/BotPlutusInterface/Contract.hs +++ b/test/Spec/BotPlutusInterface/Contract.hs @@ -9,6 +9,7 @@ import Control.Lens (ix, (&), (.~), (^.), (^?)) import Data.Aeson (ToJSON) import Data.Aeson.Extras (encodeByteString) import Data.Default (def) +import Data.Function (on) import Data.Kind (Type) import Data.Map qualified as Map import Data.Maybe (fromMaybe) @@ -871,20 +872,20 @@ assertCommandHistory state = ( \(idx, expectedCmd) -> assertCommandEqual ("command at index " ++ show idx ++ " was incorrect:") - (fromMaybe "" $ state ^? commandHistory . ix idx) (Text.replace "\n" " " expectedCmd) + (fromMaybe "" $ state ^? commandHistory . ix idx) ) assertCommandEqual :: String -> Text -> Text -> Assertion -assertCommandEqual err actual expected - | commandEqual actual expected = return () +assertCommandEqual err expected actual + | commandEqual expected actual = return () | otherwise = assertFailure $ err ++ "\nExpected:\n" ++ show expected ++ "\nGot:\n" ++ show actual commandEqual :: Text -> Text -> Bool commandEqual "" "" = True commandEqual "" _ = False commandEqual _ "" = False -commandEqual actual expected = maybe False (\restAct -> commandEqual (dropToSpace restAct) (dropToSpace postExp)) mRestAct +commandEqual expected actual = maybe False (on commandEqual dropToSpace postExp) mRestAct where (preExp, postExp) = Text.breakOn "?" expected mRestAct = Text.stripPrefix preExp actual From de358176dfbbe7f79962267abe24bee09e901d17 Mon Sep 17 00:00:00 2001 From: Samuel Williams Date: Mon, 14 Feb 2022 11:23:53 +0000 Subject: [PATCH 3/9] Slight rename --- test/Spec/BotPlutusInterface/Contract.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/test/Spec/BotPlutusInterface/Contract.hs b/test/Spec/BotPlutusInterface/Contract.hs index 2503782f..b52d280f 100644 --- a/test/Spec/BotPlutusInterface/Contract.hs +++ b/test/Spec/BotPlutusInterface/Contract.hs @@ -885,10 +885,10 @@ commandEqual :: Text -> Text -> Bool commandEqual "" "" = True commandEqual "" _ = False commandEqual _ "" = False -commandEqual expected actual = maybe False (on commandEqual dropToSpace postExp) mRestAct +commandEqual expected actual = maybe False (on commandEqual dropToSpace postExp) mPostAct where (preExp, postExp) = Text.breakOn "?" expected - mRestAct = Text.stripPrefix preExp actual + mPostAct = Text.stripPrefix preExp actual dropToSpace = Text.dropWhile (/= ' ') assertCommandCalled :: forall (w :: Type). MockContractState w -> Text -> Assertion From e3becb6ca2d70af2f80c91f6e74207a5be3a848d Mon Sep 17 00:00:00 2001 From: Samuel Williams Date: Mon, 14 Feb 2022 23:23:18 +0000 Subject: [PATCH 4/9] Fix ada change handling Improve tests to catch above --- src/BotPlutusInterface/Balance.hs | 90 +++++++++++++--- test/Spec/BotPlutusInterface/Contract.hs | 128 +++++++++++++---------- test/Spec/MockContract.hs | 13 ++- 3 files changed, 158 insertions(+), 73 deletions(-) diff --git a/src/BotPlutusInterface/Balance.hs b/src/BotPlutusInterface/Balance.hs index 2829b67a..b85379ef 100644 --- a/src/BotPlutusInterface/Balance.hs +++ b/src/BotPlutusInterface/Balance.hs @@ -86,17 +86,39 @@ balanceTxIO pabConf ownPkh unbalancedTx = preBalancedTx <- hoistEither $ addTxCollaterals utxoIndex tx >>= addSignatories ownPkh privKeys requiredSigs -- Balance the tx - balancedTx <- loop utxoIndex privKeys [] preBalancedTx + (balancedTx, minUtxos) <- loop utxoIndex privKeys [] preBalancedTx + + -- Check if we have Ada change + let adaChange = getAdaChange utxoIndex (lovelaceValue $ txFee balancedTx) balancedTx + -- If we have no change UTxO, but we do have change, we need to add an output for it + -- We'll add a minimal output, run the loop again so it gets minUTxO, then update change + balancedTxWithChange <- + if adaChange /= 0 && not (hasChangeUTxO ownPkh balancedTx) + then + let changeAddr = Ledger.pubKeyHashAddress (Ledger.PaymentPubKeyHash ownPkh) Nothing + changeTxOut = + TxOut + { txOutAddress = changeAddr + , txOutValue = Ada.lovelaceValueOf 1 + , txOutDatumHash = Nothing + } + preBalancedTxWithChange = balancedTx {txOutputs = changeTxOut : txOutputs balancedTx} + in fst <$> loop utxoIndex privKeys minUtxos preBalancedTxWithChange + else pure balancedTx + + -- Get the updated change, add it to the tx + let finalAdaChange = getAdaChange utxoIndex (lovelaceValue $ txFee balancedTxWithChange) balancedTxWithChange + fullyBalancedTx = addAdaChange ownPkh finalAdaChange balancedTxWithChange -- finally, we must update the signatories - hoistEither $ addSignatories ownPkh privKeys requiredSigs balancedTx + hoistEither $ addSignatories ownPkh privKeys requiredSigs fullyBalancedTx where loop :: Map TxOutRef TxOut -> Map PubKeyHash DummyPrivKey -> [(TxOut, Integer)] -> Tx -> - EitherT Text (Eff effs) Tx + EitherT Text (Eff effs) (Tx, [(TxOut, Integer)]) loop utxoIndex privKeys prevMinUtxos tx = do void $ lift $ Files.writeAll @w pabConf tx nextMinUtxos <- @@ -123,7 +145,7 @@ balanceTxIO pabConf ownPkh unbalancedTx = let balanceTxWithFees = balancedTx {txFee = Ada.lovelaceValueOf fees} if balanceTxWithFees == tx - then pure balanceTxWithFees + then pure (balanceTxWithFees, minUtxos) else loop utxoIndex privKeys minUtxos balanceTxWithFees calculateMinUtxos :: @@ -146,7 +168,26 @@ balanceTxStep :: balanceTxStep minUtxos fees utxos ownPkh tx = Right (addLovelaces minUtxos tx) >>= balanceTxIns utxos fees - >>= handleChange ownPkh utxos fees + >>= handleNonAdaChange ownPkh utxos fees + +-- | Get change value of a transaction, taking inputs, outputs, mint and fees into account +getChange :: Map TxOutRef TxOut -> Integer -> Tx -> Value +getChange utxos fees tx = + let txInRefs = map Tx.txInRef $ Set.toList $ txInputs tx + inputValue = mconcat $ map Tx.txOutValue $ mapMaybe (`Map.lookup` utxos) txInRefs + outputValue = mconcat $ map Tx.txOutValue $ txOutputs tx + nonMintedOutputValue = outputValue `minus` txMint tx + change = (inputValue `minus` nonMintedOutputValue) `minus` Ada.lovelaceValueOf fees + in change + +lovelaceValue :: Value -> Integer +lovelaceValue = flip Value.assetClassValueOf $ Value.assetClass "" "" + +getAdaChange :: Map TxOutRef TxOut -> Integer -> Tx -> Integer +getAdaChange utxos fees = lovelaceValue . getChange utxos fees + +getNonAdaChange :: Map TxOutRef TxOut -> Integer -> Tx -> Value +getNonAdaChange utxos fees = Ledger.noAdaValue . getChange utxos fees -- | Getting the necessary utxos to cover the fees for the transaction collectTxIns :: Set TxIn -> Map TxOutRef TxOut -> Value -> Either Text (Set TxIn) @@ -232,30 +273,45 @@ addTxCollaterals utxos tx = do _ -> Left "There are no utxos to be used as collateral" filterAdaOnly = Map.filter (isAdaOnly . txOutValue) --- | Ensures all change goes back to user -handleChange :: PubKeyHash -> Map TxOutRef TxOut -> Integer -> Tx -> Either Text Tx -handleChange ownPkh utxos fees tx = +-- | Ensures all non ada change goes back to user +handleNonAdaChange :: PubKeyHash -> Map TxOutRef TxOut -> Integer -> Tx -> Either Text Tx +handleNonAdaChange ownPkh utxos fees tx = let changeAddr = Ledger.pubKeyHashAddress (Ledger.PaymentPubKeyHash ownPkh) Nothing - txInRefs = map Tx.txInRef $ Set.toList $ txInputs tx - inputValue = mconcat $ map Tx.txOutValue $ mapMaybe (`Map.lookup` utxos) txInRefs - outputValue = mconcat $ map Tx.txOutValue $ txOutputs tx - nonMintedOutputValue = outputValue `minus` txMint tx - change = (inputValue `minus` nonMintedOutputValue) `minus` Ada.lovelaceValueOf fees + nonAdaChange = getNonAdaChange utxos fees tx outputs = case partition ((==) changeAddr . Tx.txOutAddress) $ txOutputs tx of ([], txOuts) -> TxOut { txOutAddress = changeAddr - , txOutValue = change + , txOutValue = nonAdaChange , txOutDatumHash = Nothing } : txOuts (txOut@TxOut {txOutValue = v} : txOuts, txOuts') -> - txOut {txOutValue = v <> change} : (txOuts <> txOuts') - in if isValueNat change - then Right $ if Value.isZero change then tx else tx {txOutputs = outputs} + txOut {txOutValue = v <> nonAdaChange} : (txOuts <> txOuts') + in if isValueNat nonAdaChange + then Right $ if Value.isZero nonAdaChange then tx else tx {txOutputs = outputs} else Left "Not enough inputs to balance tokens." +hasChangeUTxO :: PubKeyHash -> Tx -> Bool +hasChangeUTxO ownPkh tx = + any ((==) changeAddr . Tx.txOutAddress) $ txOutputs tx + where + changeAddr = Ledger.pubKeyHashAddress (Ledger.PaymentPubKeyHash ownPkh) Nothing + +-- | Adds ada change to a transaction, assuming there is already an output going to ownPkh. Otherwise, this is identity +addAdaChange :: PubKeyHash -> Integer -> Tx -> Tx +addAdaChange ownPkh change tx = + tx + { txOutputs = + case partition ((==) changeAddr . Tx.txOutAddress) $ txOutputs tx of + (txOut@TxOut {txOutValue = v} : txOuts, txOuts') -> + txOut {txOutValue = v <> Ada.lovelaceValueOf change} : (txOuts <> txOuts') + _ -> txOutputs tx + } + where + changeAddr = Ledger.pubKeyHashAddress (Ledger.PaymentPubKeyHash ownPkh) Nothing + {- | Add the required signatorioes to the transaction. Be aware the the signature itself is invalid, and will be ignored. Only the pub key hashes are used, mapped to signing key files on disk. -} diff --git a/test/Spec/BotPlutusInterface/Contract.hs b/test/Spec/BotPlutusInterface/Contract.hs index b52d280f..aa15af8e 100644 --- a/test/Spec/BotPlutusInterface/Contract.hs +++ b/test/Spec/BotPlutusInterface/Contract.hs @@ -79,6 +79,7 @@ tests = testGroup "BotPlutusInterface.Contracts" [ testCase "Send ada to address" sendAda + , testCase "Send ada to address without change" sendAdaNoChange , testCase "Send ada to address with staking key" sendAdaStaking , testCase "Support multiple signatories" multisigSupport , testCase "Create a tx without signing" withoutSigning @@ -96,7 +97,7 @@ tests = sendAda :: Assertion sendAda = do let txOutRef = TxOutRef "e406b0cf676fc2b1a9edb0617f259ad025c20ea6f0333820aa7cef1bfe7302e5" 0 - txOut = TxOut pkhAddr1 (Ada.lovelaceValueOf 1250) Nothing + txOut = TxOut pkhAddr1 (Ada.lovelaceValueOf 1350) Nothing initState = def & utxos .~ [(txOutRef, txOut)] inTxId = encodeByteString $ fromBuiltin $ TxId.getTxId $ Tx.txOutRefId txOutRef @@ -131,7 +132,6 @@ sendAda = do cardano-cli transaction build-raw --alonzo-era --tx-in ${inTxId}#0 --tx-in-collateral ${inTxId}#0 - --tx-out ${addr1}+250 --tx-out ${addr2}+1000 --required-signer ./signing-keys/signing-key-${pkh1'}.skey --fee 0 @@ -144,15 +144,15 @@ sendAda = do cardano-cli transaction calculate-min-fee --tx-body-file ./txs/tx-? --tx-in-count 1 - --tx-out-count 2 + --tx-out-count 1 --witness-count 1 --protocol-params-file ./protocol.json --mainnet |] ) - , -- Steps 4, 5 and 6 are near repeats of 1, 2 and 3, to ensure min utxo values are met + , -- Steps 4 to 11 are near repeats of 1, 2 and 3, to ensure min utxo values are met, and change is dispursed - ( 7 + ( 12 , [text| cardano-cli transaction build-raw --alonzo-era --tx-in ${inTxId}#0 @@ -160,12 +160,12 @@ sendAda = do --tx-out ${addr1}+50 --tx-out ${addr2}+1000 --required-signer ./signing-keys/signing-key-${pkh1'}.skey - --fee 200 + --fee 300 --protocol-params-file ./protocol.json --out-file ./txs/tx-${outTxId}.raw |] ) , - ( 8 + ( 13 , [text| cardano-cli transaction sign --tx-body-file ./txs/tx-${outTxId}.raw @@ -175,10 +175,40 @@ sendAda = do ) ] +sendAdaNoChange :: Assertion +sendAdaNoChange = do + let txOutRef = TxOutRef "e406b0cf676fc2b1a9edb0617f259ad025c20ea6f0333820aa7cef1bfe7302e5" 0 + txOut = TxOut pkhAddr1 (Ada.lovelaceValueOf 1200) Nothing + initState = def & utxos .~ [(txOutRef, txOut)] + inTxId = encodeByteString $ fromBuiltin $ TxId.getTxId $ Tx.txOutRefId txOutRef + + contract :: Contract () (Endpoint "SendAda" ()) Text CardanoTx + contract = do + let constraints = + Constraints.mustPayToPubKey paymentPkh2 (Ada.lovelaceValueOf 1000) + submitTx constraints + + assertContractWithTxId contract initState $ \state outTxId -> + assertCommandHistory + state + [ + ( 6 + , [text| + cardano-cli transaction build-raw --alonzo-era + --tx-in ${inTxId}#0 + --tx-in-collateral ${inTxId}#0 + --tx-out ${addr2}+1000 + --required-signer ./signing-keys/signing-key-${pkh1'}.skey + --fee 200 + --protocol-params-file ./protocol.json --out-file ./txs/tx-${outTxId}.raw + |] + ) + ] + sendAdaStaking :: Assertion sendAdaStaking = do let txOutRef = TxOutRef "e406b0cf676fc2b1a9edb0617f259ad025c20ea6f0333820aa7cef1bfe7302e5" 0 - txOut = TxOut pkhAddr1 (Ada.lovelaceValueOf 1250) Nothing + txOut = TxOut pkhAddr1 (Ada.lovelaceValueOf 1200) Nothing initState = def & utxos .~ [(txOutRef, txOut)] inTxId = encodeByteString $ fromBuiltin $ TxId.getTxId $ Tx.txOutRefId txOutRef @@ -216,7 +246,6 @@ sendAdaStaking = do cardano-cli transaction build-raw --alonzo-era --tx-in ${inTxId}#0 --tx-in-collateral ${inTxId}#0 - --tx-out ${addr1}+250 --tx-out ${addr2Staking}+1000 --required-signer ./signing-keys/signing-key-${pkh1'}.skey --fee 0 @@ -229,19 +258,18 @@ sendAdaStaking = do cardano-cli transaction calculate-min-fee --tx-body-file ./txs/tx-? --tx-in-count 1 - --tx-out-count 2 + --tx-out-count 1 --witness-count 1 --protocol-params-file ./protocol.json --mainnet |] ) , - ( 7 + ( 6 , [text| cardano-cli transaction build-raw --alonzo-era --tx-in ${inTxId}#0 --tx-in-collateral ${inTxId}#0 - --tx-out ${addr1}+50 --tx-out ${addr2Staking}+1000 --required-signer ./signing-keys/signing-key-${pkh1'}.skey --fee 200 @@ -249,7 +277,7 @@ sendAdaStaking = do |] ) , - ( 8 + ( 7 , [text| cardano-cli transaction sign --tx-body-file ./txs/tx-${outTxId}.raw @@ -262,7 +290,7 @@ sendAdaStaking = do multisigSupport :: Assertion multisigSupport = do let txOutRef = TxOutRef "e406b0cf676fc2b1a9edb0617f259ad025c20ea6f0333820aa7cef1bfe7302e5" 0 - txOut = TxOut pkhAddr1 (Ada.lovelaceValueOf 1250) Nothing + txOut = TxOut pkhAddr1 (Ada.lovelaceValueOf 1200) Nothing initState = def & utxos .~ [(txOutRef, txOut)] inTxId = encodeByteString $ fromBuiltin $ TxId.getTxId $ Tx.txOutRefId txOutRef @@ -283,19 +311,18 @@ multisigSupport = do cardano-cli transaction calculate-min-fee --tx-body-file ./txs/tx-? --tx-in-count 1 - --tx-out-count 2 + --tx-out-count 1 --witness-count 2 --protocol-params-file ./protocol.json --mainnet |] ) , - ( 7 + ( 6 , [text| cardano-cli transaction build-raw --alonzo-era --tx-in ${inTxId}#0 --tx-in-collateral ${inTxId}#0 - --tx-out ${addr1}+50 --tx-out ${addr2}+1000 --required-signer ./signing-keys/signing-key-${pkh1'}.skey --required-signer ./signing-keys/signing-key-${pkh3'}.skey @@ -304,7 +331,7 @@ multisigSupport = do |] ) , - ( 8 + ( 7 , [text| cardano-cli transaction sign --tx-body-file ./txs/tx-${outTxId}.raw @@ -318,7 +345,7 @@ multisigSupport = do withoutSigning :: Assertion withoutSigning = do let txOutRef = TxOutRef "e406b0cf676fc2b1a9edb0617f259ad025c20ea6f0333820aa7cef1bfe7302e5" 0 - txOut = TxOut pkhAddr1 (Ada.lovelaceValueOf 1250) Nothing + txOut = TxOut pkhAddr1 (Ada.lovelaceValueOf 1200) Nothing initState = def & utxos .~ [(txOutRef, txOut)] @@ -342,12 +369,11 @@ withoutSigning = do assertCommandHistory state [ - ( 7 + ( 6 , [text| cardano-cli transaction build-raw --alonzo-era --tx-in ${inTxId}#0 --tx-in-collateral ${inTxId}#0 - --tx-out ${addr1}+50 --tx-out ${addr2}+1000 --required-signer ./signing-keys/signing-key-${pkh1'}.skey --required-signer-hash ${pkh3'} @@ -364,7 +390,7 @@ sendTokens = do txOut1 = TxOut pkhAddr1 - (Ada.lovelaceValueOf 1300 <> Value.singleton "abcd1234" "testToken" 100) + (Ada.lovelaceValueOf 1350 <> Value.singleton "abcd1234" "testToken" 100) Nothing txOutRef2 = TxOutRef "e406b0cf676fc2b1a9edb0617f259ad025c20ea6f0333820aa7cef1bfe7302e5" 1 txOut2 = @@ -388,15 +414,15 @@ sendTokens = do assertCommandHistory state [ - ( 7 + ( 10 , [text| cardano-cli transaction build-raw --alonzo-era --tx-in ${inTxId1}#0 --tx-in-collateral ${inTxId2}#1 - --tx-out ${addr1}+100 + 95 abcd1234.74657374546F6B656E + --tx-out ${addr1}+50 + 95 abcd1234.74657374546F6B656E --tx-out ${addr2}+1000 + 5 abcd1234.74657374546F6B656E --required-signer ./signing-keys/signing-key-${pkh1'}.skey - --fee 200 + --fee 300 --protocol-params-file ./protocol.json --out-file ./txs/tx-${outTxId}.raw |] ) @@ -408,7 +434,7 @@ sendTokensWithoutName = do txOut1 = TxOut pkhAddr1 - (Ada.lovelaceValueOf 1300 <> Value.singleton "abcd1234" "" 100) + (Ada.lovelaceValueOf 1350 <> Value.singleton "abcd1234" "" 100) Nothing txOutRef2 = TxOutRef "e406b0cf676fc2b1a9edb0617f259ad025c20ea6f0333820aa7cef1bfe7302e5" 1 txOut2 = @@ -432,15 +458,15 @@ sendTokensWithoutName = do assertCommandHistory state [ - ( 7 + ( 10 , [text| cardano-cli transaction build-raw --alonzo-era --tx-in ${inTxId1}#0 --tx-in-collateral ${inTxId2}#1 - --tx-out ${addr1}+100 + 95 abcd1234 + --tx-out ${addr1}+50 + 95 abcd1234 --tx-out ${addr2}+1000 + 5 abcd1234 --required-signer ./signing-keys/signing-key-${pkh1'}.skey - --fee 200 + --fee 300 --protocol-params-file ./protocol.json --out-file ./txs/tx-${outTxId}.raw |] ) @@ -449,7 +475,7 @@ sendTokensWithoutName = do mintTokens :: Assertion mintTokens = do let txOutRef = TxOutRef "e406b0cf676fc2b1a9edb0617f259ad025c20ea6f0333820aa7cef1bfe7302e5" 0 - txOut = TxOut pkhAddr1 (Ada.lovelaceValueOf 1250) Nothing + txOut = TxOut pkhAddr1 (Ada.lovelaceValueOf 1200) Nothing initState = def & utxos .~ [(txOutRef, txOut)] inTxId = encodeByteString $ fromBuiltin $ TxId.getTxId $ Tx.txOutRefId txOutRef @@ -488,7 +514,6 @@ mintTokens = do cardano-cli transaction build-raw --alonzo-era --tx-in ${inTxId}#0 --tx-in-collateral ${inTxId}#0 - --tx-out ${addr1}+250 --tx-out ${addr2}+1000 + 5 ${curSymbol'}.74657374546F6B656E --mint-script-file ./result-scripts/policy-${curSymbol'}.plutus --mint-redeemer-file ./result-scripts/redeemer-${redeemerHash}.json @@ -497,15 +522,14 @@ mintTokens = do --required-signer ./signing-keys/signing-key-${pkh1'}.skey --fee 0 --protocol-params-file ./protocol.json --out-file ./txs/tx-? - |] + |] ) , - ( 7 + ( 6 , [text| cardano-cli transaction build-raw --alonzo-era --tx-in ${inTxId}#0 --tx-in-collateral ${inTxId}#0 - --tx-out ${addr1}+50 --tx-out ${addr2}+1000 + 5 ${curSymbol'}.74657374546F6B656E --mint-script-file ./result-scripts/policy-${curSymbol'}.plutus --mint-redeemer-file ./result-scripts/redeemer-${redeemerHash}.json @@ -583,25 +607,24 @@ spendToValidator = do cardano-cli transaction build-raw --alonzo-era --tx-in ${inTxId}#0 --tx-in-collateral ${inTxId}#0 - --tx-out ${addr1}+500 --tx-out ${valAddr'}+500 --tx-out-datum-embed-file ./result-scripts/datum-${datumHash'}.json --required-signer ./signing-keys/signing-key-${pkh1'}.skey --fee 0 --protocol-params-file ./protocol.json --out-file ./txs/tx-? - |] + |] ) , - ( 7 + ( 12 , [text| cardano-cli transaction build-raw --alonzo-era --tx-in ${inTxId}#0 --tx-in-collateral ${inTxId}#0 - --tx-out ${addr1}+300 + --tx-out ${addr1}+200 --tx-out ${valAddr'}+500 --tx-out-datum-embed-file ./result-scripts/datum-${datumHash'}.json --required-signer ./signing-keys/signing-key-${pkh1'}.skey - --fee 200 + --fee 300 --protocol-params-file ./protocol.json --out-file ./txs/tx-${outTxId}.raw |] ) @@ -679,14 +702,13 @@ redeemFromValidator = do --tx-in-redeemer-file ./result-scripts/redeemer-${redeemerHash}.json --tx-in-execution-units (387149,1400) --tx-in-collateral ${inTxId}#0 - --tx-out ${addr1}+750 --tx-out ${addr2}+500 --required-signer ./signing-keys/signing-key-${pkh1'}.skey --fee 0 --protocol-params-file ./protocol.json --out-file ./txs/tx-? - |] + |] ) , - ( 7 + ( 12 , [text| cardano-cli transaction build-raw --alonzo-era --tx-in ${inTxId}#1 @@ -695,10 +717,10 @@ redeemFromValidator = do --tx-in-redeemer-file ./result-scripts/redeemer-${redeemerHash}.json --tx-in-execution-units (387149,1400) --tx-in-collateral ${inTxId}#0 - --tx-out ${addr1}+550 + --tx-out ${addr1}+450 --tx-out ${addr2}+500 --required-signer ./signing-keys/signing-key-${pkh1'}.skey - --fee 200 + --fee 300 --protocol-params-file ./protocol.json --out-file ./txs/tx-${outTxId}.raw |] ) @@ -717,15 +739,15 @@ redeemFromValidator = do multiTx :: Assertion multiTx = do let txOutRef = TxOutRef "e406b0cf676fc2b1a9edb0617f259ad025c20ea6f0333820aa7cef1bfe7302e5" 0 - txOut = TxOut pkhAddr1 (Ada.lovelaceValueOf 1250) Nothing + txOut = TxOut pkhAddr1 (Ada.lovelaceValueOf 1200) Nothing initState = def & utxos .~ [(txOutRef, txOut)] contract :: Contract () (Endpoint "SendAda" ()) Text [CardanoTx] contract = do let constraints = - Constraints.mustPayToPubKey paymentPkh2 (Ada.lovelaceValueOf 1000) - tx1 <- submitTx constraints - tx2 <- submitTx constraints + Constraints.mustPayToPubKey paymentPkh2 . Ada.lovelaceValueOf + tx1 <- submitTx $ constraints 1000 + tx2 <- submitTx $ constraints 850 pure [tx1, tx2] @@ -749,7 +771,7 @@ multiTx = do withValidRange :: Assertion withValidRange = do let txOutRef = TxOutRef "e406b0cf676fc2b1a9edb0617f259ad025c20ea6f0333820aa7cef1bfe7302e5" 0 - txOut = TxOut pkhAddr1 (Ada.lovelaceValueOf 1250) Nothing + txOut = TxOut pkhAddr1 (Ada.lovelaceValueOf 1200) Nothing initState = def & utxos .~ [(txOutRef, txOut)] inTxId = encodeByteString $ fromBuiltin $ TxId.getTxId $ Tx.txOutRefId txOutRef @@ -769,7 +791,6 @@ withValidRange = do cardano-cli transaction build-raw --alonzo-era --tx-in ${inTxId}#0 --tx-in-collateral ${inTxId}#0 - --tx-out ${addr1}+250 --tx-out ${addr2}+1000 --invalid-before 47577202 --invalid-hereafter 50255602 @@ -779,26 +800,25 @@ withValidRange = do |] ) , - ( 7 + ( 6 , [text| cardano-cli transaction build-raw --alonzo-era --tx-in ${inTxId}#0 --tx-in-collateral ${inTxId}#0 - --tx-out ${addr1}+50 --tx-out ${addr2}+1000 --invalid-before 47577202 --invalid-hereafter 50255602 --required-signer ./signing-keys/signing-key-${pkh1'}.skey --fee 200 --protocol-params-file ./protocol.json --out-file ./txs/tx-${outTxId}.raw - |] + |] ) ] useWriter :: Assertion useWriter = do let txOutRef = TxOutRef "e406b0cf676fc2b1a9edb0617f259ad025c20ea6f0333820aa7cef1bfe7302e5" 0 - txOut = TxOut pkhAddr1 (Ada.lovelaceValueOf 1250) Nothing + txOut = TxOut pkhAddr1 (Ada.lovelaceValueOf 1200) Nothing initState = def & utxos .~ [(txOutRef, txOut)] contract :: Contract (Last Text) (Endpoint "SendAda" ()) Text CardanoTx diff --git a/test/Spec/MockContract.hs b/test/Spec/MockContract.hs index 0922b52a..ae808e64 100644 --- a/test/Spec/MockContract.hs +++ b/test/Spec/MockContract.hs @@ -72,6 +72,7 @@ import Cardano.Api ( ) import Cardano.Crypto.DSIGN (genKeyDSIGN) import Cardano.Crypto.Seed (mkSeedFromBytes) +import Control.Applicative (liftA2) import Control.Concurrent.STM (newTVarIO) import Control.Lens (at, (%~), (&), (<|), (?~), (^.), (^..), _1) import Control.Lens.TH (makeLenses) @@ -91,6 +92,7 @@ import Data.Kind (Type) import Data.List (isPrefixOf) import Data.Map (Map) import Data.Map qualified as Map +import Data.Maybe (fromMaybe) import Data.Row (Row) import Data.Set qualified as Set import Data.Text (Text) @@ -116,6 +118,7 @@ import Plutus.Contract.Effects (ChainIndexQuery (..), ChainIndexResponse (..)) import Plutus.PAB.Core.ContractInstance.STM (Activity (Active)) import PlutusTx.Builtins (fromBuiltin) import System.IO.Unsafe (unsafePerformIO) +import Text.Read (readMaybe) import Wallet.Types (ContractInstanceId (ContractInstanceId)) import Prelude @@ -314,8 +317,8 @@ mockCallCommand ShellArgs {cmdName, cmdArgs, cmdOutParser} = do Right . cmdOutParser <$> mockQueryUtxo addr ("cardano-cli", "transaction" : "calculate-min-required-utxo" : _) -> pure $ Right $ cmdOutParser "Lovelace 50" - ("cardano-cli", "transaction" : "calculate-min-fee" : _) -> - pure $ Right $ cmdOutParser "200 Lovelace" + ("cardano-cli", "transaction" : "calculate-min-fee" : rest) -> + pure $ Right $ cmdOutParser $ show (fromMaybe 0 $ toFee rest) ++ " Lovelace" ("cardano-cli", "transaction" : "build-raw" : args) -> do case drop 1 $ dropWhile (/= "--out-file") args of filepath : _ -> @@ -343,6 +346,12 @@ mockCallCommand ShellArgs {cmdName, cmdArgs, cmdOutParser} = do throwError @Text ("Unsupported command: " <> Text.intercalate " " (unsupportedCmd : unsupportedArgs)) +toFee :: [Text] -> Maybe Integer +toFee (_ : _ : _ : inCount : _ : outCount : _) = (100 *) <$> liftA2 (+) (textRead inCount) (textRead outCount) + where + textRead = readMaybe . Text.unpack +toFee _ = Nothing + mockQueryTip :: forall (w :: Type). MockContract w String mockQueryTip = do state <- get @(MockContractState w) From 4d59532b721616ba8c739c2e74cf9158001c04e6 Mon Sep 17 00:00:00 2001 From: Samuel Williams Date: Mon, 14 Feb 2022 23:32:25 +0000 Subject: [PATCH 5/9] Address comments --- src/BotPlutusInterface/Contract.hs | 8 ++++---- test/Spec/BotPlutusInterface/Contract.hs | 7 ++++--- 2 files changed, 8 insertions(+), 7 deletions(-) diff --git a/src/BotPlutusInterface/Contract.hs b/src/BotPlutusInterface/Contract.hs index 67dc9c10..b036eb31 100644 --- a/src/BotPlutusInterface/Contract.hs +++ b/src/BotPlutusInterface/Contract.hs @@ -135,7 +135,7 @@ handlePABReq contractEnv req = do ChainIndexQueryReq query -> ChainIndexQueryResp <$> queryChainIndex @w query BalanceTxReq unbalancedTx -> - BalanceTxResp <$> balanceTxStep @w contractEnv unbalancedTx + BalanceTxResp <$> balanceTx @w contractEnv unbalancedTx WriteBalancedTxReq tx -> WriteBalancedTxResp <$> writeBalancedTx @w contractEnv tx AwaitSlotReq s -> AwaitSlotResp <$> awaitSlot @w contractEnv s @@ -162,14 +162,14 @@ handlePABReq contractEnv req = do printLog @w Debug $ show resp pure resp --- | This is not identical to the real balancing, we only do a pre-balance at this stage -balanceTxStep :: +-- | This will FULLY balance a transaction +balanceTx :: forall (w :: Type) (effs :: [Type -> Type]). Member (PABEffect w) effs => ContractEnvironment w -> UnbalancedTx -> Eff effs BalanceTxResponse -balanceTxStep contractEnv unbalancedTx = do +balanceTx contractEnv unbalancedTx = do eitherPreBalancedTx <- PreBalance.balanceTxIO @w contractEnv.cePABConfig diff --git a/test/Spec/BotPlutusInterface/Contract.hs b/test/Spec/BotPlutusInterface/Contract.hs index aa15af8e..c08e7798 100644 --- a/test/Spec/BotPlutusInterface/Contract.hs +++ b/test/Spec/BotPlutusInterface/Contract.hs @@ -8,6 +8,7 @@ import Cardano.Api (NetworkId (Mainnet)) import Control.Lens (ix, (&), (.~), (^.), (^?)) import Data.Aeson (ToJSON) import Data.Aeson.Extras (encodeByteString) +import Data.Char (isSpace) import Data.Default (def) import Data.Function (on) import Data.Kind (Type) @@ -892,7 +893,7 @@ assertCommandHistory state = ( \(idx, expectedCmd) -> assertCommandEqual ("command at index " ++ show idx ++ " was incorrect:") - (Text.replace "\n" " " expectedCmd) + expectedCmd (fromMaybe "" $ state ^? commandHistory . ix idx) ) @@ -908,8 +909,8 @@ commandEqual _ "" = False commandEqual expected actual = maybe False (on commandEqual dropToSpace postExp) mPostAct where (preExp, postExp) = Text.breakOn "?" expected - mPostAct = Text.stripPrefix preExp actual - dropToSpace = Text.dropWhile (/= ' ') + mPostAct = Text.stripPrefix (Text.replace "\n" " " preExp) actual + dropToSpace = Text.dropWhile (not . isSpace) assertCommandCalled :: forall (w :: Type). MockContractState w -> Text -> Assertion assertCommandCalled state expectedCmd = From d4cc01bc17682ec3853775cdf0fced11e7c25d41 Mon Sep 17 00:00:00 2001 From: Samuel Williams Date: Tue, 15 Feb 2022 11:59:59 +0000 Subject: [PATCH 6/9] Add comment --- test/Spec/BotPlutusInterface/Contract.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/test/Spec/BotPlutusInterface/Contract.hs b/test/Spec/BotPlutusInterface/Contract.hs index c08e7798..0967eb3c 100644 --- a/test/Spec/BotPlutusInterface/Contract.hs +++ b/test/Spec/BotPlutusInterface/Contract.hs @@ -897,11 +897,15 @@ assertCommandHistory state = (fromMaybe "" $ state ^? commandHistory . ix idx) ) +-- | assertEqual but using `commandEqual` assertCommandEqual :: String -> Text -> Text -> Assertion assertCommandEqual err expected actual | commandEqual expected actual = return () | otherwise = assertFailure $ err ++ "\nExpected:\n" ++ show expected ++ "\nGot:\n" ++ show actual +-- | Checks if a command matches an expected command pattern +-- Where a command pattern may use new lines in place of spaces, and use the wildcard `?` to match up to the next space +-- E.g. `commandEqual "123\n456 ? 0" "123 456 789 0"` == `True` commandEqual :: Text -> Text -> Bool commandEqual "" "" = True commandEqual "" _ = False From d9e762c71e8d507c2f6d6fa5c4cf3e5e645e05c2 Mon Sep 17 00:00:00 2001 From: Samuel Williams Date: Tue, 15 Feb 2022 12:09:35 +0000 Subject: [PATCH 7/9] Formatting --- test/Spec/BotPlutusInterface/Contract.hs | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/test/Spec/BotPlutusInterface/Contract.hs b/test/Spec/BotPlutusInterface/Contract.hs index 0967eb3c..42e3fdce 100644 --- a/test/Spec/BotPlutusInterface/Contract.hs +++ b/test/Spec/BotPlutusInterface/Contract.hs @@ -903,9 +903,10 @@ assertCommandEqual err expected actual | commandEqual expected actual = return () | otherwise = assertFailure $ err ++ "\nExpected:\n" ++ show expected ++ "\nGot:\n" ++ show actual --- | Checks if a command matches an expected command pattern --- Where a command pattern may use new lines in place of spaces, and use the wildcard `?` to match up to the next space --- E.g. `commandEqual "123\n456 ? 0" "123 456 789 0"` == `True` +{- | Checks if a command matches an expected command pattern + Where a command pattern may use new lines in place of spaces, and use the wildcard `?` to match up to the next space + E.g. `commandEqual "123\n456 ? 0" "123 456 789 0"` == `True` +-} commandEqual :: Text -> Text -> Bool commandEqual "" "" = True commandEqual "" _ = False From 34017c2404696d52069003fb2b7d21a0877890ad Mon Sep 17 00:00:00 2001 From: Samuel Williams Date: Wed, 16 Feb 2022 13:05:27 +0000 Subject: [PATCH 8/9] Add fee to transaction over separate argument --- src/BotPlutusInterface/Balance.hs | 52 +++++++++++++------------ test/Spec.hs | 2 +- test/Spec/BotPlutusInterface/Balance.hs | 16 ++++---- 3 files changed, 35 insertions(+), 35 deletions(-) diff --git a/src/BotPlutusInterface/Balance.hs b/src/BotPlutusInterface/Balance.hs index b85379ef..33366d9b 100644 --- a/src/BotPlutusInterface/Balance.hs +++ b/src/BotPlutusInterface/Balance.hs @@ -3,6 +3,7 @@ module BotPlutusInterface.Balance ( balanceTxStep, balanceTxIO, + withFee, ) where import BotPlutusInterface.CardanoCLI qualified as CardanoCLI @@ -89,7 +90,7 @@ balanceTxIO pabConf ownPkh unbalancedTx = (balancedTx, minUtxos) <- loop utxoIndex privKeys [] preBalancedTx -- Check if we have Ada change - let adaChange = getAdaChange utxoIndex (lovelaceValue $ txFee balancedTx) balancedTx + let adaChange = getAdaChange utxoIndex balancedTx -- If we have no change UTxO, but we do have change, we need to add an output for it -- We'll add a minimal output, run the loop again so it gets minUTxO, then update change balancedTxWithChange <- @@ -107,7 +108,7 @@ balanceTxIO pabConf ownPkh unbalancedTx = else pure balancedTx -- Get the updated change, add it to the tx - let finalAdaChange = getAdaChange utxoIndex (lovelaceValue $ txFee balancedTxWithChange) balancedTxWithChange + let finalAdaChange = getAdaChange utxoIndex balancedTxWithChange fullyBalancedTx = addAdaChange ownPkh finalAdaChange balancedTxWithChange -- finally, we must update the signatories @@ -131,7 +132,7 @@ balanceTxIO pabConf ownPkh unbalancedTx = -- Calculate fees by pre-balancing the tx, building it, and running the CLI on result txWithoutFees <- - hoistEither $ balanceTxStep minUtxos 0 utxoIndex ownPkh tx + hoistEither $ balanceTxStep minUtxos utxoIndex ownPkh $ tx `withFee` 0 lift $ createDirectoryIfMissing @w False (Text.unpack pabConf.pcTxFileDir) newEitherT $ CardanoCLI.buildTx @w pabConf privKeys txWithoutFees @@ -140,13 +141,14 @@ balanceTxIO pabConf ownPkh unbalancedTx = lift $ printLog @w Debug $ "Fees: " ++ show fees -- Rebalance the initial tx with the above fees - balancedTx <- hoistEither $ balanceTxStep minUtxos fees utxoIndex ownPkh tx + balancedTx <- hoistEither $ balanceTxStep minUtxos utxoIndex ownPkh $ tx `withFee` fees - let balanceTxWithFees = balancedTx {txFee = Ada.lovelaceValueOf fees} + if balancedTx == tx + then pure (balancedTx, minUtxos) + else loop utxoIndex privKeys minUtxos balancedTx - if balanceTxWithFees == tx - then pure (balanceTxWithFees, minUtxos) - else loop utxoIndex privKeys minUtxos balanceTxWithFees +withFee :: Tx -> Integer -> Tx +withFee tx fee = tx {txFee = Ada.lovelaceValueOf fee} calculateMinUtxos :: forall (w :: Type) (effs :: [Type -> Type]). @@ -160,20 +162,20 @@ calculateMinUtxos pabConf datums txOuts = balanceTxStep :: [(TxOut, Integer)] -> - Integer -> Map TxOutRef TxOut -> PubKeyHash -> Tx -> Either Text Tx -balanceTxStep minUtxos fees utxos ownPkh tx = +balanceTxStep minUtxos utxos ownPkh tx = Right (addLovelaces minUtxos tx) - >>= balanceTxIns utxos fees - >>= handleNonAdaChange ownPkh utxos fees + >>= balanceTxIns utxos + >>= handleNonAdaChange ownPkh utxos -- | Get change value of a transaction, taking inputs, outputs, mint and fees into account -getChange :: Map TxOutRef TxOut -> Integer -> Tx -> Value -getChange utxos fees tx = - let txInRefs = map Tx.txInRef $ Set.toList $ txInputs tx +getChange :: Map TxOutRef TxOut -> Tx -> Value +getChange utxos tx = + let fees = lovelaceValue $ txFee tx + txInRefs = map Tx.txInRef $ Set.toList $ txInputs tx inputValue = mconcat $ map Tx.txOutValue $ mapMaybe (`Map.lookup` utxos) txInRefs outputValue = mconcat $ map Tx.txOutValue $ txOutputs tx nonMintedOutputValue = outputValue `minus` txMint tx @@ -183,11 +185,11 @@ getChange utxos fees tx = lovelaceValue :: Value -> Integer lovelaceValue = flip Value.assetClassValueOf $ Value.assetClass "" "" -getAdaChange :: Map TxOutRef TxOut -> Integer -> Tx -> Integer -getAdaChange utxos fees = lovelaceValue . getChange utxos fees +getAdaChange :: Map TxOutRef TxOut -> Tx -> Integer +getAdaChange utxos = lovelaceValue . getChange utxos -getNonAdaChange :: Map TxOutRef TxOut -> Integer -> Tx -> Value -getNonAdaChange utxos fees = Ledger.noAdaValue . getChange utxos fees +getNonAdaChange :: Map TxOutRef TxOut -> Tx -> Value +getNonAdaChange utxos = Ledger.noAdaValue . getChange utxos -- | Getting the necessary utxos to cover the fees for the transaction collectTxIns :: Set TxIn -> Map TxOutRef TxOut -> Value -> Either Text (Set TxIn) @@ -245,13 +247,13 @@ addLovelaces minLovelaces tx = $ txOutputs tx in tx {txOutputs = lovelacesAdded} -balanceTxIns :: Map TxOutRef TxOut -> Integer -> Tx -> Either Text Tx -balanceTxIns utxos fees tx = do +balanceTxIns :: Map TxOutRef TxOut -> Tx -> Either Text Tx +balanceTxIns utxos tx = do let txOuts = Tx.txOutputs tx nonMintedValue = mconcat (map Tx.txOutValue txOuts) `minus` txMint tx minSpending = mconcat - [ Ada.lovelaceValueOf fees + [ txFee tx , nonMintedValue ] txIns <- collectTxIns (txInputs tx) utxos minSpending @@ -274,10 +276,10 @@ addTxCollaterals utxos tx = do filterAdaOnly = Map.filter (isAdaOnly . txOutValue) -- | Ensures all non ada change goes back to user -handleNonAdaChange :: PubKeyHash -> Map TxOutRef TxOut -> Integer -> Tx -> Either Text Tx -handleNonAdaChange ownPkh utxos fees tx = +handleNonAdaChange :: PubKeyHash -> Map TxOutRef TxOut -> Tx -> Either Text Tx +handleNonAdaChange ownPkh utxos tx = let changeAddr = Ledger.pubKeyHashAddress (Ledger.PaymentPubKeyHash ownPkh) Nothing - nonAdaChange = getNonAdaChange utxos fees tx + nonAdaChange = getNonAdaChange utxos tx outputs = case partition ((==) changeAddr . Tx.txOutAddress) $ txOutputs tx of ([], txOuts) -> diff --git a/test/Spec.hs b/test/Spec.hs index 98f38791..28837cd5 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,8 +1,8 @@ module Main (main) where import Spec.BotPlutusInterface.Balance qualified -import Spec.BotPlutusInterface.Server qualified import Spec.BotPlutusInterface.Contract qualified +import Spec.BotPlutusInterface.Server qualified import Spec.BotPlutusInterface.UtxoParser qualified import Test.Tasty (TestTree, defaultMain, testGroup) import Prelude diff --git a/test/Spec/BotPlutusInterface/Balance.hs b/test/Spec/BotPlutusInterface/Balance.hs index 81540bb2..e849589f 100644 --- a/test/Spec/BotPlutusInterface/Balance.hs +++ b/test/Spec/BotPlutusInterface/Balance.hs @@ -1,5 +1,6 @@ module Spec.BotPlutusInterface.Balance (tests) where +import BotPlutusInterface.Balance (withFee) import BotPlutusInterface.Balance qualified as Balance import Data.Map qualified as Map import Data.Set qualified as Set @@ -57,38 +58,35 @@ utxo4 = (txOutRef4, TxOut addr1 (Ada.lovelaceValueOf 800_000 <> Value.singleton addUtxosForFees :: Assertion addUtxosForFees = do let txout = TxOut addr2 (Ada.lovelaceValueOf 1_000_000) Nothing - tx = mempty {txOutputs = [txout]} + tx = mempty {txOutputs = [txout]} `withFee` 500_000 minUtxo = [(txout, 1_000_000)] - fees = 500_000 utxoIndex = Map.fromList [utxo1, utxo2, utxo3] ownPkh = pkh1 balancedTx = - Balance.balanceTxStep minUtxo fees utxoIndex ownPkh tx + Balance.balanceTxStep minUtxo utxoIndex ownPkh tx txInputs <$> balancedTx @?= Right (Set.fromList [txIn1, txIn2]) addUtxosForNativeTokens :: Assertion addUtxosForNativeTokens = do let txout = TxOut addr2 (Value.singleton "11223344" "Token" 123) Nothing - tx = mempty {txOutputs = [txout]} + tx = mempty {txOutputs = [txout]} `withFee` 500_000 minUtxo = [(txout, 1_000_000)] - fees = 500_000 utxoIndex = Map.fromList [utxo1, utxo2, utxo3, utxo4] ownPkh = pkh1 balancedTx = - Balance.balanceTxStep minUtxo fees utxoIndex ownPkh tx + Balance.balanceTxStep minUtxo utxoIndex ownPkh tx txInputs <$> balancedTx @?= Right (Set.fromList [txIn1, txIn2, txIn3, txIn4]) addUtxosForChange :: Assertion addUtxosForChange = do let txout = TxOut addr2 (Ada.lovelaceValueOf 1_600_000) Nothing - tx = mempty {txOutputs = [txout]} + tx = mempty {txOutputs = [txout]} `withFee` 500_000 minUtxo = [(txout, 1_000_000)] - fees = 500_000 utxoIndex = Map.fromList [utxo1, utxo2, utxo3] ownPkh = pkh1 balancedTx = - Balance.balanceTxStep minUtxo fees utxoIndex ownPkh tx + Balance.balanceTxStep minUtxo utxoIndex ownPkh tx txInputs <$> balancedTx @?= Right (Set.fromList [txIn1, txIn2]) From 267f9afe151572053905c442f4522480c9a00538 Mon Sep 17 00:00:00 2001 From: Samuel Williams Date: Wed, 16 Feb 2022 13:19:55 +0000 Subject: [PATCH 9/9] Slight refactor --- src/BotPlutusInterface/Balance.hs | 27 +++++++++++++++------------ 1 file changed, 15 insertions(+), 12 deletions(-) diff --git a/src/BotPlutusInterface/Balance.hs b/src/BotPlutusInterface/Balance.hs index 33366d9b..744202b5 100644 --- a/src/BotPlutusInterface/Balance.hs +++ b/src/BotPlutusInterface/Balance.hs @@ -89,22 +89,13 @@ balanceTxIO pabConf ownPkh unbalancedTx = -- Balance the tx (balancedTx, minUtxos) <- loop utxoIndex privKeys [] preBalancedTx - -- Check if we have Ada change + -- Get current Ada change let adaChange = getAdaChange utxoIndex balancedTx - -- If we have no change UTxO, but we do have change, we need to add an output for it + -- If we have change but no change UTxO, we need to add an output for it -- We'll add a minimal output, run the loop again so it gets minUTxO, then update change balancedTxWithChange <- if adaChange /= 0 && not (hasChangeUTxO ownPkh balancedTx) - then - let changeAddr = Ledger.pubKeyHashAddress (Ledger.PaymentPubKeyHash ownPkh) Nothing - changeTxOut = - TxOut - { txOutAddress = changeAddr - , txOutValue = Ada.lovelaceValueOf 1 - , txOutDatumHash = Nothing - } - preBalancedTxWithChange = balancedTx {txOutputs = changeTxOut : txOutputs balancedTx} - in fst <$> loop utxoIndex privKeys minUtxos preBalancedTxWithChange + then fst <$> loop utxoIndex privKeys minUtxos (addOutput ownPkh balancedTx) else pure balancedTx -- Get the updated change, add it to the tx @@ -314,6 +305,18 @@ addAdaChange ownPkh change tx = where changeAddr = Ledger.pubKeyHashAddress (Ledger.PaymentPubKeyHash ownPkh) Nothing +-- | Adds a 1 lovelace output to a transaction +addOutput :: PubKeyHash -> Tx -> Tx +addOutput ownPkh tx = tx {txOutputs = changeTxOut : txOutputs tx} + where + changeAddr = Ledger.pubKeyHashAddress (Ledger.PaymentPubKeyHash ownPkh) Nothing + changeTxOut = + TxOut + { txOutAddress = changeAddr + , txOutValue = Ada.lovelaceValueOf 1 + , txOutDatumHash = Nothing + } + {- | Add the required signatorioes to the transaction. Be aware the the signature itself is invalid, and will be ignored. Only the pub key hashes are used, mapped to signing key files on disk. -}