draft: ex-budget for plutip

mikekeke · mikekeke · commit 4387df4b57a2 · 2022-04-08T17:21:00.000+03:00
- return ex budgets for each script for each transaction
diff --git a/bot-plutus-interface.cabal b/bot-plutus-interface.cabal
@@ -25,7 +25,8 @@ source-repository head
 common common-lang
   ghc-options:
     -Wall -Wcompat -Wincomplete-record-updates
-    -Wincomplete-uni-patterns -Wredundant-constraints -Werror
+    -Wincomplete-uni-patterns -Wredundant-constraints 
+    -- -Werror
     -fobject-code -fno-ignore-interface-pragmas
     -fno-omit-interface-pragmas -fplugin=RecordDotPreprocessor
 
diff --git a/examples/ex-units/app/Main.hs b/examples/ex-units/app/Main.hs
@@ -29,13 +29,14 @@ import Prelude
 -}
 main :: IO ()
 main = do
-  [sockPath, clusterDir, cliDir] <- getArgs
-  setEnv "CARDANO_NODE_SOCKET_PATH" sockPath
+  [clusterDir, cliDir] <- getArgs
+  let socketPath = clusterDir ++ "/node/node.socket"
+  setEnv "CARDANO_NODE_SOCKET_PATH" socketPath
   getEnv "PATH" >>= \p -> setEnv "PATH" (p ++ ":" ++ cliDir)
-  let nodeInfo = BPI.NodeInfo Mainnet sockPath
+  let nodeInfo = BPI.NodeInfo Mainnet socketPath
 
   cEnv <- mkContractEnv nodeInfo clusterDir
-  res <- BPI.runContract cEnv lockThenSpend
+  res <- BPI.runContract' cEnv lockThenSpend
   putStrLn $ case res of
     Right r -> "=== OK ===\n" ++ show r
     Left e -> "=== FAILED ===\n" ++ show e
diff --git a/examples/ex-units/ex-units.cabal b/examples/ex-units/ex-units.cabal
@@ -24,7 +24,7 @@ common common-lang
   ghc-options:
     -Wall -Wcompat -Wincomplete-record-updates
     -Wincomplete-uni-patterns -Wredundant-constraints 
-    -Werror
+    -- -Werror
     -fobject-code -fno-ignore-interface-pragmas
     -fno-omit-interface-pragmas -Wunused-packages
     -fplugin-opt PlutusTx.Plugin:defer-errors
diff --git a/examples/ex-units/src/LockSpend.hs b/examples/ex-units/src/LockSpend.hs
@@ -1,45 +1,50 @@
 module LockSpend (lockThenSpend) where
 
+import Control.Monad (void)
 import Data.Map qualified as Map
 import Data.Text (Text)
-import Ledger
-  ( Address,
-    CardanoTx,
-    CurrencySymbol,
-    MintingPolicy,
-    ScriptContext (scriptContextTxInfo),
-    TxId,
-    Validator,
-    getCardanoTxId,
-    mkMintingPolicyScript,
-    scriptAddress,
-    scriptCurrencySymbol,
-    unitDatum,
-    unitRedeemer,
-    validatorHash, TxInfo (txInfoMint), TxOutRef, ChainIndexTxOut, PaymentPubKeyHash (PaymentPubKeyHash), pubKeyHashAddress
-  )
+import Ledger (
+  Address,
+  CardanoTx,
+  ChainIndexTxOut,
+  CurrencySymbol,
+  MintingPolicy,
+  PaymentPubKeyHash (PaymentPubKeyHash),
+  ScriptContext (scriptContextTxInfo),
+  TxId,
+  TxInfo (txInfoMint),
+  TxOutRef,
+  Validator,
+  getCardanoTxId,
+  mkMintingPolicyScript,
+  pubKeyHashAddress,
+  scriptAddress,
+  scriptCurrencySymbol,
+  unitDatum,
+  unitRedeemer,
+  validatorHash,
+ )
 import Ledger.Constraints qualified as Constraints
 import Ledger.Typed.Scripts (wrapMintingPolicy)
 import Ledger.Typed.Scripts.Validators qualified as Validators
 import Ledger.Value (flattenValue, tokenName)
 import Plutus.Contract (Contract, awaitTxConfirmed, submitTx, submitTxConstraintsWith)
 import Plutus.Contract qualified as Contract
 import Plutus.PAB.Effects.Contract.Builtin (EmptySchema)
+import Plutus.V1.Ledger.Ada (adaValueOf)
 import Plutus.V1.Ledger.Ada qualified as Value
 import Plutus.V1.Ledger.Value qualified as Value
 import PlutusTx qualified
 import PlutusTx.Prelude qualified as PP
 import Prelude
-import Control.Monad (void)
-import Plutus.V1.Ledger.Ada (adaValueOf)
 
 lockThenSpend :: Contract () EmptySchema Text [(TxOutRef, ChainIndexTxOut)]
 lockThenSpend = do
   _ <- lockAtScript
   wait 1
   _ <- spendFromScript
   wait 1
