From 04746368aae82a0f8a79df25b09baf8d5eb2bb4f Mon Sep 17 00:00:00 2001 From: Mikhail Lazarev Date: Wed, 15 Jun 2022 17:51:50 +0300 Subject: [PATCH 1/7] wip: `waitTxStatusChange` rework - added chain-index polling interval and timeout - todo: config and tests --- src/BotPlutusInterface/Config.hs | 18 +++- src/BotPlutusInterface/Contract.hs | 115 ++++++++++++++++--------- src/BotPlutusInterface/Types.hs | 9 ++ test/Spec/BotPlutusInterface/Config.hs | 3 +- test/Spec/MockContract.hs | 4 +- 5 files changed, 103 insertions(+), 46 deletions(-) diff --git a/src/BotPlutusInterface/Config.hs b/src/BotPlutusInterface/Config.hs index 4aabbe84..e04f4dab 100644 --- a/src/BotPlutusInterface/Config.hs +++ b/src/BotPlutusInterface/Config.hs @@ -14,7 +14,7 @@ import BotPlutusInterface.Effects ( ShellArgs (..), callLocalCommand, ) -import BotPlutusInterface.Types (CLILocation (..), LogLevel (..), PABConfig (..)) +import BotPlutusInterface.Types (CLILocation (..), LogLevel (..), PABConfig (..), TxStatusPolling) import Cardano.Api (NetworkId (Mainnet, Testnet), unNetworkMagic) import Config (Section (Section), Value (Atom, Sections, Text)) @@ -74,6 +74,13 @@ logLevelSpec = Info <$ atomSpec "info" Debug <$ atomSpec "debug" +instance ToValue TxStatusPolling where + toValue = error "TODO: toValue TxStatusPolling" + +txStatusPollingSpec :: ValueSpec TxStatusPolling +txStatusPollingSpec = error "TODO: txStatusPollingSpec" + + {- ORMOLU_DISABLE -} instance ToValue PABConfig where toValue @@ -95,6 +102,7 @@ instance ToValue PABConfig where pcPort pcEnableTxEndpoint pcCollectStats + pcTxStausPolling ) = Sections () @@ -116,6 +124,7 @@ instance ToValue PABConfig where , Section () "port" $ toValue pcPort , Section () "enableTxEndpoint" $ toValue pcEnableTxEndpoint , Section () "collectStats" $ toValue pcCollectStats + , Section () "pcTxStausPolling" $ toValue pcTxStausPolling ] {- ORMOLU_ENABLE -} @@ -206,6 +215,13 @@ pabConfigSpec = sectionsSpec "PABConfig" $ do trueOrFalseSpec "Save some stats during contract run (only transactions execution budgets supported atm)" + pcTxStausPolling <- + sectionWithDefault' + (pcTxStausPolling def) + "pcTxStausPolling" + txStatusPollingSpec + (error "TODO: TxStatusPolling config help") + pure PABConfig {..} docPABConfig :: String diff --git a/src/BotPlutusInterface/Contract.hs b/src/BotPlutusInterface/Contract.hs index 02c3aa54..46c5ed00 100644 --- a/src/BotPlutusInterface/Contract.hs +++ b/src/BotPlutusInterface/Contract.hs @@ -24,7 +24,7 @@ import BotPlutusInterface.Effects ( saveBudget, slotToPOSIXTime, threadDelay, - uploadDir, + uploadDir ) import BotPlutusInterface.Files (DummyPrivKey (FromSKey, FromVKey)) import BotPlutusInterface.Files qualified as Files @@ -32,7 +32,7 @@ import BotPlutusInterface.Types ( ContractEnvironment (..), LogLevel (Debug, Warn), Tip (block, slot), - TxFile (Signed), + TxFile (Signed), spInterval, spBlocksTimeOut ) import Cardano.Api (AsType (..), EraInMode (..), Tx (Tx)) import Control.Lens (preview, (^.)) @@ -45,7 +45,6 @@ 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.HashMap.Strict qualified as HM import Data.Kind (Type) import Data.Map qualified as Map @@ -210,27 +209,59 @@ awaitTxStatusChange :: 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 + let txStatusPolling = contractEnv.cePABConfig.pcTxStausPolling + pollInterval = fromIntegral $ spInterval txStatusPolling + pollTimeOut = fromIntegral $ spBlocksTimeOut txStatusPolling + cutOffBlock <- (pollTimeOut +) <$> currentBlock contractEnv + printBpiLog @w Debug $ pretty $ "Awaiting status change for " ++ show txId + txStausCheckLoop txId contractEnv pollInterval cutOffBlock + +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 + 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 + return status + (Unknown, _) -> do + threadDelay @w pollInterval + txStausCheckLoop txId contractEnv pollInterval cutOffBlock + (status, _) -> return status where + -- | get Tx status with extensive debug logging + 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 $ "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 + queryChainIndexForTxState :: Eff effs (Maybe TxIdState) queryChainIndexForTxState = do mTx <- join . preview _TxIdResponse <$> (queryChainIndex @w $ TxFromTxId txId) @@ -355,25 +386,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. diff --git a/src/BotPlutusInterface/Types.hs b/src/BotPlutusInterface/Types.hs index 52f14c1b..a7938a80 100644 --- a/src/BotPlutusInterface/Types.hs +++ b/src/BotPlutusInterface/Types.hs @@ -22,6 +22,7 @@ module BotPlutusInterface.Types ( SpendBudgets, MintBudgets, ContractStats (..), + TxStatusPolling(..), addBudget, ) where @@ -83,6 +84,13 @@ data PABConfig = PABConfig , pcPort :: !Port , pcEnableTxEndpoint :: !Bool , pcCollectStats :: !Bool + , pcTxStausPolling :: !TxStatusPolling + } + deriving stock (Show, Eq) + +data TxStatusPolling = TxStatusPolling + { spInterval :: !Natural -- ^ mocroseconds + , spBlocksTimeOut :: !Natural -- ^ blocks until timeout, most likely `Unknown` state will be returned } deriving stock (Show, Eq) @@ -221,6 +229,7 @@ instance Default PABConfig where , pcPort = 9080 , pcEnableTxEndpoint = False , pcCollectStats = False + , pcTxStausPolling = TxStatusPolling 1_000 8 } data RawTx = RawTx diff --git a/test/Spec/BotPlutusInterface/Config.hs b/test/Spec/BotPlutusInterface/Config.hs index f940bfba..287bdee6 100644 --- a/test/Spec/BotPlutusInterface/Config.hs +++ b/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 (..), @@ -113,4 +113,5 @@ pabConfigExample = , pcPort = 1021 , pcEnableTxEndpoint = True , pcCollectStats = False + , pcTxStausPolling = TxStatusPolling 1_000 8 } diff --git a/test/Spec/MockContract.hs b/test/Spec/MockContract.hs index bbf75a7a..5dd4d592 100644 --- a/test/Spec/MockContract.hs +++ b/test/Spec/MockContract.hs @@ -330,8 +330,8 @@ runPABEffectPure initState req = incTip Tip {tipSlot, tipBlockId, tipBlockNo} = Tip { tipSlot = tipSlot + 1 - , tipBlockId = tipBlockId - , tipBlockNo = tipBlockNo + , tipBlockId = tipBlockId -- FIXME: will need that for testing await status timeout probably + , tipBlockNo = tipBlockNo -- FIXME: will need that for testing await status timeout probably } mockCallCommand :: From d8d4b53c70861b970161f3cbb889ef9fdaaaa0c5 Mon Sep 17 00:00:00 2001 From: Mikhail Lazarev Date: Thu, 16 Jun 2022 17:33:41 +0300 Subject: [PATCH 2/7] wip: waitTxStatusChange rework - tests added - config spec added - bugs fixed - todo: docs, refactoring, testnet tests --- bot-plutus-interface.cabal | 1 + src/BotPlutusInterface/Config.hs | 45 ++++++++--- src/BotPlutusInterface/Contract.hs | 55 +++++++------ src/BotPlutusInterface/Types.hs | 12 +-- test/Spec.hs | 2 + test/Spec/BotPlutusInterface/Config.hs | 2 +- .../Spec/BotPlutusInterface/TxStatusChange.hs | 78 +++++++++++++++++++ test/Spec/MockContract.hs | 65 +++++++++------- 8 files changed, 193 insertions(+), 67 deletions(-) create mode 100644 test/Spec/BotPlutusInterface/TxStatusChange.hs diff --git a/bot-plutus-interface.cabal b/bot-plutus-interface.cabal index 91ac578c..cb8fd978 100644 --- a/bot-plutus-interface.cabal +++ b/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 diff --git a/src/BotPlutusInterface/Config.hs b/src/BotPlutusInterface/Config.hs index e04f4dab..3e4566ab 100644 --- a/src/BotPlutusInterface/Config.hs +++ b/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 diff --git a/src/BotPlutusInterface/Contract.hs b/src/BotPlutusInterface/Contract.hs index 46c5ed00..dc141109 100644 --- a/src/BotPlutusInterface/Contract.hs +++ b/src/BotPlutusInterface/Contract.hs @@ -24,7 +24,7 @@ import BotPlutusInterface.Effects ( saveBudget, slotToPOSIXTime, threadDelay, - uploadDir + uploadDir, ) import BotPlutusInterface.Files (DummyPrivKey (FromSKey, FromVKey)) import BotPlutusInterface.Files qualified as Files @@ -32,7 +32,9 @@ 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]). diff --git a/src/BotPlutusInterface/Types.hs b/src/BotPlutusInterface/Types.hs index a7938a80..474f6637 100644 --- a/src/BotPlutusInterface/Types.hs +++ b/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 diff --git a/test/Spec.hs b/test/Spec.hs index 85280d32..839f5cf3 100644 --- a/test/Spec.hs +++ b/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 ] diff --git a/test/Spec/BotPlutusInterface/Config.hs b/test/Spec/BotPlutusInterface/Config.hs index 287bdee6..3c617c64 100644 --- a/test/Spec/BotPlutusInterface/Config.hs +++ b/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 } diff --git a/test/Spec/BotPlutusInterface/TxStatusChange.hs b/test/Spec/BotPlutusInterface/TxStatusChange.hs new file mode 100644 index 00000000..28f1b3d4 --- /dev/null +++ b/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 diff --git a/test/Spec/MockContract.hs b/test/Spec/MockContract.hs index 5dd4d592..83c325a5 100644 --- a/test/Spec/MockContract.hs +++ b/test/Spec/MockContract.hs @@ -45,6 +45,7 @@ module Spec.MockContract ( tip, utxos, mockBudget, + nonExistingTxId, ) where import BotPlutusInterface.CardanoCLI (unsafeSerialiseAddress) @@ -91,7 +92,9 @@ import Control.Monad.Freer.State (State, get, modify, runState) import Data.Aeson (Result (Success), ToJSON) import Data.Aeson qualified as JSON import Data.Aeson.Extras (encodeByteString) +import Data.Bool (bool) import Data.ByteString qualified as ByteString +import Data.ByteString.Char8 qualified as BS import Data.Default (Default (def)) import Data.Either.Combinators (fromRight, mapLeft) import Data.Hex (hex, unhex) @@ -183,6 +186,9 @@ addr1 = unsafeSerialiseAddress Mainnet (Ledger.pubKeyHashAddress paymentPkh1 Not addr2 = unsafeSerialiseAddress Mainnet (Ledger.pubKeyHashAddress paymentPkh2 Nothing) addr3 = unsafeSerialiseAddress Mainnet (Ledger.pubKeyHashAddress paymentPkh3 Nothing) +nonExistingTxId :: TxId +nonExistingTxId = TxId "ff" + skeyToPubKey :: SigningKey PaymentKey -> PubKey skeyToPubKey = Ledger.toPublicKey @@ -327,12 +333,16 @@ runPABEffectPure initState req = mc <* modify @(MockContractState w) (tip %~ incTip) incTip TipAtGenesis = Tip 1 (BlockId "00") 0 - incTip Tip {tipSlot, tipBlockId, tipBlockNo} = - Tip - { tipSlot = tipSlot + 1 - , tipBlockId = tipBlockId -- FIXME: will need that for testing await status timeout probably - , tipBlockNo = tipBlockNo -- FIXME: will need that for testing await status timeout probably - } + incTip Tip {tipSlot, tipBlockNo} = + let nextSlot = succ tipSlot + -- new block each 3 slots + newBlock = + tipBlockNo & bool id succ (nextSlot `mod` 3 == 0) + in Tip + { tipSlot = nextSlot + , tipBlockId = BlockId . BS.pack . show $ newBlock + , tipBlockNo = newBlock + } mockCallCommand :: forall (w :: Type) (a :: Type). @@ -556,24 +566,26 @@ mockQueryChainIndex = \case TxOutFromRef txOutRef -> do state <- get @(MockContractState w) pure $ TxOutRefResponse $ Tx.fromTxOut =<< lookup txOutRef (state ^. utxos) - TxFromTxId txId -> 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 -> 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 + } UtxoSetMembership _ -> throwError @Text "UtxoSetMembership is unimplemented" UtxoSetAtAddress pageQuery _ -> do @@ -608,8 +620,9 @@ mockQueryChainIndex = \case } TxoSetAtAddress _ _ -> throwError @Text "TxoSetAtAddress is unimplemented" - GetTip -> - throwError @Text "GetTip is unimplemented" + GetTip -> do + state <- get @(MockContractState w) + pure $ GetTipResponse (state ^. tip) -- | Fills in gaps of inputs with garbage TxOuts, so that the indexes we know about are in the correct positions buildOutputsFromKnownUTxOs :: [(TxOutRef, TxOut)] -> TxId -> ChainIndexTxOutputs From c8e1c179b39fb652706d876cdfa46dba38fbfd82 Mon Sep 17 00:00:00 2001 From: Mikhail Lazarev Date: Fri, 17 Jun 2022 14:29:42 +0300 Subject: [PATCH 3/7] clarification comment about hardcoded epoch slots --- src/BotPlutusInterface/QueryNode.hs | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/src/BotPlutusInterface/QueryNode.hs b/src/BotPlutusInterface/QueryNode.hs index 3b623870..7a283cea 100644 --- a/src/BotPlutusInterface/QueryNode.hs +++ b/src/BotPlutusInterface/QueryNode.hs @@ -77,11 +77,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 From 575ba8d518a081f8f09cb0ef6cd2ccce2cbeba78 Mon Sep 17 00:00:00 2001 From: Mikhail Lazarev Date: Fri, 17 Jun 2022 16:02:30 +0300 Subject: [PATCH 4/7] waitTxStatusChange rework - docs - clenaup - testnet tested --- src/BotPlutusInterface/Config.hs | 6 +- src/BotPlutusInterface/Contract.hs | 65 +++++++++---------- src/BotPlutusInterface/Types.hs | 10 ++- .../Spec/BotPlutusInterface/TxStatusChange.hs | 43 ++++++++---- test/Spec/MockContract.hs | 39 ++++++----- 5 files changed, 93 insertions(+), 70 deletions(-) diff --git a/src/BotPlutusInterface/Config.hs b/src/BotPlutusInterface/Config.hs index 3e4566ab..efe3999c 100644 --- a/src/BotPlutusInterface/Config.hs +++ b/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 diff --git a/src/BotPlutusInterface/Contract.hs b/src/BotPlutusInterface/Contract.hs index dc141109..748159af 100644 --- a/src/BotPlutusInterface/Contract.hs +++ b/src/BotPlutusInterface/Contract.hs @@ -47,6 +47,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.Function (fix) import Data.HashMap.Strict qualified as HM import Data.Kind (Type) import Data.Map qualified as Map @@ -54,7 +55,6 @@ 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,6 +205,14 @@ 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 => @@ -212,42 +220,34 @@ awaitTxStatusChange :: 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 :: diff --git a/src/BotPlutusInterface/Types.hs b/src/BotPlutusInterface/Types.hs index 474f6637..911a539b 100644 --- a/src/BotPlutusInterface/Types.hs +++ b/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) diff --git a/test/Spec/BotPlutusInterface/TxStatusChange.hs b/test/Spec/BotPlutusInterface/TxStatusChange.hs index 28f1b3d4..0bf4b045 100644 --- a/test/Spec/BotPlutusInterface/TxStatusChange.hs +++ b/test/Spec/BotPlutusInterface/TxStatusChange.hs @@ -2,10 +2,10 @@ 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 @@ -13,12 +13,15 @@ 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,15 +55,16 @@ 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 @@ -67,12 +72,28 @@ 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 diff --git a/test/Spec/MockContract.hs b/test/Spec/MockContract.hs index 83c325a5..e7467048 100644 --- a/test/Spec/MockContract.hs +++ b/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 From e741f66d13d6187c1c0f91f1b2e8a236ccd0ef50 Mon Sep 17 00:00:00 2001 From: Mikhail Lazarev Date: Mon, 20 Jun 2022 13:45:15 +0300 Subject: [PATCH 5/7] resolving review comments --- src/BotPlutusInterface/Config.hs | 2 +- src/BotPlutusInterface/Contract.hs | 15 ++++----------- test/Spec/BotPlutusInterface/TxStatusChange.hs | 2 +- 3 files changed, 6 insertions(+), 13 deletions(-) diff --git a/src/BotPlutusInterface/Config.hs b/src/BotPlutusInterface/Config.hs index 49cc8b2c..dcb7ca6c 100644 --- a/src/BotPlutusInterface/Config.hs +++ b/src/BotPlutusInterface/Config.hs @@ -94,7 +94,7 @@ txStatusPollingSpec = sectionsSpec "TxStatusPolling configuration" $ do spInterval <- reqSection' - "milliseconds" + "microseconds" naturalSpec "Interval between chain-index queries for transactions status change detection" spBlocksTimeOut <- diff --git a/src/BotPlutusInterface/Contract.hs b/src/BotPlutusInterface/Contract.hs index 748159af..1a3fc2ca 100644 --- a/src/BotPlutusInterface/Contract.hs +++ b/src/BotPlutusInterface/Contract.hs @@ -33,8 +33,6 @@ import BotPlutusInterface.Types ( LogLevel (Debug, Warn), Tip (block, slot), TxFile (Signed), - -- spBlocksTimeOut, - -- spInterval, ) import Cardano.Api (AsType (..), EraInMode (..), Tx (Tx)) import Control.Lens (preview, (^.)) @@ -233,15 +231,10 @@ awaitTxStatusChange contractEnv txId = do 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 + 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 diff --git a/test/Spec/BotPlutusInterface/TxStatusChange.hs b/test/Spec/BotPlutusInterface/TxStatusChange.hs index 0bf4b045..6b037488 100644 --- a/test/Spec/BotPlutusInterface/TxStatusChange.hs +++ b/test/Spec/BotPlutusInterface/TxStatusChange.hs @@ -64,7 +64,7 @@ testTxFoundAndConfirmed = do case runContractPure contract initState of (Left err, _) -> assertFailure $ Text.unpack err - (Right Unknown, _) -> assertFailure "State should not be Unknown" + (Right Unknown, _) -> assertFailure "Tx status should not be Unknown but it is" (Right _, _) -> pure () testStopWaitingByTimeout :: Assertion From 7febab011d8437f41cedc1c73c4e78bf02ab9b64 Mon Sep 17 00:00:00 2001 From: Mikhail Lazarev Date: Mon, 20 Jun 2022 14:19:57 +0300 Subject: [PATCH 6/7] small example fix --- test/Spec/BotPlutusInterface/Config.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/Spec/BotPlutusInterface/Config.hs b/test/Spec/BotPlutusInterface/Config.hs index cd53cd2e..ee846bfe 100644 --- a/test/Spec/BotPlutusInterface/Config.hs +++ b/test/Spec/BotPlutusInterface/Config.hs @@ -115,5 +115,5 @@ pabConfigExample = , pcCollectStats = False , pcCollectLogs = False , pcBudgetMultiplier = 1 - , pcTxStatusPolling = TxStatusPolling 1_000 8 + , pcTxStatusPolling = TxStatusPolling 1_000_000 8 } From bcea30f4163b0eb5e9cfcf4bf1140cfa0af4ab46 Mon Sep 17 00:00:00 2001 From: Mikhail Lazarev Date: Wed, 22 Jun 2022 12:00:49 +0300 Subject: [PATCH 7/7] keep precision for posix to utc conversion --- src/BotPlutusInterface/TimeSlot.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/BotPlutusInterface/TimeSlot.hs b/src/BotPlutusInterface/TimeSlot.hs index f0a9aba2..3cc1a2de 100644 --- a/src/BotPlutusInterface/TimeSlot.hs +++ b/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 --