Merge pull request #139 from mlabs-haskell/vasil-adjust-tx-ench

Intermediate PR to Babbagize adjustUnbalancedTx

Author: mikekeke

bot-plutus-interface.cabal

@@ -106,6 +106,7 @@ library
     , cardano-crypto
     , cardano-ledger-alonzo
     , cardano-ledger-core
+    , cardano-ledger-shelley
     , cardano-prelude
     , cardano-slotting
     , config-schema
@@ -173,6 +174,7 @@ test-suite bot-plutus-interface-test
   main-is:        Spec.hs
   ghc-options:    -fplugin-opt PlutusTx.Plugin:defer-errors
   other-modules:
+    Spec.BotPlutusInterface.AdjustUnbalanced
     Spec.BotPlutusInterface.Balance
     Spec.BotPlutusInterface.Config
     Spec.BotPlutusInterface.Contract

src/BotPlutusInterface/Contract.hs

@@ -34,8 +34,19 @@ import BotPlutusInterface.Types (
   Tip (block, slot),
   TxFile (Signed),
  )
-import Cardano.Api (AsType (..), EraInMode (..), Tx (Tx))
-import Control.Lens (preview, (^.))
+import Cardano.Api (
+  AsType (..),
+  EraInMode (..),
+  ShelleyBasedEra (ShelleyBasedEraBabbage),
+  Tx (Tx),
+  toLedgerPParams,
+ )
+import Cardano.Api.Shelley (toShelleyTxOut)
+import Cardano.Ledger.Shelley.API.Wallet (
+  CLI (evaluateMinLovelaceOutput),
+ )
+import Cardano.Prelude (maybeToEither)
+import Control.Lens (preview, (.~), (^.))
 import Control.Monad (join, void, when)
 import Control.Monad.Freer (Eff, Member, interpret, reinterpret, runM, subsume, type (~>))
 import Control.Monad.Freer.Error (runError)
@@ -46,7 +57,7 @@ import Control.Monad.Trans.Either (EitherT, eitherT, firstEitherT, newEitherT)
 import Data.Aeson (ToJSON, Value (Array, Bool, Null, Number, Object, String))
 import Data.Aeson.Extras (encodeByteString)
 import Data.Aeson.KeyMap qualified as KeyMap
-import Data.Function (fix)
+import Data.Function (fix, (&))
 import Data.Kind (Type)
 import Data.List.NonEmpty (NonEmpty ((:|)))
 import Data.Map qualified as Map
@@ -56,15 +67,16 @@ import Data.Text qualified as Text
 import Data.Vector qualified as V
 import Ledger (POSIXTime)
 import Ledger qualified
+import Ledger.Ada qualified as Ada
 import Ledger.Address (PaymentPubKeyHash (PaymentPubKeyHash))
-import Ledger.Constraints.OffChain (UnbalancedTx (..), adjustUnbalancedTx)
-import Ledger.Params (Params (Params))
+import Ledger.Constraints.OffChain (UnbalancedTx (..), tx)
 import Ledger.Slot (Slot (Slot))
-import Ledger.TimeSlot (SlotConfig (..))
-import Ledger.Tx (CardanoTx (CardanoApiTx, EmulatorTx))
+import Ledger.Tx (CardanoTx (CardanoApiTx, EmulatorTx), outputs)
 import Ledger.Tx qualified as Tx
+import Ledger.Validation (Coin (Coin))
 import Plutus.ChainIndex.TxIdState (fromTx, transactionStatus)
 import Plutus.ChainIndex.Types (RollbackState (..), TxIdState, TxStatus)
