Merge pull request #129 from mlabs-haskell/gergely/add-missing-effects

Add missing effects

Author: szg251

bot-plutus-interface.cabal

@@ -217,6 +217,7 @@ test-suite bot-plutus-interface-test
     , plutus-script-utils
     , plutus-tx
     , plutus-tx-plugin
+    , pretty-diff
     , prettyprinter
     , QuickCheck
     , quickcheck-instances

flake.lock

@@ -7,6 +7,7 @@ module BotPlutusInterface.Balance (
   withFee,
 ) where
 
+import BotPlutusInterface.BodyBuilder qualified as BodyBuilder
 import BotPlutusInterface.CardanoCLI qualified as CardanoCLI
 import BotPlutusInterface.Effects (
   PABEffect,
@@ -19,14 +20,14 @@ import BotPlutusInterface.Files qualified as Files
 import BotPlutusInterface.Types (LogLevel (Debug), PABConfig)
 import Cardano.Api (ExecutionUnitPrices (ExecutionUnitPrices))
 import Cardano.Api.Shelley (ProtocolParameters (protocolParamPrices))
-import Control.Monad (foldM, void, zipWithM)
+import Control.Monad (foldM, void)
 import Control.Monad.Freer (Eff, Member)
 import Control.Monad.Trans.Class (lift)
 import Control.Monad.Trans.Either (EitherT, hoistEither, newEitherT, runEitherT)
+import Data.Bifunctor (bimap)
 import Data.Coerce (coerce)
 import Data.Either.Combinators (rightToMaybe)
 import Data.Kind (Type)
-import Data.List ((\\))
 import Data.Map (Map)
 import Data.Map qualified as Map
 import Data.Maybe (fromMaybe, mapMaybe)
@@ -46,7 +47,6 @@ import Ledger.Interval (
   LowerBound (LowerBound),
   UpperBound (UpperBound),
  )
-import Ledger.Scripts (Datum, DatumHash)
 import Ledger.Time (POSIXTimeRange)
 import Ledger.Tx (
   Tx (..),
@@ -63,9 +63,6 @@ import Plutus.V1.Ledger.Api (
   CurrencySymbol (..),
   TokenName (..),
  )
-
-import BotPlutusInterface.BodyBuilder qualified as BodyBuilder
-import Data.Bifunctor (bimap)
 import Prettyprinter (pretty, viaShow, (<+>))
 import Prelude
 
@@ -103,15 +100,15 @@ balanceTxIO pabConf ownPkh unbalancedTx =
       preBalancedTx <- hoistEither $ addTxCollaterals utxoIndex tx >>= addSignatories ownPkh privKeys requiredSigs
 
       -- Balance the tx
-      (balancedTx, minUtxos) <- loop utxoIndex privKeys [] preBalancedTx
+      balancedTx <- loop utxoIndex privKeys preBalancedTx
 
       -- Get current Ada change
       let adaChange = getAdaChange utxoIndex balancedTx
       -- 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 changeAddr balancedTx)
-          then fst <$> loop utxoIndex privKeys minUtxos (addOutput changeAddr balancedTx)
+          then loop utxoIndex privKeys (addOutput changeAddr balancedTx)
           else pure balancedTx
 
       -- Get the updated change, add it to the tx
@@ -122,26 +119,18 @@ balanceTxIO pabConf ownPkh unbalancedTx =
       hoistEither $ addSignatories ownPkh privKeys requiredSigs fullyBalancedTx
   where
     changeAddr :: Address
-    changeAddr = Ledger.pubKeyHashAddress (Ledger.PaymentPubKeyHash ownPkh) (pabConf.pcOwnStakePubKeyHash)
+    changeAddr = Ledger.pubKeyHashAddress (Ledger.PaymentPubKeyHash ownPkh) pabConf.pcOwnStakePubKeyHash
     loop ::
       Map TxOutRef TxOut ->
       Map PubKeyHash DummyPrivKey ->
-      [(TxOut, Integer)] ->
       Tx ->
-      EitherT Text (Eff effs) (Tx, [(TxOut, Integer)])
-    loop utxoIndex privKeys prevMinUtxos tx = do
+      EitherT Text (Eff effs) Tx
+    loop utxoIndex privKeys tx = do
       void $ lift $ Files.writeAll @w pabConf tx
-      nextMinUtxos <-
-        newEitherT $
-          calculateMinUtxos @w pabConf (Tx.txData tx) $ Tx.txOutputs tx \\ map fst prevMinUtxos
-
-      let minUtxos = prevMinUtxos ++ nextMinUtxos
-
-      lift $ printBpiLog @w Debug $ "Min utxos:" <+> pretty minUtxos
 
       -- Calculate fees by pre-balancing the tx, building it, and running the CLI on result
       txWithoutFees <-
-        hoistEither $ balanceTxStep minUtxos utxoIndex changeAddr $ tx `withFee` 0
+        hoistEither $ balanceTxStep utxoIndex changeAddr $ tx `withFee` 0
 
       exBudget <- newEitherT $ BodyBuilder.buildAndEstimateBudget @w pabConf privKeys txWithoutFees
 
@@ -152,11 +141,11 @@ balanceTxIO pabConf ownPkh unbalancedTx =
       lift $ printBpiLog @w Debug $ "Fees:" <+> pretty fees
 
       -- Rebalance the initial tx with the above fees
-      balancedTx <- hoistEither $ balanceTxStep minUtxos utxoIndex changeAddr $ tx `withFee` fees
+      balancedTx <- hoistEither $ balanceTxStep utxoIndex changeAddr $ tx `withFee` fees
 
       if balancedTx == tx
-        then pure (balancedTx, minUtxos)
-        else loop utxoIndex privKeys minUtxos balancedTx
+        then pure balancedTx
+        else loop utxoIndex privKeys balancedTx
 
 getExecutionUnitPrices :: PABConfig -> ExecutionUnitPrices
 getExecutionUnitPrices pabConf =
@@ -176,24 +165,13 @@ multRational (num :% denom) s = (s * num) :% denom
 withFee :: Tx -> Integer -> Tx
 withFee tx fee = tx {txFee = Ada.lovelaceValueOf fee}
 
-calculateMinUtxos ::
-  forall (w :: Type) (effs :: [Type -> Type]).
-  Member (PABEffect w) effs =>
-  PABConfig ->
-  Map DatumHash Datum ->
-  [TxOut] ->
-  Eff effs (Either Text [(TxOut, Integer)])
-calculateMinUtxos pabConf datums txOuts =
-  zipWithM (fmap . (,)) txOuts <$> mapM (CardanoCLI.calculateMinUtxo @w pabConf datums) txOuts
-
 balanceTxStep ::
-  [(TxOut, Integer)] ->
   Map TxOutRef TxOut ->
   Address ->
   Tx ->
   Either Text Tx
-balanceTxStep minUtxos utxos changeAddr tx =
-  Right (addLovelaces minUtxos tx)
+balanceTxStep utxos changeAddr tx =
+  Right tx
     >>= balanceTxIns utxos
     >>= handleNonAdaChange changeAddr utxos
 
@@ -256,23 +234,6 @@ txOutToTxIn (txOutRef, txOut) =
     PubKeyCredential _ -> Right $ Tx.pubKeyTxIn txOutRef
     ScriptCredential _ -> Left "Cannot covert a script output to TxIn"
 
--- | Add min lovelaces to each tx output
-addLovelaces :: [(TxOut, Integer)] -> Tx -> Tx
-addLovelaces minLovelaces tx =
-  let lovelacesAdded =
-        map
-          ( \txOut ->
-              let outValue = txOutValue txOut
-                  lovelaces = Ada.getLovelace $ Ada.fromValue outValue
-                  minUtxo = fromMaybe 0 $ lookup txOut minLovelaces
-               in txOut
-                    { txOutValue =
-                        outValue <> Ada.lovelaceValueOf (max 0 (minUtxo - lovelaces))
-                    }
-          )
-          $ txOutputs tx
-   in tx {txOutputs = lovelacesAdded}
-
 balanceTxIns :: Map TxOutRef TxOut -> Tx -> Either Text Tx
 balanceTxIns utxos tx = do
   let txOuts = Tx.txOutputs tx

src/BotPlutusInterface/Balance.hs

@@ -3,7 +3,6 @@
 
 module BotPlutusInterface.CardanoCLI (
   submitTx,
-  calculateMinUtxo,
   calculateMinFee,
   buildTx,
   signTx,
@@ -124,27 +123,6 @@ utxosAt pabConf address =
             . Text.pack
       }
 
-calculateMinUtxo ::
-  forall (w :: Type) (effs :: [Type -> Type]).
-  Member (PABEffect w) effs =>
-  PABConfig ->
-  Map DatumHash Datum ->
-  TxOut ->
-  Eff effs (Either Text Integer)
-calculateMinUtxo pabConf datums txOut =
-  join
-    <$> callCommand @w
-      ShellArgs
-        { cmdName = "cardano-cli"
-        , cmdArgs =
-            mconcat
-              [ ["transaction", "calculate-min-required-utxo", "--babbage-era"]
-              , txOutOpts pabConf datums [txOut]
-              , ["--protocol-params-file", pabConf.pcProtocolParamsFile]
-              ]
-        , cmdOutParser = mapLeft Text.pack . parseOnly UtxoParser.feeParser . Text.pack
-        }
-
 -- | Calculating fee for an unbalanced transaction
 calculateMinFee ::
   forall (w :: Type) (effs :: [Type -> Type]).

src/BotPlutusInterface/CardanoCLI.hs

@@ -56,8 +56,10 @@ import Data.Vector qualified as V
 import Ledger (POSIXTime)
 import Ledger qualified
 import Ledger.Address (PaymentPubKeyHash (PaymentPubKeyHash))
-import Ledger.Constraints.OffChain (UnbalancedTx (..))
+import Ledger.Constraints.OffChain (UnbalancedTx (..), adjustUnbalancedTx)
+import Ledger.Params (Params (Params))
 import Ledger.Slot (Slot (Slot))
+import Ledger.TimeSlot (SlotConfig (..))
 import Ledger.Tx (CardanoTx (CardanoApiTx, EmulatorTx))
 import Ledger.Tx qualified as Tx
 import Plutus.ChainIndex.TxIdState (fromTx, transactionStatus)
@@ -189,20 +191,32 @@ handlePABReq contractEnv req = do
       either (error . show) (PosixTimeRangeToContainedSlotRangeResp . Right)
         <$> posixTimeRangeToContainedSlotRange @w posixTimeRange
     AwaitTxStatusChangeReq txId -> AwaitTxStatusChangeResp txId <$> awaitTxStatusChange @w contractEnv txId
+    AdjustUnbalancedTxReq unbalancedTx -> AdjustUnbalancedTxResp <$> adjustUnbalancedTx' @w contractEnv unbalancedTx
     ------------------------
     -- Unhandled requests --
     ------------------------
-    -- AwaitTimeReq t -> pure $ AwaitTimeResp t
-    -- AwaitUtxoSpentReq txOutRef -> pure $ AwaitUtxoSpentResp ChainIndexTx
-    -- AwaitUtxoProducedReq Address -> pure $ AwaitUtxoProducedResp (NonEmpty ChainIndexTx)
-    -- AwaitTxOutStatusChangeReq TxOutRef
-    -- ExposeEndpointReq ActiveEndpoint -> ExposeEndpointResp EndpointDescription (EndpointValue JSON.Value)
-    -- YieldUnbalancedTxReq UnbalancedTx
-    unsupported -> error ("Unsupported PAB effect: " ++ show unsupported)
+    AwaitUtxoSpentReq _ -> error ("Unsupported PAB effect: " ++ show req)
+    AwaitUtxoProducedReq _ -> error ("Unsupported PAB effect: " ++ show req)
+    AwaitTxOutStatusChangeReq _ -> error ("Unsupported PAB effect: " ++ show req)
+    ExposeEndpointReq _ -> error ("Unsupported PAB effect: " ++ show req)
+    YieldUnbalancedTxReq _ -> error ("Unsupported PAB effect: " ++ show req)
 
   printBpiLog @w Debug $ pretty resp
   pure resp
 
+adjustUnbalancedTx' ::
+  forall (w :: Type) (effs :: [Type -> Type]).
+  ContractEnvironment w ->
+  UnbalancedTx ->
+  Eff effs (Either Tx.ToCardanoError UnbalancedTx)
+adjustUnbalancedTx' contractEnv unbalancedTx = do
+  let slotConfig = SlotConfig 20000 1654524000
+      networkId = contractEnv.cePABConfig.pcNetwork
+      maybeParams = contractEnv.cePABConfig.pcProtocolParams >>= \pparams -> pure $ Params slotConfig pparams networkId
+  case maybeParams of
+    Just params -> pure $ snd <$> adjustUnbalancedTx params unbalancedTx
+    _ -> pure . Left $ Tx.TxBodyError "no protocol params"
+
 {- | Await till transaction status change to something from `Unknown`.
  Uses `chain-index` to query transaction by id.
  Important notes:

src/BotPlutusInterface/Contract.hs

@@ -59,34 +59,31 @@ addUtxosForFees :: Assertion
 addUtxosForFees = do
   let txout = TxOut addr2 (Ada.lovelaceValueOf 1_000_000) Nothing
       tx = mempty {txOutputs = [txout]} `withFee` 500_000
-      minUtxo = [(txout, 1_000_000)]
       utxoIndex = Map.fromList [utxo1, utxo2, utxo3]
       ownAddr = addr1
       balancedTx =
-        Balance.balanceTxStep minUtxo utxoIndex ownAddr tx
+        Balance.balanceTxStep utxoIndex ownAddr 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]} `withFee` 500_000
-      minUtxo = [(txout, 1_000_000)]
       utxoIndex = Map.fromList [utxo1, utxo2, utxo3, utxo4]
       ownAddr = addr1
       balancedTx =
-        Balance.balanceTxStep minUtxo utxoIndex ownAddr tx
+        Balance.balanceTxStep utxoIndex ownAddr 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]} `withFee` 500_000
-      minUtxo = [(txout, 1_000_000)]
       utxoIndex = Map.fromList [utxo1, utxo2, utxo3]
       ownAddr = addr1
       balancedTx =
-        Balance.balanceTxStep minUtxo utxoIndex ownAddr tx
+        Balance.balanceTxStep utxoIndex ownAddr tx
 
   txInputs <$> balancedTx @?= Right (Set.fromList [txIn1, txIn2])