Add support for AwaitTxStatusChangeReq contract request

Change-type: minor
Signed-off-by: Giovanni Garufi <giovanni@mlabs.city>

Author: nazrhom

examples/plutus-game/app/Main.hs

@@ -24,6 +24,7 @@ import Data.Aeson.TH (defaultOptions, deriveJSON)
 import Data.ByteString.Lazy qualified as LazyByteString
 import Data.Default (def)
 import Data.Maybe (fromMaybe)
+import Ledger.Address (StakePubKeyHash (..))
 import Playground.Types (FunctionSchema)
 import Schema (FormSchema)
 import Servant.Client.Core (BaseUrl (BaseUrl), Scheme (Http))
@@ -60,11 +61,12 @@ main = do
           , pcProtocolParams = protocolParams
           , pcTipPollingInterval = 10_000_000
           , pcSlotConfig = def
-          , pcOwnPubKeyHash = "0f45aaf1b2959db6e5ff94dbb1f823bf257680c3c723ac2d49f97546"
+          , pcOwnPubKeyHash = "54667d9a5b790a8640fe4662812060a782aa5a3a266cf75ff3869be3"
+          , pcOwnStakePubKeyHash = Just $ StakePubKeyHash "7f8286c1eae3afc4241480cc534ab89f28383f4673bc5aa27e0582b0"
           , pcScriptFileDir = "./scripts"
           , pcSigningKeyFileDir = "./signing-keys"
           , pcTxFileDir = "./txs"
-          , pcDryRun = True
+          , pcDryRun = False
           , pcLogLevel = Debug
           , pcProtocolParamsFile = "./protocol.json"
           , pcForceBudget = Just (1000, 1000)

src/BotPlutusInterface/Balance.hs

@@ -73,7 +73,7 @@ balanceTxIO ::
 balanceTxIO pabConf ownPkh unbalancedTx =
   runEitherT $
     do
-      utxos <- newEitherT $ CardanoCLI.utxosAt @w pabConf $ Ledger.pubKeyHashAddress (Ledger.PaymentPubKeyHash ownPkh) Nothing
+      utxos <- newEitherT $ CardanoCLI.utxosAt @w pabConf changeAddr
       privKeys <- newEitherT $ Files.readPrivateKeys @w pabConf
       let utxoIndex = fmap Tx.toTxOut utxos <> unBalancedTxUtxoIndex unbalancedTx
           requiredSigs = map Ledger.unPaymentPubKeyHash $ Map.keys (unBalancedTxRequiredSignatories unbalancedTx)
@@ -101,17 +101,19 @@ balanceTxIO pabConf ownPkh unbalancedTx =
       -- 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 fst <$> loop utxoIndex privKeys minUtxos (addOutput ownPkh balancedTx)
+        if adaChange /= 0 && not (hasChangeUTxO changeAddr balancedTx)
+          then fst <$> loop utxoIndex privKeys minUtxos (addOutput changeAddr balancedTx)
           else pure balancedTx
 
       -- Get the updated change, add it to the tx
       let finalAdaChange = getAdaChange utxoIndex balancedTxWithChange
-          fullyBalancedTx = addAdaChange ownPkh finalAdaChange balancedTxWithChange
+          fullyBalancedTx = addAdaChange changeAddr finalAdaChange balancedTxWithChange
 
       -- finally, we must update the signatories
       hoistEither $ addSignatories ownPkh privKeys requiredSigs fullyBalancedTx
   where
+    changeAddr :: Address
+    changeAddr = Ledger.pubKeyHashAddress (Ledger.PaymentPubKeyHash ownPkh) (pabConf.pcOwnStakePubKeyHash)
     loop ::
       Map TxOutRef TxOut ->
       Map PubKeyHash DummyPrivKey ->
@@ -130,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 utxoIndex ownPkh $ tx `withFee` 0
+        hoistEither $ balanceTxStep minUtxos utxoIndex changeAddr $ tx `withFee` 0
 
       exBudget <- newEitherT $ CardanoCLI.buildTx @w pabConf privKeys txWithoutFees
       nonBudgettedFees <- newEitherT $ CardanoCLI.calculateMinFee @w pabConf txWithoutFees
@@ -140,7 +142,7 @@ balanceTxIO pabConf ownPkh unbalancedTx =
       lift $ printLog @w Debug $ "Fees: " ++ show fees
 
       -- Rebalance the initial tx with the above fees
-      balancedTx <- hoistEither $ balanceTxStep minUtxos utxoIndex ownPkh $ tx `withFee` fees
+      balancedTx <- hoistEither $ balanceTxStep minUtxos utxoIndex changeAddr $ tx `withFee` fees
 
       if balancedTx == tx
         then pure (balancedTx, minUtxos)