-  pkh <- Contract.ownPaymentPubKeyHash 
+  pkh <- Contract.ownPaymentPubKeyHash
   Map.toList <$> Contract.utxosAt (pubKeyHashAddress pkh Nothing)
   where
     wait = void . Contract.waitNSlots
@@ -79,10 +84,11 @@ spendFromScript = do
               <> Constraints.otherScript validator
               <> Constraints.mintingPolicy mintingPolicy
 
-      let txc2 = Constraints.mustSpendScriptOutput oref2 unitRedeemer
-                 <> Constraints.mustPayToPubKey 
-                      (PaymentPubKeyHash "72cae61f85ed97fb0e7703d9fec382e4973bf47ea2ac9335cab1e3fe") 
-                      (adaValueOf 200)  
+      let txc2 =
+            Constraints.mustSpendScriptOutput oref2 unitRedeemer
+              <> Constraints.mustPayToPubKey
+                (PaymentPubKeyHash "72cae61f85ed97fb0e7703d9fec382e4973bf47ea2ac9335cab1e3fe")
+                (adaValueOf 200)
           lookups2 =
             Constraints.unspentOutputs (Map.fromList utxos2)
               <> Constraints.otherScript (validator2 2)
@@ -130,7 +136,6 @@ mkValidator2 i _ _ _ =
     someWork = PP.sort $ PP.reverse [0, 1, 2, 3, 4, 5, 6, 7, 8, 9] :: [Integer]
     check = PP.length someWork PP.== 10
 
-
 data TestLockSpend2
 
 instance Validators.ValidatorTypes TestLockSpend2 where
