wip: waitTxStatusChange rework

- tests added
- config spec added
- bugs fixed
- todo: docs, refactoring, testnet tests

Author: mikekeke

bot-plutus-interface.cabal

@@ -177,6 +177,7 @@ test-suite bot-plutus-interface-test
     Spec.BotPlutusInterface.Contract
     Spec.BotPlutusInterface.ContractStats
     Spec.BotPlutusInterface.Server
+    Spec.BotPlutusInterface.TxStatusChange
     Spec.BotPlutusInterface.UtxoParser
     Spec.MockContract
 

src/BotPlutusInterface/Config.hs

@@ -14,7 +14,12 @@ import BotPlutusInterface.Effects (
   ShellArgs (..),
   callLocalCommand,
  )
-import BotPlutusInterface.Types (CLILocation (..), LogLevel (..), PABConfig (..), TxStatusPolling)
+import BotPlutusInterface.Types (
+  CLILocation (..),
+  LogLevel (..),
+  PABConfig (..),
+  TxStatusPolling (TxStatusPolling, spBlocksTimeOut, spInterval),
+ )
 
 import Cardano.Api (NetworkId (Mainnet, Testnet), unNetworkMagic)
 import Config (Section (Section), Value (Atom, Sections, Text))
@@ -24,6 +29,7 @@ import Config.Schema (
   atomSpec,
   generateDocs,
   naturalSpec,
+  reqSection',
   sectionsSpec,
   trueOrFalseSpec,
   (<!>),
@@ -75,11 +81,27 @@ logLevelSpec =
     <!> Debug <$ atomSpec "debug"
 
 instance ToValue TxStatusPolling where
-  toValue = error "TODO: toValue TxStatusPolling"
+  toValue (TxStatusPolling interval timeout) =
+    Sections
+      ()
+      [ Section () "pollingInterval" $ toValue interval
+      , Section () "pollingTimeout" $ toValue timeout
+      ]
 
 txStatusPollingSpec :: ValueSpec TxStatusPolling
-txStatusPollingSpec = error "TODO: txStatusPollingSpec"
-  
+txStatusPollingSpec =
+  sectionsSpec "TxStatusPolling configuration" $ do
+    spInterval <-
+      reqSection'
+        "milliseconds"
+        naturalSpec
+        "Interval between chain-index queries for transacions status change detection"
+    spBlocksTimeOut <-
+      reqSection'
+        "blocks"
+        naturalSpec
+        "Timeout (in blocks) after which awating of transaction status change will be cancelled and current staus returned"
+    pure $ TxStatusPolling {..}
 
 {- ORMOLU_DISABLE -}
 instance ToValue PABConfig where
@@ -102,7 +124,7 @@ instance ToValue PABConfig where
         pcPort
         pcEnableTxEndpoint
         pcCollectStats
-        pcTxStausPolling
+        pcTxStatusPolling
       ) =
       Sections
         ()
@@ -124,7 +146,7 @@ instance ToValue PABConfig where
         , Section () "port"               $ toValue pcPort
         , Section () "enableTxEndpoint"   $ toValue pcEnableTxEndpoint
         , Section () "collectStats"       $ toValue pcCollectStats
-        , Section () "pcTxStausPolling"   $ toValue pcTxStausPolling
+        , Section () "pcTxStatusPolling"  $ toValue pcTxStatusPolling
         ]
 {- ORMOLU_ENABLE -}
 
@@ -215,13 +237,12 @@ pabConfigSpec = sectionsSpec "PABConfig" $ do
       trueOrFalseSpec
       "Save some stats during contract run (only transactions execution budgets supported atm)"
 
-  pcTxStausPolling <- 
+  pcTxStatusPolling <-
     sectionWithDefault'
-    (pcTxStausPolling def)
-    "pcTxStausPolling"
-    txStatusPollingSpec
-    (error "TODO: TxStatusPolling config help")
-
+      (pcTxStatusPolling def)
+      "pcTxStatusPolling"
+      txStatusPollingSpec
+      "TODO: TxStatusPolling config help" -- FIXME
   pure PABConfig {..}
 
 docPABConfig :: String

src/BotPlutusInterface/Contract.hs

@@ -24,15 +24,17 @@ import BotPlutusInterface.Effects (
   saveBudget,
   slotToPOSIXTime,
   threadDelay,
-  uploadDir
+  uploadDir,
  )
 import BotPlutusInterface.Files (DummyPrivKey (FromSKey, FromVKey))
 import BotPlutusInterface.Files qualified as Files
 import BotPlutusInterface.Types (
   ContractEnvironment (..),
   LogLevel (Debug, Warn),
   Tip (block, slot),
-  TxFile (Signed), spInterval, spBlocksTimeOut
+  TxFile (Signed),
+  -- spBlocksTimeOut,
+  -- spInterval,
  )
 import Cardano.Api (AsType (..), EraInMode (..), Tx (Tx))
 import Control.Lens (preview, (^.))
@@ -52,6 +54,7 @@ import Data.Row (Row)
 import Data.Text (Text)
 import Data.Text qualified as Text
 import Data.Vector qualified as V