+import Plutus.Contract.CardanoAPI (toCardanoTxOutBabbage, toCardanoTxOutDatumHashBabbage)
 import Plutus.Contract.Checkpoint (Checkpoint (..))
 import Plutus.Contract.Effects (
   BalanceTxResponse (..),
@@ -76,6 +88,7 @@ import Plutus.Contract.Effects (
  )
 import Plutus.Contract.Resumable (Resumable (..))
 import Plutus.Contract.Types (Contract (..), ContractEffs)
+import Plutus.V1.Ledger.Tx (TxOut (txOutValue))
 import PlutusTx.Builtins (fromBuiltin)
 import Prettyprinter (Pretty (pretty), (<+>))
 import Prettyprinter qualified as PP
@@ -187,8 +200,8 @@ handlePABReq contractEnv req = do
       ChainIndexQueryResp <$> queryChainIndex @w query
     BalanceTxReq unbalancedTx ->
       BalanceTxResp <$> balanceTx @w contractEnv unbalancedTx
-    WriteBalancedTxReq tx ->
-      WriteBalancedTxResp <$> writeBalancedTx @w contractEnv tx
+    WriteBalancedTxReq tx' ->
+      WriteBalancedTxResp <$> writeBalancedTx @w contractEnv tx'
     AwaitSlotReq s -> AwaitSlotResp <$> awaitSlot @w contractEnv s
     AwaitTimeReq t -> AwaitTimeResp <$> awaitTime @w contractEnv t
     CurrentSlotReq -> CurrentSlotResp <$> currentSlot @w contractEnv
@@ -210,18 +223,47 @@ handlePABReq contractEnv req = do
   printBpiLog @w Debug $ pretty resp
   pure resp
 
+-- do-not-remove yet, need fo comparison with "own" implementation below
+-- minAda calculated fo 1 Lovelace output for this version is 999978
+-- 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"
+
+-- minAda calculated fo 1 Lovelace output for this version is 840450
+-- if switch all babbage related things to alonzo, it will calculate 999978 as ^ above
 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"
+adjustUnbalancedTx' contractEnv unbalancedTx = pure $ do
+  pparams <- getPParams
+  let networkId = contractEnv.cePABConfig.pcNetwork
+
+  updatedOuts <- traverse (adjustTxOut networkId pparams) (unbalancedTx ^. tx . outputs)
+  return $ unbalancedTx & (tx . outputs .~ updatedOuts)
+  where
+    getPParams =
+      maybeToEither (Tx.TxBodyError "No protocol params found in PAB config") $
+        asBabbageBased toLedgerPParams
+          <$> contractEnv.cePABConfig.pcProtocolParams
+
+    adjustTxOut networkId pparams txOut = do
+      txOut' <- toCardanoTxOutBabbage networkId toCardanoTxOutDatumHashBabbage txOut
+      let (Coin minTxOut) = evaluateMinLovelaceOutput pparams (asBabbageBased toShelleyTxOut txOut')
+          missingLovelace = max 0 (Ada.lovelaceOf minTxOut - Ada.fromValue (txOutValue txOut))
+      pure $ txOut {txOutValue = txOutValue txOut <> Ada.toValue missingLovelace}
+
+    asBabbageBased f = f ShelleyBasedEraBabbage
 
 {- | Await till transaction status change to something from `Unknown`.
  Uses `chain-index` to query transaction by id.
@@ -283,9 +325,9 @@ awaitTxStatusChange contractEnv txId = do
     queryChainIndexForTxState = do
       mTx <- join . preview _TxIdResponse <$> (queryChainIndex @w $ TxFromTxId txId)
       case mTx of
-        Just tx -> do
+        Just tx' -> do
           blk <- fromInteger <$> currentBlock contractEnv
-          pure . Just $ fromTx blk tx
+          pure . Just $ fromTx blk tx'
         Nothing -> pure Nothing
 
     logDebug = printBpiLog @w Debug . pretty
@@ -310,8 +352,8 @@ balanceTx contractEnv unbalancedTx = do
 
 fromCardanoTx :: CardanoTx -> Tx.Tx
 fromCardanoTx (CardanoApiTx _) = error "Cannot handle cardano api tx"
-fromCardanoTx (EmulatorTx tx) = tx
-fromCardanoTx (Tx.Both tx _) = tx
+fromCardanoTx (EmulatorTx tx') = tx'
+fromCardanoTx (Tx.Both tx' _) = tx'
 
 -- | This step would build tx files, write them to disk and submit them to the chain
 writeBalancedTx ::
@@ -322,48 +364,48 @@ writeBalancedTx ::
   Eff effs WriteBalancedTxResponse
 writeBalancedTx contractEnv cardanoTx = do
   let pabConf = contractEnv.cePABConfig
-      tx = fromCardanoTx cardanoTx
+      tx' = fromCardanoTx cardanoTx
   uploadDir @w pabConf.pcSigningKeyFileDir
   createDirectoryIfMissing @w False (Text.unpack pabConf.pcScriptFileDir)
 
   eitherT (pure . WriteBalancedTxFailed . OtherError) (pure . WriteBalancedTxSuccess . CardanoApiTx) $ do
-    void $ firstEitherT (Text.pack . show) $ newEitherT $ Files.writeAll @w pabConf tx
+    void $ firstEitherT (Text.pack . show) $ newEitherT $ Files.writeAll @w pabConf tx'
     lift $ uploadDir @w pabConf.pcScriptFileDir
 
     privKeys <- newEitherT $ Files.readPrivateKeys @w pabConf
 
-    let requiredSigners = Map.keys $ tx ^. Tx.signatures
+    let requiredSigners = Map.keys $ tx' ^. Tx.signatures
         skeys = Map.filter (\case FromSKey _ -> True; FromVKey _ -> False) privKeys
         signable = all ((`Map.member` skeys) . Ledger.pubKeyHash) requiredSigners
 
-    void $ newEitherT $ BodyBuilder.buildAndEstimateBudget @w pabConf privKeys tx
+    void $ newEitherT $ BodyBuilder.buildAndEstimateBudget @w pabConf privKeys tx'
 
     -- TODO: This whole part is hacky and we should remove it.
-    let path = Text.unpack $ Files.txFilePath pabConf "raw" (Tx.txId tx)
+    let path = Text.unpack $ Files.txFilePath pabConf "raw" (Tx.txId tx')
     -- We read back the tx from file as tx currently has the wrong id (but the one we create with cardano-cli is correct)
     alonzoBody <- firstEitherT (Text.pack . show) $ newEitherT $ readFileTextEnvelope @w (AsTxBody AsBabbageEra) path
     let cardanoApiTx = Tx.SomeTx (Tx alonzoBody []) BabbageEraInCardanoMode
 
     if signable
-      then newEitherT $ CardanoCLI.signTx @w pabConf tx requiredSigners
+      then newEitherT $ CardanoCLI.signTx @w pabConf tx' requiredSigners
       else
         lift . printBpiLog @w Warn . PP.vsep $
           [ "Not all required signatures have signing key files. Please sign and submit the tx manually:"
-          , "Tx file:" <+> pretty (Files.txFilePath pabConf "raw" (Tx.txId tx))
+          , "Tx file:" <+> pretty (Files.txFilePath pabConf "raw" (Tx.txId tx'))
           , "Signatories (pkh):" <+> pretty (Text.unwords (map pkhToText requiredSigners))
           ]
 
     when (pabConf.pcCollectStats && signable) $
-      collectBudgetStats (Tx.txId tx) pabConf
+      collectBudgetStats (Tx.txId tx') pabConf
 
     when (not pabConf.pcDryRun && signable) $ do
-      newEitherT $ CardanoCLI.submitTx @w pabConf tx
+      newEitherT $ CardanoCLI.submitTx @w pabConf tx'
 
     -- We need to replace the outfile we created at the previous step, as it currently still has the old (incorrect) id
     let cardanoTxId = Ledger.getCardanoTxId $ Tx.CardanoApiTx cardanoApiTx
-        signedSrcPath = Files.txFilePath pabConf "signed" (Tx.txId tx)
+        signedSrcPath = Files.txFilePath pabConf "signed" (Tx.txId tx')
         signedDstPath = Files.txFilePath pabConf "signed" cardanoTxId
-    mvFiles (Files.txFilePath pabConf "raw" (Tx.txId tx)) (Files.txFilePath pabConf "raw" cardanoTxId)
+    mvFiles (Files.txFilePath pabConf "raw" (Tx.txId tx')) (Files.txFilePath pabConf "raw" cardanoTxId)
     when signable $ mvFiles signedSrcPath signedDstPath
 
     pure cardanoApiTx

test/Spec.hs

@@ -1,5 +1,6 @@
 module Main (main) where
 
+import Spec.BotPlutusInterface.AdjustUnbalanced qualified
 import Spec.BotPlutusInterface.Balance qualified
 import Spec.BotPlutusInterface.Contract qualified
 import Spec.BotPlutusInterface.ContractStats qualified
@@ -27,4 +28,5 @@ tests =
     , Spec.BotPlutusInterface.Server.tests
     , Spec.BotPlutusInterface.ContractStats.tests
     , Spec.BotPlutusInterface.TxStatusChange.tests
+    , Spec.BotPlutusInterface.AdjustUnbalanced.tests
     ]

test/Spec/BotPlutusInterface/AdjustUnbalanced.hs

@@ -0,0 +1,98 @@
+module Spec.BotPlutusInterface.AdjustUnbalanced (tests) where
+
+import BotPlutusInterface.Types (
+  ContractEnvironment (cePABConfig),
+  PABConfig (pcOwnPubKeyHash, pcProtocolParams),
+ )
+import Control.Lens ((&), (.~), (^.))
+import Data.Default (def)
+import Data.Text (Text)
+import Ledger (
+  ChainIndexTxOut (PublicKeyChainIndexTxOut),
+  PaymentPubKeyHash (unPaymentPubKeyHash),
+  TxOut (..),
+  Value,
+  outputs,
+  pubKeyHashAddress,
+ )
+import Ledger.Ada qualified as Ada
+import Ledger.Constraints qualified as Constraints
+import Ledger.Tx (TxOutRef (TxOutRef))
+import Plutus.ChainIndex (OutputDatum (NoOutputDatum))
+import Plutus.Contract (
+  Contract (..),
+  Endpoint,
+  adjustUnbalancedTx,
+ )
+import Spec.MockContract (
+  contractEnv,
+  paymentPkh1,
+  paymentPkh2,
+  paymentPkh3,
+  pkhAddr1,
+  runContractPure,
+  utxos,
+ )
+import Test.Tasty (TestTree)
+import Test.Tasty.HUnit (Assertion, assertBool, assertFailure, testCase)
+import Prelude
+
+import Data.Foldable (find)
+import Data.Void (Void)
+import Ledger.Ada (fromValue)
+import Ledger.Constraints.OffChain (tx)
+
+tests :: TestTree
+tests = testCase "Adjusting unbalanced transaction" testOutsGetAdjusted
+
+testOutsGetAdjusted :: Assertion
+testOutsGetAdjusted = do
+  let txOutRef = TxOutRef "e406b0cf676fc2b1a9edb0617f259ad025c20ea6f0333820aa7cef1bfe7302e5" 0
+      txOut = PublicKeyChainIndexTxOut pkhAddr1 (Ada.lovelaceValueOf 1350) NoOutputDatum Nothing
+      initState =
+        def & utxos .~ [(txOutRef, txOut)]
+          & contractEnv .~ contractEnv'
+      pabConf = def {pcOwnPubKeyHash = unPaymentPubKeyHash paymentPkh1, pcProtocolParams = Just def}
+      contractEnv' = def {cePABConfig = pabConf}
+
+      smallValue = Ada.lovelaceValueOf 1
+      bigEnoughValue = Ada.adaValueOf 777
+
+      shouldBeAdjusted = (paymentPkh2, smallValue)
+      shouldNotBeAdjusted = (paymentPkh3, bigEnoughValue)
+
+      contract :: Contract () (Endpoint "SendAda" ()) Text [TxOut]
+      contract = do
+        let constraints = foldMap toPayConstraint [shouldBeAdjusted, shouldNotBeAdjusted]
+            utx = either (error . show) id (Constraints.mkTx @Void mempty constraints)
+        adjustedUtx <- adjustUnbalancedTx utx
+        return (adjustedUtx ^. tx . outputs)
+
+  case runContractPure contract initState of
+    (Right outs, _) -> do
+      -- check of value that should be adjusted
+      assertBool
+        "Small values should be adjusted and become bigger"
+        (fromValue (outValueForPkh outs paymentPkh2) > fromValue smallValue)
+
+      -- check of value that should NOT be adjusted
+      let resultAdaAmount = fromValue (outValueForPkh outs paymentPkh3)
+          initialAdaAmount = fromValue bigEnoughValue
+          errMessage =
+            "Big enough value should not be adjusted, but it changed: "
+              <> show initialAdaAmount
+              <> " -> "
+              <> show resultAdaAmount
+      assertBool errMessage (resultAdaAmount == initialAdaAmount)
+    e -> assertFailure $ "RES:\n" ++ show e
+
+toPayConstraint :: (PaymentPubKeyHash, Value) -> Constraints.TxConstraints i o
+toPayConstraint (pkh, value) = Constraints.mustPayToPubKey pkh value
+
+outValueForPkh :: [TxOut] -> PaymentPubKeyHash -> Value
+outValueForPkh outs pkh =
+  let address = pubKeyHashAddress pkh Nothing
+   in maybe
+        (error "Should not happen: value for PKH used in test not found")
+        txOutValue
+        $ flip find outs $ \txOut -> address == txOutAddress txOut