@@ -175,13 +177,13 @@ calculateMinUtxos pabConf datums txOuts =
 balanceTxStep ::
   [(TxOut, Integer)] ->
   Map TxOutRef TxOut ->
-  PubKeyHash ->
+  Address ->
   Tx ->
   Either Text Tx
-balanceTxStep minUtxos utxos ownPkh tx =
+balanceTxStep minUtxos utxos changeAddr tx =
   Right (addLovelaces minUtxos tx)
     >>= balanceTxIns utxos
-    >>= handleNonAdaChange ownPkh utxos
+    >>= handleNonAdaChange changeAddr utxos
 
 -- | Get change value of a transaction, taking inputs, outputs, mint and fees into account
 getChange :: Map TxOutRef TxOut -> Tx -> Value
@@ -288,10 +290,9 @@ addTxCollaterals utxos tx = do
     filterAdaOnly = Map.filter (isAdaOnly . txOutValue)
 
 -- | Ensures all non ada change goes back to user
-handleNonAdaChange :: PubKeyHash -> Map TxOutRef TxOut -> Tx -> Either Text Tx
-handleNonAdaChange ownPkh utxos tx =
-  let changeAddr = Ledger.pubKeyHashAddress (Ledger.PaymentPubKeyHash ownPkh) Nothing
-      nonAdaChange = getNonAdaChange utxos tx
+handleNonAdaChange :: Address -> Map TxOutRef TxOut -> Tx -> Either Text Tx
+handleNonAdaChange changeAddr utxos tx =
+  let nonAdaChange = getNonAdaChange utxos tx
       outputs =
         case partition ((==) changeAddr . Tx.txOutAddress) $ txOutputs tx of
           ([], txOuts) ->
@@ -307,38 +308,33 @@ handleNonAdaChange ownPkh utxos tx =
         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 =
+hasChangeUTxO :: Address -> Tx -> Bool
+hasChangeUTxO changeAddr 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 =
+addAdaChange :: Address -> Integer -> Tx -> Tx
+addAdaChange changeAddr 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
 
 -- | Adds a 1 lovelace output to a transaction
-addOutput :: PubKeyHash -> Tx -> Tx
-addOutput ownPkh tx = tx {txOutputs = changeTxOut : txOutputs tx}
+addOutput :: Address -> Tx -> Tx
+addOutput changeAddr 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,
+{- | Add the required signatories 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.
 -}
 addSignatories :: PubKeyHash -> Map PubKeyHash DummyPrivKey -> [PubKeyHash] -> Tx -> Either Text Tx

src/BotPlutusInterface/Contract.hs

@@ -12,21 +12,23 @@ import BotPlutusInterface.Effects (
   logToContract,
   printLog,
   queryChainIndex,
+  readFileTextEnvelope,
   threadDelay,
   uploadDir,
  )
 import BotPlutusInterface.Files (DummyPrivKey (FromSKey, FromVKey))
 import BotPlutusInterface.Files qualified as Files
-import BotPlutusInterface.Types (ContractEnvironment (..), LogLevel (Debug, Warn), Tip (slot))
-import Control.Lens ((^.))
-import Control.Monad (void)
+import BotPlutusInterface.Types (ContractEnvironment (..), LogLevel (Debug, Warn), Tip (block, slot))
+import Cardano.Api (AsType (..), EraInMode (..))
+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)
 import Control.Monad.Freer.Extras.Log (handleLogIgnore)
 import Control.Monad.Freer.Extras.Modify (raiseEnd)
 import Control.Monad.Freer.Writer (Writer (Tell))
 import Control.Monad.Trans.Class (lift)
-import Control.Monad.Trans.Either (eitherT, firstEitherT, newEitherT, secondEitherT)
+import Control.Monad.Trans.Either (eitherT, firstEitherT, newEitherT)
 import Data.Aeson (ToJSON, Value)
 import Data.Aeson.Extras (encodeByteString)
 import Data.Kind (Type)
@@ -42,13 +44,15 @@ import Ledger.Slot (Slot (Slot))
 import Ledger.TimeSlot (posixTimeRangeToContainedSlotRange, posixTimeToEnclosingSlot, slotToEndPOSIXTime)
 import Ledger.Tx (CardanoTx)
 import Ledger.Tx qualified as Tx
-import Plutus.ChainIndex.Types (RollbackState (Committed), TxValidity (..))
+import Plutus.ChainIndex.Types (RollbackState (Committed), TxStatus, TxValidity (..))
 import Plutus.Contract.Checkpoint (Checkpoint (..))
 import Plutus.Contract.Effects (
   BalanceTxResponse (..),
+  ChainIndexQuery (..),
   PABReq (..),
   PABResp (..),
   WriteBalancedTxResponse (..),
+  _TxIdResponse,
  )
 import Plutus.Contract.Resumable (Resumable (..))
 import Plutus.Contract.Types (Contract (..), ContractEffs)
