Merge pull request #122 from mlabs-haskell/misha/await-status-change-rework

Misha/await status change rework

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 (..))
+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,6 +81,29 @@ logLevelSpec =
     <!> Info <$ atomSpec "info"
     <!> Debug <$ atomSpec "debug"
 
+instance ToValue TxStatusPolling where
+  toValue (TxStatusPolling interval timeout) =
+    Sections
+      ()
+      [ Section () "pollingInterval" $ toValue interval
+      , Section () "pollingTimeout" $ toValue timeout
+      ]
+
+txStatusPollingSpec :: ValueSpec TxStatusPolling
+txStatusPollingSpec =
+  sectionsSpec "TxStatusPolling configuration" $ do
+    spInterval <-
+      reqSection'
+        "microseconds"
+        naturalSpec
+        "Interval between chain-index queries for transactions status change detection"
+    spBlocksTimeOut <-
+      reqSection'
+        "blocks"
+        naturalSpec
+        "Timeout (in blocks) after which awaiting of transaction status change will be cancelled and current Status returned"
+    pure $ TxStatusPolling {..}
+
 {- ORMOLU_DISABLE -}
 instance ToValue PABConfig where
   toValue
@@ -98,6 +127,7 @@ instance ToValue PABConfig where
         pcCollectStats
         pcCollectLogs
         pcBudgetMultiplier
+        pcTxStatusPolling
       ) =
       Sections
         ()
@@ -121,6 +151,7 @@ instance ToValue PABConfig where
         , Section () "collectStats"       $ toValue pcCollectStats
         , Section () "collectLogs"        $ toValue pcCollectLogs
         , Section () "budgetMultiplier"   $ toValue pcBudgetMultiplier
+        , Section () "pcTxStatusPolling"  $ toValue pcTxStatusPolling
         ]
 {- ORMOLU_ENABLE -}
 
@@ -225,6 +256,13 @@ pabConfigSpec = sectionsSpec "PABConfig" $ do
       customRationalSpec
       "Multiplier on the budgets automatically calculated"
 
+  pcTxStatusPolling <-
+    sectionWithDefault'
+      (pcTxStatusPolling def)
+      "pcTxStatusPolling"
+      txStatusPollingSpec
+      "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

@@ -45,7 +45,7 @@ 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.Either (fromRight)
+import Data.Function (fix)
 import Data.HashMap.Strict qualified as HM
 import Data.Kind (Type)
 import Data.Map qualified as Map
