From 0c319565bd97f6e7eea244cca6d0d00d84368e36 Mon Sep 17 00:00:00 2001 From: Emmanuel Denloye-Ito Date: Tue, 31 May 2022 15:19:04 -0400 Subject: [PATCH 1/5] Pre-date transaction creation time --- exec/MPT.hs | 10 +++--- exec/TXG.hs | 48 ++++++++++++++++------------ exec/TXG/Types.hs | 10 ++++++ lib/TXG/Repl.hs | 4 +-- lib/TXG/Simulate/Contracts/Common.hs | 14 ++++---- 5 files changed, 53 insertions(+), 33 deletions(-) diff --git a/exec/MPT.hs b/exec/MPT.hs index c096054..dd757d2 100644 --- a/exec/MPT.hs +++ b/exec/MPT.hs @@ -137,6 +137,7 @@ worker config = do , confGasPrice = mpt_gasPrice config , confTTL = mpt_timetolive config , confTrackMempoolStat = Nothing -- this will be ignored + , confRewindTime = 0 -- this will be ignored } cids <- newIORef $ NES.fromList $ NEL.fromList $ mpt_nodeChainIds config _ <- liftIO $ forkFinally (pollLoop cids (mpt_confirmationDepth config) (mpt_dbFile config) (mpt_pollDelay config) tcut trkeys cfg) $ either throwIO pure @@ -250,6 +251,7 @@ mkMPTConfig mdistribution manager mpt_config hostAddr = , confGasPrice = mpt_gasPrice mpt_config , confTTL = mpt_timetolive mpt_config , confTrackMempoolStat = Nothing -- this will be ignored + , confRewindTime = 0 -- this will be ignored } data ApiError = ApiError @@ -449,7 +451,7 @@ generateTransactions ifCoinOnlyTransfers isVerbose contractIndex = do mkTransferCaps rcvr amt $ acclookup sn CoinTransferAndCreate (SenderName acc) rcvr (Guard guardd) amt -> mkTransferCaps rcvr amt (acc, guardd) - meta <- Sim.makeMetaWithSender sender ttl gp gl cid + meta <- Sim.makeMetaWithSender sender ttl gp gl cid 0 (msg,) <$> createCoinContractRequest version meta ks coinContractRequest mkTransferCaps :: ReceiverName -> Sim.Amount -> (Sim.Account, NEL.NonEmpty SomeKeyPairCaps) -> (Sim.Account, NEL.NonEmpty SomeKeyPairCaps) @@ -469,10 +471,10 @@ generateTransactions ifCoinOnlyTransfers isVerbose contractIndex = do Nothing -> error "This account does not have an associated keyset!" Just keyset -> do - meta <- Sim.makeMeta cid ttl gp gl + meta <- Sim.makeMeta cid ttl gp gl 0 simplePayReq v meta paymentsRequest $ Just keyset SPRequestGetBalance _account -> do - meta <- Sim.makeMeta cid ttl gp gl + meta <- Sim.makeMeta cid ttl gp gl 0 simplePayReq v meta paymentsRequest Nothing _ -> error "SimplePayments.CreateAccount code generation not supported" @@ -492,7 +494,7 @@ coinTransfers nodekey config tv tcut trkeys cfg = do accountMap <- fmap (M.fromList . toList) . forM chains $ \cid -> do let f (Sim.Account sender) = do - !meta <- liftIO (Sim.makeMetaWithSender sender (confTTL cfg) (confGasPrice cfg) (confGasLimit cfg) cid) + !meta <- liftIO (Sim.makeMetaWithSender sender (confTTL cfg) (confGasPrice cfg) (confGasLimit cfg) cid 0) Sim.createCoinAccount (confVersion cfg) meta sender (coinKS, _coinAcc) <- liftIO $ unzip <$> traverse f Sim.coinAccountNames diff --git a/exec/TXG.hs b/exec/TXG.hs index a701d22..74b00a6 100644 --- a/exec/TXG.hs +++ b/exec/TXG.hs @@ -112,7 +112,8 @@ generateSimpleTransactions = do tGasLimit <- asks confGasLimit tGasPrice <- asks confGasPrice tTTL <- asks confTTL - (msgs, cmds) <- liftIO . fmap NEL.unzip . sequenceA . nelReplicate batch $ f tGasLimit tGasPrice tTTL cid v stdgen + tRewindTime <- asks confRewindTime + (msgs, cmds) <- liftIO . fmap NEL.unzip . sequenceA . nelReplicate batch $ f tGasLimit tGasPrice tTTL cid tRewindTime v stdgen -- Delay, so as not to hammer the network. delay <- generateDelay liftIO $ threadDelay delay @@ -123,10 +124,11 @@ generateSimpleTransactions = do -> GasPrice -> CM.TTLSeconds -> Sim.ChainId + -> Integer -> ChainwebVersion -> StdGen -> IO (Maybe Text, Command Text) - f gl gp ttl cid v stdgen = do + f gl gp ttl cid rt v stdgen = do let (operandA, operandB, op) = flip evalState stdgen $ do a <- state $ randomR (1, 100 :: Integer) b <- state $ randomR (1, 100 :: Integer) @@ -139,7 +141,7 @@ generateSimpleTransactions = do kps <- testSomeKeyPairs let theData = object ["test-admin-keyset" .= fmap (formatB16PubKey . fst) kps] - meta <- Sim.makeMeta cid ttl gp gl + meta <- Sim.makeMeta cid ttl gp gl rt (Nothing,) <$> mkExec (T.pack theCode) theData meta (NEL.toList kps) @@ -178,8 +180,9 @@ _generateXChainTransactions isVerbose = do tGasLimit <- asks confGasLimit tGasPrice <- asks confGasPrice tTTL <- asks confTTL + tRewindTime <- asks confRewindTime (mmsgs, cmds) <- liftIO . fmap NEL.unzip . sequenceA . nelReplicate batch $ - xChainTransfer tGasLimit tGasPrice tTTL version isVerbose sourceChain targetChain $ accounts "coin" accs + xChainTransfer tGasLimit tGasPrice tTTL tRewindTime version isVerbose sourceChain targetChain $ accounts "coin" accs generateDelay >>= liftIO . threadDelay pure (sourceChain, targetChain, mmsgs, cmds) where @@ -190,13 +193,14 @@ _generateXChainTransactions isVerbose = do :: GasLimit -> GasPrice -> CM.TTLSeconds + -> Integer -> ChainwebVersion -> Verbose -> Sim.ChainId -> Sim.ChainId -> Map Sim.Account (NEL.NonEmpty SomeKeyPairCaps) -> IO (Maybe Text, Command Text) - xChainTransfer gl gp ttl version (Verbose vb) sourceChain _targetChain coinaccts = do + xChainTransfer gl gp ttl rt version (Verbose vb) sourceChain _targetChain coinaccts = do coinContractRequest <- mkRandomCoinContractRequest True coinaccts >>= generate let msg = if vb then Just $ T.pack (show coinContractRequest) else Nothing let acclookup sn@(Sim.Account accsn) = @@ -211,7 +215,7 @@ _generateXChainTransactions isVerbose = do mkTransferCaps rcvr amt $ acclookup sn CoinTransferAndCreate (SenderName acc) rcvr (Guard guardd) amt -> mkTransferCaps rcvr amt (acc, guardd) - meta <- Sim.makeMetaWithSender sender ttl gp gl sourceChain + meta <- Sim.makeMetaWithSender sender ttl gp gl sourceChain rt (msg,) <$> createCoinContractRequest version meta ks coinContractRequest mkTransferCaps :: ReceiverName -> Sim.Amount -> (Sim.Account, NEL.NonEmpty SomeKeyPairCaps) -> (Sim.Account, NEL.NonEmpty SomeKeyPairCaps) @@ -243,11 +247,12 @@ generateTransactions ifCoinOnlyTransfers isVerbose contractIndex = do tGasLimit <- asks confGasLimit tGasPrice <- asks confGasPrice tTTL <- asks confTTL + tRewindTime <- asks confRewindTime (mmsgs, cmds) <- liftIO . fmap NEL.unzip . sequenceA . nelReplicate batch $ case contractIndex of - CoinContract -> coinContract tGasLimit tGasPrice tTTL version ifCoinOnlyTransfers isVerbose cid $ accounts "coin" accs + CoinContract -> coinContract tGasLimit tGasPrice tTTL version ifCoinOnlyTransfers isVerbose cid tRewindTime $ accounts "coin" accs HelloWorld -> (Nothing,) <$> (generate fake >>= helloRequest version) - Payments -> (Nothing,) <$> payments tGasLimit tGasPrice tTTL version cid (accounts "payment" accs) + Payments -> (Nothing,) <$> payments tGasLimit tGasPrice tTTL version cid tRewindTime (accounts "payment" accs) generateDelay >>= liftIO . threadDelay pure (cid, mmsgs, cmds) where @@ -262,9 +267,10 @@ generateTransactions ifCoinOnlyTransfers isVerbose contractIndex = do -> Bool -> Verbose -> Sim.ChainId + -> Integer -> Map Sim.Account (NEL.NonEmpty SomeKeyPairCaps) -> IO (Maybe Text, Command Text) - coinContract gl gp ttl version transfers (Verbose vb) cid coinaccts = do + coinContract gl gp ttl version transfers (Verbose vb) cid rt coinaccts = do coinContractRequest <- mkRandomCoinContractRequest transfers coinaccts >>= generate let msg = if vb then Just $ T.pack (show coinContractRequest) else Nothing let acclookup sn@(Sim.Account accsn) = @@ -279,7 +285,7 @@ generateTransactions ifCoinOnlyTransfers isVerbose contractIndex = do mkTransferCaps rcvr amt $ acclookup sn CoinTransferAndCreate (SenderName acc) rcvr (Guard guardd) amt -> mkTransferCaps rcvr amt (acc, guardd) - meta <- Sim.makeMetaWithSender sender ttl gp gl cid + meta <- Sim.makeMetaWithSender sender ttl gp gl cid rt (msg,) <$> createCoinContractRequest version meta ks coinContractRequest mkTransferCaps :: ReceiverName -> Sim.Amount -> (Sim.Account, NEL.NonEmpty SomeKeyPairCaps) -> (Sim.Account, NEL.NonEmpty SomeKeyPairCaps) @@ -291,18 +297,18 @@ generateTransactions ifCoinOnlyTransfers isVerbose contractIndex = do , PLiteral $ LString $ T.pack r , PLiteral $ LDecimal m] - payments :: GasLimit -> GasPrice -> CM.TTLSeconds -> ChainwebVersion -> Sim.ChainId -> Map Sim.Account (NEL.NonEmpty SomeKeyPairCaps) -> IO (Command Text) - payments gl gp ttl v cid paymentAccts = do + payments :: GasLimit -> GasPrice -> CM.TTLSeconds -> ChainwebVersion -> Sim.ChainId -> Integer -> Map Sim.Account (NEL.NonEmpty SomeKeyPairCaps) -> IO (Command Text) + payments gl gp ttl v cid rt paymentAccts = do paymentsRequest <- mkRandomSimplePaymentRequest paymentAccts >>= generate case paymentsRequest of SPRequestPay fromAccount _ _ -> case M.lookup fromAccount paymentAccts of Nothing -> error "This account does not have an associated keyset!" Just keyset -> do - meta <- Sim.makeMeta cid ttl gp gl + meta <- Sim.makeMeta cid ttl gp gl rt simplePayReq v meta paymentsRequest $ Just keyset SPRequestGetBalance _account -> do - meta <- Sim.makeMeta cid ttl gp gl + meta <- Sim.makeMeta cid ttl gp gl rt simplePayReq v meta paymentsRequest Nothing _ -> error "SimplePayments.CreateAccount code generation not supported" @@ -538,10 +544,10 @@ type ContractLoader loadContracts :: Args -> ChainwebHost -> NEL.NonEmpty ContractLoader -> IO () loadContracts config (ChainwebHost h _p2p service) contractLoaders = do - conf@(TXGConfig _ _ _ _ _ _ (Verbose vb) tgasLimit tgasPrice ttl' _trackMempoolStat) + conf@(TXGConfig _ _ _ _ _ _ (Verbose vb) tgasLimit tgasPrice ttl' _trackMempoolStat rt) <- mkTXGConfig Nothing config (HostAddress h service) forM_ (nodeChainIds config) $ \cid -> do - !meta <- Sim.makeMeta cid ttl' tgasPrice tgasLimit + !meta <- Sim.makeMeta cid ttl' tgasPrice tgasLimit rt ts <- testSomeKeyPairs contracts <- traverse (\f -> f meta ts) contractLoaders pollresponse <- runExceptT $ do @@ -591,7 +597,7 @@ realTransactions -> TimingDistribution -> LoggerT T.Text IO () realTransactions config (ChainwebHost h _p2p service) tcut tv distribution = do - cfg@(TXGConfig _ _ _ _ v _ _ tgasLimit tgasPrice ttl' _trackMempoolStat) + cfg@(TXGConfig _ _ _ _ v _ _ tgasLimit tgasPrice ttl' _trackMempoolStat rt) <- liftIO $ mkTXGConfig (Just distribution) config (HostAddress h service) let chains = maybe (versionChains $ nodeVersion config) NES.fromList @@ -599,7 +605,7 @@ realTransactions config (ChainwebHost h _p2p service) tcut tv distribution = do $ nodeChainIds config accountMap <- fmap (M.fromList . toList) . forM chains $ \cid -> do - !meta <- liftIO $ Sim.makeMeta cid ttl' tgasPrice tgasLimit + !meta <- liftIO $ Sim.makeMeta cid ttl' tgasPrice tgasLimit rt (paymentKS, paymentAcc) <- liftIO $ NEL.unzip <$> Sim.createPaymentsAccounts v meta (coinKS, coinAcc) <- liftIO $ NEL.unzip <$> Sim.createCoinAccounts v meta pollresponse <- liftIO . runExceptT $ do @@ -652,7 +658,7 @@ _realXChainCoinTransactions config (ChainwebHost h _p2p service) tv distribution $ nodeChainIds config accountMap <- fmap (M.fromList . toList) . forM chains $ \cid -> do let f (Sim.Account sender) = do - meta <- liftIO $ Sim.makeMetaWithSender sender (confTTL cfg) (confGasPrice cfg) (confGasLimit cfg) cid + meta <- liftIO $ Sim.makeMetaWithSender sender (confTTL cfg) (confGasPrice cfg) (confGasLimit cfg) cid (confRewindTime cfg) Sim.createCoinAccount (confVersion cfg) meta sender (coinKS, _coinAcc) <- liftIO $ unzip <$> traverse f Sim.coinAccountNames @@ -697,7 +703,7 @@ realCoinTransactions config (ChainwebHost h _p2p service) tcut tv distribution = accountMap <- fmap (M.fromList . toList) . forM chains $ \cid -> do let f (Sim.Account sender) = do - meta <- liftIO $ Sim.makeMetaWithSender sender (confTTL cfg) (confGasPrice cfg) (confGasLimit cfg) cid + meta <- liftIO $ Sim.makeMetaWithSender sender (confTTL cfg) (confGasPrice cfg) (confGasLimit cfg) cid (confRewindTime cfg) Sim.createCoinAccount (confVersion cfg) meta sender (coinKS, _coinAcc) <- liftIO $ unzip <$> traverse f Sim.coinAccountNames @@ -784,7 +790,7 @@ singleTransaction args (ChainwebHost h _p2p service) (SingleTX c cid) | otherwise = do cfg <- mkTXGConfig Nothing args (HostAddress h service) kps <- testSomeKeyPairs - meta <- Sim.makeMeta cid (confTTL cfg) (confGasPrice cfg) (confGasLimit cfg) + meta <- Sim.makeMeta cid (confTTL cfg) (confGasPrice cfg) (confGasLimit cfg) (confRewindTime cfg) let v = confVersion cfg cmd <- mkExec c (datum kps) meta (NEL.toList kps) diff --git a/exec/TXG/Types.hs b/exec/TXG/Types.hs index c9a6aae..6e674e9 100644 --- a/exec/TXG/Types.hs +++ b/exec/TXG/Types.hs @@ -203,6 +203,7 @@ data Args = Args , timetolive :: TTLSeconds , trackMempoolStatConfig :: !(Maybe PollParams) , confirmationDepth :: !Int + , rewindTime :: !Integer } deriving (Show, Generic) instance ToJSON Args where @@ -219,6 +220,7 @@ instance ToJSON Args where , "timetolive" .= timetolive o , "trackMempoolStatConfig" .= trackMempoolStatConfig o , "confirmationDepth" .= confirmationDepth o + , "rewindTime" .= rewindTime o ] instance FromJSON (Args -> Args) where @@ -235,6 +237,7 @@ instance FromJSON (Args -> Args) where <*< field @"timetolive" ..: "timetolive" % o <*< field @"trackMempoolStatConfig" ..: "trackMempoolStatConfig" %o <*< field @"confirmationDepth" ..: "confirmationDepth" %o + <*< field @"rewindTime" ..: "rewindTime" %o defaultArgs :: Args defaultArgs = Args @@ -250,6 +253,7 @@ defaultArgs = Args , timetolive = Sim.defTTL , trackMempoolStatConfig = Just defaultPollParams , confirmationDepth = 6 + , rewindTime = 60 * 2 -- 2 minutes } where v :: ChainwebVersion @@ -307,6 +311,10 @@ scriptConfigParser = id % long "confirmation-depth" <> metavar "INT" <> help "Confirmation depth" + <*< field @"rewindTime" .:: option auto + % long "rewind-time" + <> metavar "INT" + <> help "Number of seconds to pre-date transaction creation time" where read' :: Read a => String -> ReadM a read' msg = eitherReader (bimap (const msg) id . readEither) @@ -364,6 +372,7 @@ data TXGConfig = TXGConfig , confGasPrice :: GasPrice , confTTL :: TTLSeconds , confTrackMempoolStat :: !(Maybe PollParams) + , confRewindTime :: Integer } deriving (Generic) mkTXGConfig :: Maybe TimingDistribution -> Args -> HostAddress -> IO TXGConfig @@ -381,6 +390,7 @@ mkTXGConfig mdistribution config hostAddr = do , confGasPrice = gasPrice config , confTTL = timetolive config , confTrackMempoolStat = trackMempoolStatConfig config + , confRewindTime = rewindTime config } -- -------------------------------------------------------------------------- -- diff --git a/lib/TXG/Repl.hs b/lib/TXG/Repl.hs index 7c677b7..6316db9 100644 --- a/lib/TXG/Repl.hs +++ b/lib/TXG/Repl.hs @@ -333,10 +333,10 @@ _nw = unsafePerformIO $ mkNetwork _ver _hostAddr _cid {-# NOINLINE _nw #-} _metaIO :: IO PublicMeta -_metaIO = makeMeta _cid defTTL defGasPrice defGasLimit +_metaIO = makeMeta _cid defTTL defGasPrice defGasLimit 0 _metaIO' :: GasLimit -> IO PublicMeta -_metaIO' = makeMeta _cid defTTL defGasPrice +_metaIO' g = makeMeta _cid defTTL defGasPrice g 0 _cmd1IO :: IO (Command Text) _cmd1IO = do diff --git a/lib/TXG/Simulate/Contracts/Common.hs b/lib/TXG/Simulate/Contracts/Common.hs index 1f9c1fc..13cc8d5 100644 --- a/lib/TXG/Simulate/Contracts/Common.hs +++ b/lib/TXG/Simulate/Contracts/Common.hs @@ -45,6 +45,7 @@ import Data.Aeson import Data.Attoparsec.ByteString.Char8 import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as B8 +import Data.Coerce (coerce) import Data.Char import Data.Decimal import Data.FileEmbed @@ -61,6 +62,7 @@ import qualified Data.Yaml as Y import Fake import GHC.Generics import Pact.ApiReq (ApiKeyPair(..), mkExec, mkKeyPairs) +import Pact.Parse (ParsedInteger(..)) import qualified Pact.Types.ChainId as CM import qualified Pact.Types.ChainMeta as CM import Pact.Types.Command (Command(..), SomeKeyPairCaps) @@ -189,8 +191,8 @@ distinctPairsSendersOverList xs@(_first:_second:_rest) = do distinctPairsSendersOverList _ = error "distinctPairSendersOverList: Please give at least two accounts!" -- hardcoded sender (sender00) -makeMeta :: ChainId -> CM.TTLSeconds -> GasPrice -> GasLimit -> IO CM.PublicMeta -makeMeta cid ttl gasPrice gasLimit = do +makeMeta :: ChainId -> CM.TTLSeconds -> GasPrice -> GasLimit -> Integer -> IO CM.PublicMeta +makeMeta cid ttl gasPrice gasLimit rewindTime = do t <- currentTxTime return $ CM.PublicMeta { @@ -199,7 +201,7 @@ makeMeta cid ttl gasPrice gasLimit = do , CM._pmGasLimit = gasLimit , CM._pmGasPrice = gasPrice , CM._pmTTL = ttl - , CM._pmCreationTime = t + , CM._pmCreationTime = t + coerce rewindTime } defGasLimit :: GasLimit @@ -211,9 +213,9 @@ defGasPrice = 0.001 defTTL :: CM.TTLSeconds defTTL = 3600 -makeMetaWithSender :: String -> CM.TTLSeconds -> GasPrice -> GasLimit -> ChainId -> IO CM.PublicMeta -makeMetaWithSender sender ttl gasPrice gasLimit cid = - set CM.pmSender (T.pack sender) <$> makeMeta cid ttl gasPrice gasLimit +makeMetaWithSender :: String -> CM.TTLSeconds -> GasPrice -> GasLimit -> ChainId -> Integer -> IO CM.PublicMeta +makeMetaWithSender sender ttl gasPrice gasLimit cid rewindTime = + set CM.pmSender (T.pack sender) <$> makeMeta cid ttl gasPrice gasLimit rewindTime newtype ContractName = ContractName { getContractName :: String } deriving (Eq, Ord, Show, Generic) From cf8ac1935f669aafdbc0c62e5e92650ebe767c0d Mon Sep 17 00:00:00 2001 From: Emmanuel Denloye-Ito Date: Tue, 31 May 2022 21:19:23 -0400 Subject: [PATCH 2/5] use the right binary operator (duh!) --- lib/TXG/Simulate/Contracts/Common.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/TXG/Simulate/Contracts/Common.hs b/lib/TXG/Simulate/Contracts/Common.hs index 13cc8d5..ed29b09 100644 --- a/lib/TXG/Simulate/Contracts/Common.hs +++ b/lib/TXG/Simulate/Contracts/Common.hs @@ -201,7 +201,7 @@ makeMeta cid ttl gasPrice gasLimit rewindTime = do , CM._pmGasLimit = gasLimit , CM._pmGasPrice = gasPrice , CM._pmTTL = ttl - , CM._pmCreationTime = t + coerce rewindTime + , CM._pmCreationTime = t - coerce rewindTime } defGasLimit :: GasLimit From 8823af670433f1645278f630a589c9ab0d4002d7 Mon Sep 17 00:00:00 2001 From: Emmanuel Denloye-Ito Date: Thu, 9 Jun 2022 14:21:11 -0400 Subject: [PATCH 3/5] make retry policy better --- exec/TXG.hs | 13 ++++++++----- 1 file changed, 8 insertions(+), 5 deletions(-) diff --git a/exec/TXG.hs b/exec/TXG.hs index 74b00a6..295cab6 100644 --- a/exec/TXG.hs +++ b/exec/TXG.hs @@ -447,7 +447,10 @@ loop confDepth tcut f = forever $ do case confTrackMempoolStat config of Nothing -> pure () Just p -> do - let retrier = retrying policy (const (pure . isRight)) . const + let retrier = retrying policy (const retryIfPollEmptyAlso) . const + retryIfPollEmptyAlso = \case + Left s -> pure $ s == "Failure no result returned" + Right _ -> pure False policy :: RetryPolicyM IO policy = exponentialBackoff (pollExponentialBackoffInitTime p) @@ -510,10 +513,10 @@ data MempoolStat' = | TimeUntilConfirmationDepth TimeSpan instance Show MempoolStat' where - show = show . \case - TimeUntilMempoolAcceptance t -> t - TimeUntilBlockInclusion t -> t - TimeUntilConfirmationDepth t -> t + show = \case + TimeUntilMempoolAcceptance t -> "time-until-mempool-acceptance: " ++ show t + TimeUntilBlockInclusion t -> "time-until-block-inclusion: " ++ show t + TimeUntilConfirmationDepth t -> "time-until-confirmation-depth: " ++ show t getCurrentTimeInt64 :: IO Int64 getCurrentTimeInt64 = do From 831f1fcacd679a2fecfafbe835c621d9cd53bb8b Mon Sep 17 00:00:00 2001 From: Emmanuel Denloye-Ito Date: Thu, 9 Jun 2022 14:24:30 -0400 Subject: [PATCH 4/5] just show time elapsed in microseconds for TimeSpan --- exec/TXG.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/exec/TXG.hs b/exec/TXG.hs index 295cab6..5f3198a 100644 --- a/exec/TXG.hs +++ b/exec/TXG.hs @@ -505,7 +505,7 @@ data TimeSpan = TimeSpan , end_time :: Int64 } instance Show TimeSpan where - show (TimeSpan s e) = show (s,e) + show (TimeSpan s e) = printf "%d microseconds" $ e - s data MempoolStat' = TimeUntilMempoolAcceptance TimeSpan From fae15cd6b3eb3485f43058b746cdd746673f50aa Mon Sep 17 00:00:00 2001 From: Emmanuel Denloye-Ito Date: Mon, 13 Jun 2022 12:57:00 -0400 Subject: [PATCH 5/5] log errors while retrying poll --- exec/TXG.hs | 64 +++++++++++++++++++++++++++++++++++++++-------------- txg.cabal | 1 + 2 files changed, 48 insertions(+), 17 deletions(-) diff --git a/exec/TXG.hs b/exec/TXG.hs index 5f3198a..e4abb38 100644 --- a/exec/TXG.hs +++ b/exec/TXG.hs @@ -33,6 +33,7 @@ import Control.Lens hiding (op, (.=), (|>)) import Control.Monad.Except import Control.Monad.Reader hiding (local) import Control.Monad.State.Strict +import Control.Monad.Trans.Writer.CPS hiding (listen) import Control.Retry import Data.Aeson.Lens import Data.Generics.Product.Fields (field) @@ -50,6 +51,7 @@ import qualified Data.Map as M import Data.Maybe import Data.Sequence.NonEmpty (NESeq(..)) import qualified Data.Sequence.NonEmpty as NES +import Data.String (IsString(..)) import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as T @@ -422,6 +424,13 @@ _xChainLoop f = forever $ do lift . logg Info $ "Transaction request keys: " <> T.pack (show _xRequestKeys) +newtype RetryErrors = RetryErrors (HM.HashMap Text [Value]) + +instance Semigroup RetryErrors where + (RetryErrors o1) <> (RetryErrors o2) = RetryErrors $ HM.unionWith mappend o1 o2 + +instance Monoid RetryErrors where + mempty = RetryErrors mempty loop :: (MonadIO m, MonadLog T.Text m) @@ -449,35 +458,46 @@ loop confDepth tcut f = forever $ do Just p -> do let retrier = retrying policy (const retryIfPollEmptyAlso) . const retryIfPollEmptyAlso = \case - Left s -> pure $ s == "Failure no result returned" + Left jvalue -> case jvalue of + Object o -> do + tell $ RetryErrors $ fmap pure o + pure $ case HM.lookup "internalError" o of + Just "Failure no result returned" -> True + _ -> False + _ -> fail "impossible" Right _ -> pure False - policy :: RetryPolicyM IO policy = exponentialBackoff (pollExponentialBackoffInitTime p) <> limitRetries (pollRetries p) toChunker = toList . _rkRequestKeys forM_ (chunksOf (pollChunkSize p) $ toChunker rks) $ \chunk -> do - poll_result <- liftIO $ retrier $ pollRequestKeys' config cid (RequestKeys $ NEL.fromList chunk) + (poll_result,RetryErrors errs) <- liftIO $ runWriterT $ retrier $ liftIO $ pollRequestKeys' config cid (RequestKeys $ NEL.fromList chunk) case poll_result of - Left err -> lift $ logg Error $ T.pack $ printf "Caught this error while polling for these request keys (%s) %s" (show $ RequestKeys $ NEL.fromList chunk) err + Left err -> lift $ logg Error $ T.pack $ printf "Caught this error while polling for these request keys (%s) %s" (show $ RequestKeys $ NEL.fromList chunk) $ encodeToText err Right (poll_start,poll_end,result) -> iforM_ result $ \rk res -> do - logStat cid rk (TimeUntilMempoolAcceptance (TimeSpan {start_time = start, end_time = end})) - logStat cid rk (TimeUntilBlockInclusion (TimeSpan {start_time = poll_start, end_time = poll_end})) + -- display any errors that accumulated while retrying + iforM_ errs $ \k messages -> do + logStat cid rk (Left k) + forM_ messages $ logStat cid rk . Left . encodeToText + logStat cid rk (Right $ TimeUntilMempoolAcceptance (TimeSpan {start_time = start, end_time = end})) + logStat cid rk (Right $ TimeUntilBlockInclusion (TimeSpan {start_time = poll_start, end_time = poll_end})) let h = fromIntegral $ fromJuste $ res ^? _2 . key "blockHeight" . _Integer cstart <- liftIO getCurrentTimeInt64 cend <- liftIO $ withAsync (loopUntilConfirmationDepth confDepth cid h tcut) wait - logStat cid rk (TimeUntilConfirmationDepth (TimeSpan {start_time = cstart, end_time = cend})) + logStat cid rk (Right $ TimeUntilConfirmationDepth (TimeSpan {start_time = cstart, end_time = cend})) forM_ (Compose msgs) $ \m -> lift . logg Info $ "Actual transaction: " <> m -logStat :: (MonadTrans t, MonadLog Text m) => ChainId -> RequestKey -> MempoolStat' -> t m () -logStat cid rk ms = lift $ logg Info $ T.pack $ show $ MempoolStat - { - ms_chainid = cid - , ms_txhash = rk - , ms_stat = ms - } +logStat :: (MonadTrans t, MonadLog Text m) => ChainId -> RequestKey -> Either Text MempoolStat' -> t m () +logStat cid rk = \case + Right ms -> lift $ logg Info $ T.pack $ show $ MempoolStat + { + ms_chainid = cid + , ms_txhash = rk + , ms_stat = ms + } + Left other -> lift $ logg Info other type BlockHeight = Int @@ -531,16 +551,26 @@ trackTime act = do t2 <- getCurrentTimeInt64 return (r,t1,t2) -pollRequestKeys' :: TXGConfig -> ChainId -> RequestKeys -> IO (Either String (Int64, Int64, (HM.HashMap RequestKey (Maybe PactError, Value)))) +pollRequestKeys' + :: TXGConfig + -> ChainId + -> RequestKeys + -> IO (Either Value (Int64, Int64, (HM.HashMap RequestKey (Maybe PactError, Value)))) pollRequestKeys' cfg cid rkeys = do (response, start, end) <- trackTime $ pactPoll cfg cid rkeys case response of - Left _ -> pure $ Left "Failure" + Left (ClientError t) -> pure $ either (Left . internalError) Left $ eitherDecode @Value $ LB.fromStrict $ T.encodeUtf8 t Right (PollResponses as) - | null as -> pure $ Left "Failure no result returned" + | null as -> pure $ Left $ internalError @T.Text "Failure no result returned" | otherwise -> pure $ Right $ (start, end, fmap f as) where f cr = (either Just (const Nothing) $ _pactResult $ _crResult cr, fromJuste $ _crMetaData cr) + internalError :: (ToJSON s, IsString s) => s -> Value + internalError s = + object + [ + "internalError" .= s + ] type ContractLoader = CM.PublicMeta -> NEL.NonEmpty SomeKeyPairCaps -> IO (Command Text) diff --git a/txg.cabal b/txg.cabal index bd5d648..05a39d4 100644 --- a/txg.cabal +++ b/txg.cabal @@ -93,6 +93,7 @@ executable txg , split , string-conv >=0.1 , stm + , transformers , txg , yet-another-logger >=0.3