@@ -154,7 +159,7 @@ validatorAddr2 = scriptAddress . validator2
 -- minting policy
 {-# INLINEABLE mkPolicy #-}
 mkPolicy :: () -> ScriptContext -> Bool
-mkPolicy _ !ctx =
+mkPolicy _ ctx =
   PP.traceIfFalse "Let me mint" check
   where
     info = scriptContextTxInfo ctx
diff --git a/src/BotPlutusInterface/Contract.hs b/src/BotPlutusInterface/Contract.hs
@@ -1,7 +1,7 @@
 {-# LANGUAGE AllowAmbiguousTypes #-}
 {-# LANGUAGE RankNTypes #-}
 
-module BotPlutusInterface.Contract (runContract, handleContract) where
+module BotPlutusInterface.Contract (runContract, runContract', handleContract) where
 
 import BotPlutusInterface.Balance qualified as PreBalance
 import BotPlutusInterface.BodyBuilder qualified as BodyBuilder
@@ -17,11 +17,11 @@ import BotPlutusInterface.Effects (
   queryChainIndex,
   readFileTextEnvelope,
   threadDelay,
-  uploadDir,
+  uploadDir, estimateBudget, saveBudget
  )
 import BotPlutusInterface.Files (DummyPrivKey (FromSKey, FromVKey))
 import BotPlutusInterface.Files qualified as Files
-import BotPlutusInterface.Types (ContractEnvironment (..), LogLevel (Debug, Warn), Tip (block, slot))
+import BotPlutusInterface.Types (ContractEnvironment (..), LogLevel (Debug, Warn), Tip (block, slot), Budgets, TxFile (Signed), TxBudget)
 import Cardano.Api (AsType (..), EraInMode (..), Tx (Tx))
 import Control.Lens (preview, (^.))
 import Control.Monad (join, void, when)
@@ -64,15 +64,29 @@ import Plutus.Contract.Types (Contract (..), ContractEffs)
 import PlutusTx.Builtins (fromBuiltin)
 import Wallet.Emulator.Error (WalletAPIError (..))
 import Prelude
+import Control.Concurrent.STM (newTVarIO, TVar, readTVarIO)
+import Data.Map (Map)
 
 runContract ::
   forall (w :: Type) (s :: Row Type) (e :: Type) (a :: Type).
   (ToJSON w, Monoid w) =>
   ContractEnvironment w ->
   Contract w s e a ->
   IO (Either e a)
-runContract contractEnv (Contract effs) = do
-  runM $ handlePABEffect @w contractEnv $ raiseEnd $ handleContract contractEnv effs
+runContract contractEnv contract = 
+  fmap fst <$> runContract' contractEnv contract
+
+runContract' ::
+  forall (w :: Type) (s :: Row Type) (e :: Type) (a :: Type).
+  (ToJSON w, Monoid w) =>
+  ContractEnvironment w ->
+  Contract w s e a ->
+  IO (Either e (a, Map Text TxBudget))
+runContract' contractEnv (Contract effs) = do
+  emptyBudgets :: Budgets <- newTVarIO mempty
+  res <- runM $ handlePABEffect @w contractEnv emptyBudgets $ raiseEnd $ handleContract contractEnv effs
+  budgets <- readTVarIO emptyBudgets
+  return $ (,budgets) <$> res
 
 handleContract ::
   forall (w :: Type) (e :: Type) (a :: Type).
@@ -272,6 +286,12 @@ writeBalancedTx contractEnv (Right tx) = do
     -- We need to replace the outfile we created at the previous step, as it currently still has the old (incorrect) id
     mvFiles (Files.txFilePath pabConf "raw" (Tx.txId tx)) (Files.txFilePath pabConf "raw" (Ledger.getCardanoTxId $ Left cardanoTx))
     when signable $ mvFiles (Files.txFilePath pabConf "signed" (Tx.txId tx)) (Files.txFilePath pabConf "signed" (Ledger.getCardanoTxId $ Left cardanoTx))
+    
+    let txId = Ledger.getCardanoTxId $ Left cardanoTx
+        path = Text.unpack $ Files.txFilePath pabConf "signed" txId
+    b <- firstEitherT (Text.pack . show) $ newEitherT $ estimateBudget @w (Signed path)
+
+    _ <- newEitherT (Right <$> saveBudget @w (Text.pack $ show txId) b)
 
     pure cardanoTx
   where
diff --git a/src/BotPlutusInterface/Effects.hs b/src/BotPlutusInterface/Effects.hs
@@ -20,7 +20,7 @@ module BotPlutusInterface.Effects (
   writeFileTextEnvelope,
   callCommand,
   estimateBudget,
-) where
+saveBudget) where
 
 import BotPlutusInterface.ChainIndex (handleChainIndexReq)
 import BotPlutusInterface.Estimate qualified as Estimate
@@ -31,7 +31,7 @@ import BotPlutusInterface.Types (
   ContractState (ContractState),
   LogLevel (..),
   TxBudget,
-  TxFile,
+  TxFile, Budgets
  )
 import Cardano.Api (AsType, FileError, HasTextEnvelope, TextEnvelopeDescr, TextEnvelopeError)
 import Cardano.Api qualified
@@ -53,6 +53,7 @@ import System.Directory qualified as Directory
 import System.Exit (ExitCode (ExitFailure, ExitSuccess))
 import System.Process (readProcess, readProcessWithExitCode)
 import Prelude hiding (readFile)
+import Data.Map qualified as Map
 
 data ShellArgs a = ShellArgs
   { cmdName :: Text
@@ -88,14 +89,16 @@ data PABEffect (w :: Type) (r :: Type) where
   UploadDir :: Text -> PABEffect w ()
   QueryChainIndex :: ChainIndexQuery -> PABEffect w ChainIndexResponse
   EstimateBudget :: TxFile -> PABEffect w (Either BudgetEstimationError TxBudget)
+  SaveBudget :: Text -> TxBudget -> PABEffect w ()
 
 handlePABEffect ::
   forall (w :: Type) (effs :: [Type -> Type]).
   LastMember IO effs =>
   (Monoid w) =>
   ContractEnvironment w ->
+  Budgets ->
   Eff (PABEffect w ': effs) ~> Eff effs
-handlePABEffect contractEnv =
+handlePABEffect contractEnv budgets =
   interpretM
     ( \case
         CallCommand shellArgs ->
@@ -132,8 +135,12 @@ handlePABEffect contractEnv =
           handleChainIndexReq contractEnv.cePABConfig query
         EstimateBudget txPath ->
           Estimate.estimateBudget contractEnv.cePABConfig txPath
+        SaveBudget txId exBudget -> saveBudgetImpl budgets txId exBudget
     )
 
+saveBudgetImpl budgets txId budget = 
+  atomically $ modifyTVar budgets (Map.insert txId budget)
+
 printLog' :: LogLevel -> LogLevel -> String -> IO ()
 printLog' logLevelSetting msgLogLvl msg =
   when (logLevelSetting >= msgLogLvl) $ putStrLn msg
@@ -267,3 +274,13 @@ queryChainIndex ::
   ChainIndexQuery ->
   Eff effs ChainIndexResponse
 queryChainIndex = send @(PABEffect w) . QueryChainIndex
+
+
+
+saveBudget ::
+  forall (w :: Type) (effs :: [Type -> Type]).
+  Member (PABEffect w) effs =>
+  Text -> 
+  TxBudget  ->
+  Eff effs ()
+saveBudget txId budget = send @(PABEffect w) $ SaveBudget txId budget
diff --git a/src/BotPlutusInterface/Types.hs b/src/BotPlutusInterface/Types.hs
@@ -21,7 +21,7 @@ module BotPlutusInterface.Types (
   SpendBudgets,
   MintBudgets,
   emptyBudget,
-) where
+Budgets) where
 
 import Cardano.Api (NetworkId (Testnet), NetworkMagic (..), ScriptExecutionError, ScriptWitnessIndex)
 import Cardano.Api.ProtocolParameters (ProtocolParameters)
@@ -192,3 +192,6 @@ emptyBudget = TxBudget mempty mempty
 type SpendBudgets = Map TxOutRef ExBudget
 
 type MintBudgets = Map MintingPolicyHash ExBudget
+
+
+type Budgets = TVar (Map Text TxBudget)