@@ -148,13 +152,13 @@ handlePABReq contractEnv req = do
         PosixTimeRangeToContainedSlotRangeResp $
           Right $
             posixTimeRangeToContainedSlotRange contractEnv.cePABConfig.pcSlotConfig posixTimeRange
+    AwaitTxStatusChangeReq txId -> AwaitTxStatusChangeResp txId <$> getTxUpdate @w contractEnv txId
     ------------------------
     -- Unhandled requests --
     ------------------------
     -- AwaitTimeReq t -> pure $ AwaitTimeResp t
     -- AwaitUtxoSpentReq txOutRef -> pure $ AwaitUtxoSpentResp ChainIndexTx
     -- AwaitUtxoProducedReq Address -> pure $ AwaitUtxoProducedResp (NonEmpty ChainIndexTx)
-    AwaitTxStatusChangeReq txId -> pure $ AwaitTxStatusChangeResp txId (Committed TxValid ())
     -- AwaitTxOutStatusChangeReq TxOutRef
     -- ExposeEndpointReq ActiveEndpoint -> ExposeEndpointResp EndpointDescription (EndpointValue JSON.Value)
     -- YieldUnbalancedTxReq UnbalancedTx
@@ -163,6 +167,33 @@ handlePABReq contractEnv req = do
   printLog @w Debug $ show resp
   pure resp
 
+getTxUpdate ::
+  forall (w :: Type) (effs :: [Type -> Type]).
+  Member (PABEffect w) effs =>
+  ContractEnvironment w ->
+  Ledger.TxId ->
+  Eff effs TxStatus
+getTxUpdate contractEnv txId = do
+  let minBlockHeight = 3
+  _ <- findTxByIdOrLoop
+  printLog @w Debug $ "Found tx in chain index. Waiting for " ++ show minBlockHeight ++ " blocks"
+  _ <- awaitNBlocks @w contractEnv minBlockHeight
+  printLog @w Debug "Waited, checking once more for tx rollback"
+  _ <- findTxByIdOrLoop
+  printLog @w Debug "Tx is confirmed"
+  pure $ Committed TxValid ()
+  where
+    findTxByIdOrLoop :: Eff effs ()
+    findTxByIdOrLoop = do
+      mTx <- join . preview _TxIdResponse <$> (queryChainIndex @w $ TxFromTxId txId)
+      case mTx of
+        Just _ -> pure ()
+        Nothing -> do
+          printLog @w Debug "Tx not found... looping"
+          -- Wait for 1 block and try again
+          _ <- awaitNBlocks @w contractEnv 1
+          void $ getTxUpdate @w contractEnv txId
+
 -- | This will FULLY balance a transaction
 balanceTx ::
   forall (w :: Type) (effs :: [Type -> Type]).
@@ -194,7 +225,7 @@ writeBalancedTx contractEnv (Right tx) = do
   uploadDir @w pabConf.pcSigningKeyFileDir
   createDirectoryIfMissing @w False (Text.unpack pabConf.pcScriptFileDir)
 
-  eitherT (pure . WriteBalancedTxFailed . OtherError) (pure . WriteBalancedTxSuccess . Right) $ do
+  eitherT (pure . WriteBalancedTxFailed . OtherError) (pure . WriteBalancedTxSuccess . Left) $ do
     void $ firstEitherT (Text.pack . show) $ newEitherT $ Files.writeAll @w pabConf tx
     lift $ uploadDir @w pabConf.pcScriptFileDir
 
@@ -215,9 +246,16 @@ writeBalancedTx contractEnv (Right tx) = do
           , "Signatories (pkh): " <> Text.unwords (map pkhToText requiredSigners)
           ]
 
-    if not pabConf.pcDryRun && signable
-      then secondEitherT (const tx) $ newEitherT $ CardanoCLI.submitTx @w pabConf tx
-      else pure tx
+    let ext = if signable then "signed" else "raw"
+        path = Text.unpack $ Files.txFilePath pabConf ext 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)
+    alonxoTx <- firstEitherT (Text.pack . show) $ newEitherT $ readFileTextEnvelope @w (AsTx AsAlonzoEra) path
+    let cardanoTx = Tx.SomeTx alonxoTx AlonzoEraInCardanoMode
+
+    when (not pabConf.pcDryRun && signable) $ do
+      newEitherT $ CardanoCLI.submitTx @w pabConf tx
+
+    pure cardanoTx
 
 pkhToText :: Ledger.PubKey -> Text
 pkhToText = encodeByteString . fromBuiltin . Ledger.getPubKeyHash . Ledger.pubKeyHash
@@ -239,6 +277,26 @@ awaitSlot contractEnv s@(Slot n) = do
       | n < tip'.slot -> pure $ Slot tip'.slot
     _ -> awaitSlot contractEnv s
 
