waitTxStatusChange rework

- docs
- clenaup
- testnet tested

Author: mikekeke

src/BotPlutusInterface/Config.hs

@@ -95,12 +95,12 @@ txStatusPollingSpec =
       reqSection'
         "milliseconds"
         naturalSpec
-        "Interval between chain-index queries for transacions status change detection"
+        "Interval between chain-index queries for transactions status change detection"
     spBlocksTimeOut <-
       reqSection'
         "blocks"
         naturalSpec
-        "Timeout (in blocks) after which awating of transaction status change will be cancelled and current staus returned"
+        "Timeout (in blocks) after which awaiting of transaction status change will be cancelled and current Status returned"
     pure $ TxStatusPolling {..}
 
 {- ORMOLU_DISABLE -}
@@ -242,7 +242,7 @@ pabConfigSpec = sectionsSpec "PABConfig" $ do
       (pcTxStatusPolling def)
       "pcTxStatusPolling"
       txStatusPollingSpec
-      "TODO: TxStatusPolling config help" -- FIXME
+      "Set interval between `chain-index` queries and number of blocks to wait until timeout while await Transaction status to change"
   pure PABConfig {..}
 
 docPABConfig :: String

src/BotPlutusInterface/Contract.hs

@@ -47,14 +47,14 @@ import Control.Monad.Trans.Class (lift)
 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.Function (fix)
 import Data.HashMap.Strict qualified as HM
 import Data.Kind (Type)
 import Data.Map qualified as Map
 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))
@@ -205,49 +205,49 @@ handlePABReq contractEnv req = do
   printBpiLog @w Debug $ pretty resp
   pure resp
 
+{- | Await till transaction status change to something from `Unknown`.
+ Uses `chain-index` to query transaction by id.
+ Important notes:
+ * if transaction is not found in `chain-index` status considered to be `Unknown`
+ * if transaction is found but `transactionStatus` failed to make status - status considered to be `Unknown`
+ * uses `TxStatusPolling` to set `chain-index` polling interval and number of blocks to wait until timeout,
+   if timeout is reached, returns whatever status it was able to get during last check
+-}
 awaitTxStatusChange ::
   forall (w :: Type) (effs :: [Type -> Type]).
   Member (PABEffect w) effs =>
   ContractEnvironment w ->
   Ledger.TxId ->
   Eff effs TxStatus
 awaitTxStatusChange contractEnv txId = do
-  traceM "@@ await stats change"
   checkStartedBlock <- currentBlock contractEnv
   printBpiLog @w Debug $ pretty $ "Awaiting status change for " ++ show txId
-  txStausCheckLoop txId contractEnv checkStartedBlock
 
-txStausCheckLoop ::
-  forall (w :: Type) (effs :: [Type -> Type]).
-  Member (PABEffect w) effs =>
-  Ledger.TxId ->
-  ContractEnvironment w ->
-  Integer ->
-  Eff effs TxStatus
-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 . 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
-      retry
-    (status, _) -> return status
+
+  fix $ \loop -> do
+    currBlock <- currentBlock contractEnv
+    txStatus <- getStatus
+    case (txStatus, currBlock > cutOffBlock) of
+      (status, True) -> do
+        logDebug . mconcat $
+          [ "Timeout for waiting `TxId "
+          , show txId
+          , "` status cahnge reached"
+          , " - waited "
+          , show pollTimeout
+          , " blocks."
+          , " Current status: "
+          , show status
+          ]
+        return status
+      (Unknown, _) -> do
+        threadDelay @w pollInterval
+        loop
+      (status, _) -> return status
   where
     getStatus = do
       mTx <- queryChainIndexForTxState
@@ -260,7 +260,7 @@ txStausCheckLoop txId contractEnv checkStartedBlock = do
           blk <- fromInteger <$> currentBlock contractEnv
           case transactionStatus blk txState txId of
             Left e -> do
-              logDebug $ "Staus check for TxId " ++ show txId ++ " failed with " ++ show e
+              logDebug $ "Status check for TxId " ++ show txId ++ " failed with " ++ show e
               return Unknown
             Right st -> do
               logDebug $ "Status for TxId " ++ show txId ++ " is " ++ show st
@@ -276,9 +276,6 @@ txStausCheckLoop txId contractEnv checkStartedBlock = do
         Nothing -> pure Nothing
 
     logDebug = printBpiLog @w Debug . pretty
-    -- logDebug = traceM . show . pretty
-
-    retry = txStausCheckLoop txId contractEnv checkStartedBlock
 
 -- | This will FULLY balance a transaction
 balanceTx ::

src/BotPlutusInterface/Types.hs

@@ -88,10 +88,16 @@ data PABConfig = PABConfig
   }
   deriving stock (Show, Eq)
 
+{- | Settings for `Contract.awaitTxStatusChange` implementation.
+ See also `BotPlutusInterface.Contract.awaitTxStatusChange`
+-}
 data TxStatusPolling = TxStatusPolling