@@ -203,34 +203,62 @@ 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
-  -- The depth (in blocks) after which a transaction cannot be rolled back anymore (from Plutus.ChainIndex.TxIdState)
-  let chainConstant = 8
-
-  mTx <- queryChainIndexForTxState
-  case mTx of
-    Nothing -> pure Unknown
-    Just txState -> do
-      printBpiLog @w Debug $ "Found transaction in node, waiting" <+> pretty chainConstant <+> " blocks for it to settle."
-      awaitNBlocks @w contractEnv (chainConstant + 1)
-      -- Check if the tx is still present in chain-index, in case of a rollback
-      -- we might not find it anymore.
-      ciTxState' <- queryChainIndexForTxState
-      case ciTxState' of
-        Nothing -> pure Unknown
-        Just _ -> do
-          blk <- fromInteger <$> currentBlock contractEnv
-          -- This will set the validity correctly based on the txState.
-          -- The tx will always be committed, as we wait for chainConstant + 1 blocks
-          let status = transactionStatus blk txState txId
-          pure $ fromRight Unknown status
+  checkStartedBlock <- currentBlock contractEnv
+  printBpiLog @w Debug $ pretty $ "Awaiting status change for " ++ show txId
+
+  let txStatusPolling = contractEnv.cePABConfig.pcTxStatusPolling
+      pollInterval = fromIntegral $ txStatusPolling.spInterval
+      pollTimeout = txStatusPolling.spBlocksTimeOut
+      cutOffBlock = checkStartedBlock + fromIntegral pollTimeout
+
+  fix $ \loop -> do
+    currBlock <- currentBlock contractEnv
+    txStatus <- getStatus
+    case (txStatus, currBlock > cutOffBlock) of
+      (status, True) -> do
+        logDebug . mconcat . fmap mconcat $
+          [ ["Timeout for waiting `TxId ", show txId, "` status change 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
+      case mTx of
+        Nothing -> do
+          logDebug $ "TxId " ++ show txId ++ " not found in index"
+          return Unknown
+        Just txState -> do
+          logDebug $ "TxId " ++ show txId ++ " found in index, checking status"
+          blk <- fromInteger <$> currentBlock contractEnv
+          case transactionStatus blk txState txId of
+            Left e -> do
+              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
+              return st
+
     queryChainIndexForTxState :: Eff effs (Maybe TxIdState)
     queryChainIndexForTxState = do
       mTx <- join . preview _TxIdResponse <$> (queryChainIndex @w $ TxFromTxId txId)
@@ -240,6 +268,8 @@ awaitTxStatusChange contractEnv txId = do
           pure . Just $ fromTx blk tx
         Nothing -> pure Nothing
 
+    logDebug = printBpiLog @w Debug . pretty
+
 -- | This will FULLY balance a transaction
 balanceTx ::
   forall (w :: Type) (effs :: [Type -> Type]).
@@ -355,25 +385,25 @@ 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 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.

src/BotPlutusInterface/QueryNode.hs

@@ -78,11 +78,15 @@ flattenQueryResult = \case
 connectionInfo :: NodeInfo -> C.LocalNodeConnectInfo C.CardanoMode
 connectionInfo (NodeInfo netId socket) =
   C.LocalNodeConnectInfo
-    ( C.CardanoModeParams
-        (C.EpochSlots 21600) -- TODO: this probably should be settable somehow?
-    )
+    (C.CardanoModeParams epochSlots)
     netId
     socket
+  where
+    -- This parameter needed only for the Byron era. Since the Byron
+    -- era is over and the parameter has never changed it is ok to
+    -- hardcode this. See comment on `Cardano.Api.ConsensusModeParams` in
+    -- cardano-node.
+    epochSlots = C.EpochSlots 21600
 
 toQueryError :: Show e => e -> NodeQueryError
 toQueryError = NodeQueryError . pack . show

src/BotPlutusInterface/TimeSlot.hs

@@ -148,7 +148,7 @@ posixTimeRangeToContainedSlotRangeIO
           NegInf -> pure NegInf
           PosInf -> pure PosInf
 
-      -- helper to calulate bound's closure
+      -- helper to calculate bound's closure
       -- if bound is not `NegInf` or `PosInf`, then `Closure` need to be calculated
       -- https://github.com/input-output-hk/plutus-apps/blob/e51f57fa99f4cc0942ba6476b0689e43f0948eb3/plutus-ledger/src/Ledger/TimeSlot.hs#L125-L130
       getExtClosure ::
@@ -186,7 +186,7 @@ posixTimeToSlot sysStart eraHist pTime = do
     toUtc (Ledger.POSIXTime milliseconds) =
       posixSecondsToUTCTime
         . secondsToNominalDiffTime
-        $ fromInteger (milliseconds `div` 1000)
+        $ fromInteger milliseconds / 1000
 
 -- helper functions --
 

src/BotPlutusInterface/Types.hs

@@ -22,6 +22,7 @@ module BotPlutusInterface.Types (
   SpendBudgets,
   MintBudgets,
   ContractStats (..),
+  TxStatusPolling (..),
   LogsList (..),
   addBudget,
 ) where
@@ -89,6 +90,21 @@ data PABConfig = PABConfig
   , -- | Collect logs inside ContractEnvironment, doesn't depend on log level
     pcCollectLogs :: !Bool
   , pcBudgetMultiplier :: !Rational
+  , pcTxStatusPolling :: !TxStatusPolling
+  }
+  deriving stock (Show, Eq)
+
+{- | Settings for `Contract.awaitTxStatusChange` implementation.
+ See also `BotPlutusInterface.Contract.awaitTxStatusChange`
+-}
+data TxStatusPolling = TxStatusPolling
+  { -- | Interval between `chain-index` queries, microseconds
+    spInterval :: !Natural
+  , -- | 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)
 
@@ -240,6 +256,7 @@ instance Default PABConfig where
       , pcCollectStats = False
       , pcCollectLogs = False
       , pcBudgetMultiplier = 1
+      , pcTxStatusPolling = TxStatusPolling 1_000_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

@@ -3,7 +3,7 @@
 module Spec.BotPlutusInterface.Config (tests) where
 
 import BotPlutusInterface.Config (loadPABConfig, savePABConfig)
-import BotPlutusInterface.Types (CLILocation (..), LogLevel (..), PABConfig (..))
+import BotPlutusInterface.Types (CLILocation (..), LogLevel (..), PABConfig (..), TxStatusPolling (TxStatusPolling))
 import Cardano.Api (
   AnyPlutusScriptVersion (..),
   CostModel (..),
@@ -115,4 +115,5 @@ pabConfigExample =
     , pcCollectStats = False
     , pcCollectLogs = False
     , pcBudgetMultiplier = 1
+    , pcTxStatusPolling = TxStatusPolling 1_000_000 8
     }