+-- | Wait for n Blocks.
+awaitNBlocks ::
+  forall (w :: Type) (effs :: [Type -> Type]).
+  Member (PABEffect w) effs =>
+  ContractEnvironment w ->
+  Integer ->
+  Eff effs ()
+awaitNBlocks contractEnv n = do
+  current <- currentBlock contractEnv
+  go current
+  where
+    go :: Integer -> Eff effs ()
+    go start = do
+      threadDelay @w (fromIntegral contractEnv.cePABConfig.pcTipPollingInterval)
+      tip <- CardanoCLI.queryTip @w contractEnv.cePABConfig
+      case tip of
+        Right tip'
+          | start + n >= tip'.block -> pure ()
+        _ -> go start
+
 {- | Wait at least until the given time. Uses the awaitSlot under the hood, so the same constraints
  are applying here as well.
 -}
@@ -261,6 +319,14 @@ currentSlot ::
 currentSlot contractEnv =
   Slot . slot . either (error . Text.unpack) id <$> CardanoCLI.queryTip @w contractEnv.cePABConfig
 
+currentBlock ::
+  forall (w :: Type) (effs :: [Type -> Type]).
+  Member (PABEffect w) effs =>
+  ContractEnvironment w ->
+  Eff effs Integer
+currentBlock contractEnv =
+  block . either (error . Text.unpack) id <$> CardanoCLI.queryTip @w contractEnv.cePABConfig
+
 currentTime ::
   forall (w :: Type) (effs :: [Type -> Type]).
   Member (PABEffect w) effs =>

src/BotPlutusInterface/Types.hs

@@ -28,7 +28,7 @@ import Data.Kind (Type)
 import Data.Map (Map)
 import Data.Text (Text)
 import GHC.Generics (Generic)
-import Ledger (PubKeyHash)
+import Ledger (PubKeyHash, StakePubKeyHash)
 import Ledger.TimeSlot (SlotConfig)
 import Network.Wai.Handler.Warp (Port)
 import Numeric.Natural (Natural)
@@ -62,6 +62,7 @@ data PABConfig = PABConfig
     pcDryRun :: !Bool
   , pcLogLevel :: !LogLevel
   , pcOwnPubKeyHash :: !PubKeyHash
+  , pcOwnStakePubKeyHash :: !(Maybe StakePubKeyHash)
   , pcTipPollingInterval :: !Natural
   , -- | Forced budget for scripts, as optional (CPU Steps, Memory Units)
     pcForceBudget :: !(Maybe (Integer, Integer))
@@ -127,6 +128,7 @@ instance Default PABConfig where
       , pcProtocolParamsFile = "./protocol.json"
       , pcLogLevel = Info
       , pcOwnPubKeyHash = ""
+      , pcOwnStakePubKeyHash = Nothing
       , pcForceBudget = Nothing
       , pcPort = 9080
       , pcEnableTxEndpoint = False

test/Spec/BotPlutusInterface/Balance.hs

@@ -61,9 +61,9 @@ addUtxosForFees = do
       tx = mempty {txOutputs = [txout]} `withFee` 500_000
       minUtxo = [(txout, 1_000_000)]
       utxoIndex = Map.fromList [utxo1, utxo2, utxo3]
-      ownPkh = pkh1
+      ownAddr = addr1
       balancedTx =
-        Balance.balanceTxStep minUtxo utxoIndex ownPkh tx
+        Balance.balanceTxStep minUtxo utxoIndex ownAddr tx
 
   txInputs <$> balancedTx @?= Right (Set.fromList [txIn1, txIn2])
 
@@ -73,9 +73,9 @@ addUtxosForNativeTokens = do
       tx = mempty {txOutputs = [txout]} `withFee` 500_000
       minUtxo = [(txout, 1_000_000)]
       utxoIndex = Map.fromList [utxo1, utxo2, utxo3, utxo4]
-      ownPkh = pkh1
+      ownAddr = addr1
       balancedTx =
-        Balance.balanceTxStep minUtxo utxoIndex ownPkh tx
+        Balance.balanceTxStep minUtxo utxoIndex ownAddr tx
 
   txInputs <$> balancedTx @?= Right (Set.fromList [txIn1, txIn2, txIn3, txIn4])
 
@@ -85,8 +85,8 @@ addUtxosForChange = do
       tx = mempty {txOutputs = [txout]} `withFee` 500_000
       minUtxo = [(txout, 1_000_000)]
       utxoIndex = Map.fromList [utxo1, utxo2, utxo3]
-      ownPkh = pkh1
+      ownAddr = addr1
       balancedTx =
-        Balance.balanceTxStep minUtxo utxoIndex ownPkh tx
+        Balance.balanceTxStep minUtxo utxoIndex ownAddr tx
 
   txInputs <$> balancedTx @?= Right (Set.fromList [txIn1, txIn2])