-  { -- | mocroseconds
+  { -- | Interval between `chain-index` queries, microseconds
     spInterval :: !Natural
-  , -- | blocks until timeout, most likely `Unknown` state will be returned
+  , -- | Number of blocks to wait until timeout.
+    --   Timeout is required because transaction can be silently discarded from node mempool
+    --   and never appear in `chain-index` even if it was submitted successfully to the node
+    --   (chain-sync protocol won't help here also)
     spBlocksTimeOut :: !Natural
   }
   deriving stock (Show, Eq)

test/Spec/BotPlutusInterface/TxStatusChange.hs

@@ -2,23 +2,26 @@ module Spec.BotPlutusInterface.TxStatusChange (tests) where
 
 import BotPlutusInterface.Types (
   ContractEnvironment (cePABConfig),
-  PABConfig (pcOwnPubKeyHash),
+  PABConfig (pcOwnPubKeyHash, pcTxStatusPolling),
+  TxStatusPolling (spBlocksTimeOut),
  )
-import Control.Lens ((&), (.~))
-import Control.Monad (void)
+import Control.Lens ((&), (.~), (^.))
 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.ChainIndex (RollbackState (Unknown), Tip (TipAtGenesis), TxStatus)
+import Plutus.ChainIndex.Types (Tip (Tip))
 import Plutus.Contract (
   Contract (..),
   Endpoint,
   awaitTxStatusChange,
+  getTip,
   submitTx,
+  throwError,
  )
 import Spec.MockContract (
   contractEnv,
@@ -27,10 +30,11 @@ import Spec.MockContract (
   paymentPkh2,
   pkhAddr1,
   runContractPure,
+  tip,
   utxos,
  )
 import Test.Tasty (TestTree, testGroup)
-import Test.Tasty.HUnit (Assertion, assertFailure, testCase, (@?=))
+import Test.Tasty.HUnit (Assertion, assertBool, assertFailure, testCase, (@?=))
 import Prelude
 
 tests :: TestTree
@@ -51,28 +55,45 @@ testTxFoundAndConfirmed = do
       pabConf = def {pcOwnPubKeyHash = unPaymentPubKeyHash paymentPkh1}
       contractEnv' = def {cePABConfig = pabConf}
 
-      contract :: Contract () (Endpoint "SendAda" ()) Text ()
+      contract :: Contract () (Endpoint "SendAda" ()) Text TxStatus
       contract = do
         let constraints =
               Constraints.mustPayToPubKey paymentPkh2 (Ada.lovelaceValueOf 1000)
         tx <- submitTx constraints
-        void $ awaitTxStatusChange $ getCardanoTxId tx
+        awaitTxStatusChange $ getCardanoTxId tx
 
   case runContractPure contract initState of
     (Left err, _) -> assertFailure $ Text.unpack err
+    (Right Unknown, _) -> assertFailure "State should not be Unknown"
     (Right _, _) -> pure ()
 
 testStopWaitingByTimeout :: Assertion
 testStopWaitingByTimeout = do
   let initState =
         def & contractEnv .~ contractEnv'
       pabConf = def {pcOwnPubKeyHash = unPaymentPubKeyHash paymentPkh1}
+      timeoutBlocks = fromIntegral . spBlocksTimeOut . pcTxStatusPolling $ pabConf
       contractEnv' = def {cePABConfig = pabConf}
 
-      contract :: Contract () (Endpoint "SendAda" ()) Text TxStatus
-      contract =
-        awaitTxStatusChange nonExistingTxId
+      contract :: Contract () (Endpoint "SendAda" ()) Text (Tip, TxStatus)
+      contract = do
+        awaitStartBlock <- getTip
+        case awaitStartBlock of
+          TipAtGenesis -> throwError "Should not happen: TipAtGenesis"
+          tip' -> do
+            txStatus <- awaitTxStatusChange nonExistingTxId
+            return (tip', txStatus)
 
   case runContractPure contract initState of
     (Left err, _) -> assertFailure $ Text.unpack err
-    (Right txStatus, _) -> txStatus @?= Unknown
+    (Right (startTip, txStatus), state) -> do
+      startAwaitingBlockNo <- getBlock startTip
+      endAwaitingBlockNo <- getBlock $ state ^. tip
+      assertBool
+        "Current block should be GT than start + timeout"
+        (endAwaitingBlockNo > startAwaitingBlockNo + timeoutBlocks)
+      txStatus @?= Unknown
+  where
+    getBlock = \case
+      TipAtGenesis -> assertFailure "Should not happen: TipAtGenesis"
+      Tip _ _ blockNo -> pure blockNo

test/Spec/MockContract.hs

@@ -566,26 +566,25 @@ mockQueryChainIndex = \case
   TxOutFromRef txOutRef -> do
     state <- get @(MockContractState w)
     pure $ TxOutRefResponse $ Tx.fromTxOut =<< lookup txOutRef (state ^. utxos)
-  TxFromTxId txId -> case txId == nonExistingTxId of
-    True -> pure $ TxIdResponse Nothing
-    False -> do
-      -- TODO: Track some kind of state here, add tests to ensure this works correctly
-      -- For now, empty txs
-      state <- get @(MockContractState w)
-      let knownUtxos = state ^. utxos
-      pure $
-        TxIdResponse $
-          Just $
-            ChainIndexTx
-              { _citxTxId = txId
-              , _citxInputs = mempty
-              , _citxOutputs = buildOutputsFromKnownUTxOs knownUtxos txId
-              , _citxValidRange = Ledger.always
-              , _citxData = mempty
-              , _citxRedeemers = mempty
-              , _citxScripts = mempty
-              , _citxCardanoTx = Nothing
-              }
+  TxFromTxId txId ->
+    if txId == nonExistingTxId
+      then pure $ TxIdResponse Nothing
+      else do
+        -- TODO: Track some kind of state here, add tests to ensure this works correctly
+        -- For now, empty txs
+        state <- get @(MockContractState w)
+        let knownUtxos = state ^. utxos
+        pure . TxIdResponse . Just $
+          ChainIndexTx
+            { _citxTxId = txId
+            , _citxInputs = mempty
+            , _citxOutputs = buildOutputsFromKnownUTxOs knownUtxos txId
+            , _citxValidRange = Ledger.always
+            , _citxData = mempty
+            , _citxRedeemers = mempty
+            , _citxScripts = mempty
+            , _citxCardanoTx = Nothing
+            }
   UtxoSetMembership _ ->
     throwError @Text "UtxoSetMembership is unimplemented"
   UtxoSetAtAddress pageQuery _ -> do