+import Debug.Trace (traceM)
 import Ledger (POSIXTime)
 import Ledger qualified
 import Ledger.Address (PaymentPubKeyHash (PaymentPubKeyHash))
@@ -209,35 +212,43 @@ awaitTxStatusChange ::
   Ledger.TxId ->
   Eff effs TxStatus
 awaitTxStatusChange contractEnv txId = do
-  let txStatusPolling = contractEnv.cePABConfig.pcTxStausPolling
-      pollInterval = fromIntegral $ spInterval txStatusPolling
-      pollTimeOut = fromIntegral $ spBlocksTimeOut txStatusPolling
-  cutOffBlock <- (pollTimeOut +) <$> currentBlock contractEnv
+  traceM "@@ await stats change"
+  checkStartedBlock <- currentBlock contractEnv
   printBpiLog @w Debug $ pretty $ "Awaiting status change for " ++ show txId
-  txStausCheckLoop txId contractEnv pollInterval cutOffBlock
+  txStausCheckLoop txId contractEnv checkStartedBlock
 
 txStausCheckLoop ::
   forall (w :: Type) (effs :: [Type -> Type]).
   Member (PABEffect w) effs =>
   Ledger.TxId ->
   ContractEnvironment w ->
-  Int ->
   Integer ->
   Eff effs TxStatus
-txStausCheckLoop txId contractEnv pollInterval cutOffBlock = do
+txStausCheckLoop txId contractEnv checkStartedBlock = do
+  let txStatusPolling = contractEnv.cePABConfig.pcTxStatusPolling
+      pollInterval = fromIntegral $ txStatusPolling.spInterval
+      pollTimeout = txStatusPolling.spBlocksTimeOut
+      cutOffBlock = checkStartedBlock + fromIntegral pollTimeout
   currBlock <- currentBlock contractEnv
   txStatus <- getStatus
   case (txStatus, currBlock > cutOffBlock) of
     (status, True) -> do
-      logDebug $ "Awaiting preiod for TxId " ++ show txId 
-                 ++ " status change is over, current status: " ++ show status
+      logDebug . mconcat $
+        [ "Timeout period for waiting `TxId "
+        , show txId
+        , "` status cahnge is over"
+        , " - waited "
+        , show pollTimeout
+        , " blocks."
+        , " Current status: "
+        , show status
+        ]
       return status
     (Unknown, _) -> do
       threadDelay @w pollInterval
-      txStausCheckLoop txId contractEnv pollInterval cutOffBlock
+      retry
     (status, _) -> return status
   where
-    -- | get Tx status with extensive debug logging
     getStatus = do
       mTx <- queryChainIndexForTxState
       case mTx of
@@ -251,16 +262,9 @@ txStausCheckLoop txId contractEnv pollInterval cutOffBlock = do
             Left e -> do
               logDebug $ "Staus check for TxId " ++ show txId ++ " failed with " ++ show e
               return Unknown
-            Right st -> case st of
-              Unknown -> do
-                logDebug $ "Staus for TxId " ++ show txId ++ " is Unknown"
-                return Unknown
-              other -> do
-                logDebug $
-                  "Staus for TxId " ++ show txId ++ " is " ++ show other
-                pure other
-
-    logDebug = printBpiLog @w Debug . pretty
+            Right st -> do
+              logDebug $ "Status for TxId " ++ show txId ++ " is " ++ show st
+              return st
 
     queryChainIndexForTxState :: Eff effs (Maybe TxIdState)
     queryChainIndexForTxState = do
@@ -271,6 +275,11 @@ txStausCheckLoop txId contractEnv pollInterval cutOffBlock = do
           pure . Just $ fromTx blk tx
         Nothing -> pure Nothing
 
+    logDebug = printBpiLog @w Debug . pretty
+    -- logDebug = traceM . show . pretty
+
+    retry = txStausCheckLoop txId contractEnv checkStartedBlock
+
 -- | This will FULLY balance a transaction
 balanceTx ::
   forall (w :: Type) (effs :: [Type -> Type]).

src/BotPlutusInterface/Types.hs

@@ -22,7 +22,7 @@ module BotPlutusInterface.Types (
   SpendBudgets,
   MintBudgets,
   ContractStats (..),
-  TxStatusPolling(..),
+  TxStatusPolling (..),
   addBudget,
 ) where
 
@@ -84,13 +84,15 @@ data PABConfig = PABConfig
   , pcPort :: !Port
   , pcEnableTxEndpoint :: !Bool
   , pcCollectStats :: !Bool
-  , pcTxStausPolling :: !TxStatusPolling
+  , pcTxStatusPolling :: !TxStatusPolling
   }
   deriving stock (Show, Eq)
 
 data TxStatusPolling = TxStatusPolling
-  { spInterval :: !Natural -- ^ mocroseconds
-  , spBlocksTimeOut :: !Natural -- ^ blocks until timeout, most likely `Unknown` state will be returned
+  { -- | mocroseconds
+    spInterval :: !Natural
+  , -- | blocks until timeout, most likely `Unknown` state will be returned
+    spBlocksTimeOut :: !Natural
   }
   deriving stock (Show, Eq)
 
@@ -229,7 +231,7 @@ instance Default PABConfig where
       , pcPort = 9080
       , pcEnableTxEndpoint = False
       , pcCollectStats = False
-      , pcTxStausPolling = TxStatusPolling 1_000 8
+      , pcTxStatusPolling = TxStatusPolling 1_000 8
       }
 
 data RawTx = RawTx

test/Spec.hs

@@ -4,6 +4,7 @@ import Spec.BotPlutusInterface.Balance qualified
 import Spec.BotPlutusInterface.Contract qualified
 import Spec.BotPlutusInterface.ContractStats qualified
 import Spec.BotPlutusInterface.Server qualified
+import Spec.BotPlutusInterface.TxStatusChange qualified
 import Spec.BotPlutusInterface.UtxoParser qualified
 import Test.Tasty (TestTree, defaultMain, testGroup)
 import Prelude
@@ -25,4 +26,5 @@ tests =
     , Spec.BotPlutusInterface.Balance.tests
     , Spec.BotPlutusInterface.Server.tests
     , Spec.BotPlutusInterface.ContractStats.tests
+    , Spec.BotPlutusInterface.TxStatusChange.tests
     ]

test/Spec/BotPlutusInterface/Config.hs

@@ -113,5 +113,5 @@ pabConfigExample =
     , pcPort = 1021
     , pcEnableTxEndpoint = True
     , pcCollectStats = False
-    , pcTxStausPolling = TxStatusPolling 1_000 8
+    , pcTxStatusPolling = TxStatusPolling 1_000 8
     }

test/Spec/BotPlutusInterface/TxStatusChange.hs

@@ -0,0 +1,78 @@
+module Spec.BotPlutusInterface.TxStatusChange (tests) where
+
+import BotPlutusInterface.Types (
+  ContractEnvironment (cePABConfig),
+  PABConfig (pcOwnPubKeyHash),
+ )
+import Control.Lens ((&), (.~))
+import Control.Monad (void)
+import Data.Default (def)
+import Data.Text (Text)
+import Data.Text qualified as Text
+import Ledger (PaymentPubKeyHash (unPaymentPubKeyHash), getCardanoTxId)
+import Ledger.Ada qualified as Ada
+import Ledger.Constraints qualified as Constraints
+import Ledger.Tx (TxOut (TxOut), TxOutRef (TxOutRef))
+import Plutus.ChainIndex (RollbackState (Unknown), TxStatus)
+import Plutus.Contract (
+  Contract (..),
+  Endpoint,
+  awaitTxStatusChange,
+  submitTx,
+ )
+import Spec.MockContract (
+  contractEnv,
+  nonExistingTxId,
+  paymentPkh1,
+  paymentPkh2,
+  pkhAddr1,
+  runContractPure,
+  utxos,
+ )
+import Test.Tasty (TestTree, testGroup)
+import Test.Tasty.HUnit (Assertion, assertFailure, testCase, (@?=))
+import Prelude
+
+tests :: TestTree
+tests =
+  testGroup
+    "Await Tx status change"
+    [ testCase "Return status if Tx was found as status is not Unknown" testTxFoundAndConfirmed
+    , testCase "Stop waiting by timeout if Tx could not be found" testStopWaitingByTimeout
+    ]
+
+testTxFoundAndConfirmed :: Assertion
+testTxFoundAndConfirmed = do
+  let txOutRef = TxOutRef "e406b0cf676fc2b1a9edb0617f259ad025c20ea6f0333820aa7cef1bfe7302e5" 0
+      txOut = TxOut pkhAddr1 (Ada.lovelaceValueOf 1350) Nothing
+      initState =
+        def & utxos .~ [(txOutRef, txOut)]
+          & contractEnv .~ contractEnv'
+      pabConf = def {pcOwnPubKeyHash = unPaymentPubKeyHash paymentPkh1}
+      contractEnv' = def {cePABConfig = pabConf}
+
+      contract :: Contract () (Endpoint "SendAda" ()) Text ()
+      contract = do
+        let constraints =
+              Constraints.mustPayToPubKey paymentPkh2 (Ada.lovelaceValueOf 1000)
+        tx <- submitTx constraints
+        void $ awaitTxStatusChange $ getCardanoTxId tx
+
+  case runContractPure contract initState of
+    (Left err, _) -> assertFailure $ Text.unpack err
+    (Right _, _) -> pure ()
+
+testStopWaitingByTimeout :: Assertion
+testStopWaitingByTimeout = do
+  let initState =
+        def & contractEnv .~ contractEnv'
+      pabConf = def {pcOwnPubKeyHash = unPaymentPubKeyHash paymentPkh1}
+      contractEnv' = def {cePABConfig = pabConf}
+
+      contract :: Contract () (Endpoint "SendAda" ()) Text TxStatus
+      contract =
+        awaitTxStatusChange nonExistingTxId
+
+  case runContractPure contract initState of
+    (Left err, _) -> assertFailure $ Text.unpack err
+    (Right txStatus, _) -> txStatus @?= Unknown