From f07e9d9f19deb881808e3d123eb624b75c9ed2bc Mon Sep 17 00:00:00 2001 From: shum Date: Thu, 22 Oct 2026 00:27:42 +0000 Subject: [PATCH] store: send the registrar key's transactions --- .../src/StoreService/Names/Env.hs | 8 +- .../src/StoreService/Names/Sender.hs | 273 +++++++++++++++++ simplex-chat.cabal | 3 + tests/Bots/StoreService/NamesSenderTests.hs | 284 ++++++++++++++++++ tests/Bots/StoreService/NamesStoreTests.hs | 2 +- tests/Test.hs | 2 + 6 files changed, 569 insertions(+), 3 deletions(-) create mode 100644 apps/simplex-store-service/src/StoreService/Names/Sender.hs create mode 100644 tests/Bots/StoreService/NamesSenderTests.hs diff --git a/apps/simplex-store-service/src/StoreService/Names/Env.hs b/apps/simplex-store-service/src/StoreService/Names/Env.hs index a8c4442618..9011cf035c 100644 --- a/apps/simplex-store-service/src/StoreService/Names/Env.hs +++ b/apps/simplex-store-service/src/StoreService/Names/Env.hs @@ -2,6 +2,7 @@ module StoreService.Names.Env (NamesEnv (..), newNamesEnv) where +import Data.Time.Clock (getCurrentTime) import Simplex.Chat.Controller (ChatController (..)) import Simplex.Messaging.Agent.Protocol (UserId) import Simplex.Messaging.Agent.Store.Common (DBStore) @@ -9,6 +10,7 @@ import StoreService.Config (NamesConfig (..)) import StoreService.Names.Chain (ChainClient, newChainClient) import StoreService.Names.Phases (Phases, newPhases) import StoreService.Names.Profiles (Profiles, chatProfile, defaultProfileLimits, monotonicSeconds, newProfiles, systemResolver) +import StoreService.Names.Sender (Sender, newSender) import StoreService.Names.Turns (Turns, newTurns) data NamesEnv = NamesEnv @@ -19,7 +21,8 @@ data NamesEnv = NamesEnv nePhases :: Phases, neTurns :: Turns, neChain :: ChainClient, - neProfiles :: Profiles + neProfiles :: Profiles, + neSender :: Sender } newNamesEnv :: ChatController -> UserId -> NamesConfig -> DBStore -> IO NamesEnv @@ -28,4 +31,5 @@ newNamesEnv neChat@ChatController {random} neUserId neConfig@NamesConfig {nChain neTurns <- newTurns neChain <- newChainClient random nChain neProfiles <- newProfiles defaultProfileLimits monotonicSeconds (chatProfile neChat neUserId) systemResolver - pure NamesEnv {neChat, neUserId, neConfig, neStore, nePhases, neTurns, neChain, neProfiles} + neSender <- newSender random neChain neStore getCurrentTime + pure NamesEnv {neChat, neUserId, neConfig, neStore, nePhases, neTurns, neChain, neProfiles, neSender} diff --git a/apps/simplex-store-service/src/StoreService/Names/Sender.hs b/apps/simplex-store-service/src/StoreService/Names/Sender.hs new file mode 100644 index 0000000000..c0a6002d8a --- /dev/null +++ b/apps/simplex-store-service/src/StoreService/Names/Sender.hs @@ -0,0 +1,273 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} + +-- | Every transaction of the registrar key, sent once and in nonce order. +module StoreService.Names.Sender + ( Sender, + SendError (..), + TxOutcome (..), + PendingTx, + ptHash, + ptNonce, + newSender, + submitTransaction, + inFlightTransaction, + awaitOutcome, + followTransactions, + runSender, + replaceAfter, + ) +where + +import Control.Concurrent (threadDelay) +import Control.Concurrent.MVar (MVar, newMVar, withMVar) +import Control.Concurrent.STM +import Control.Exception (throwIO) +import Control.Monad (forM, forM_, forever, unless, void, when) +import Control.Monad.Except (ExceptT (..), runExceptT, throwError, withExceptT) +import Control.Monad.IO.Class (liftIO) +import Crypto.Random (ChaChaDRG) +import Data.ByteString (ByteString) +import Data.List (find) +import Data.List.NonEmpty (NonEmpty (..), (<|)) +import qualified Data.List.NonEmpty as L +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as M +import Data.Maybe (fromMaybe) +import qualified Data.Text as T +import Data.Time.Clock (NominalDiffTime, UTCTime, addUTCTime) +import Data.Word (Word64) +import Simplex.Messaging.Agent.Store.Common (DBStore, withTransaction) +import Simplex.Messaging.Eth.Address (Address) +import Simplex.Messaging.Util (tshow) +import StoreService.Config (ChainConfig (..)) +import StoreService.Log (logError, logInfo, logWarn) +import StoreService.Names.Chain +import StoreService.Names.Store (NameTransaction (..), NewTransaction (..), TxFor, TxStatus (..), insertTransaction, pendingTransactions, recordTransactionOutcome) +import StoreService.Store.Invoices (StoreDecodeError (..)) + +data Sender = Sender + { snChain :: ChainClient, + snRandom :: TVar ChaChaDRG, + snStore :: DBStore, + snNow :: IO UTCTime, + -- | MVar wakes its waiters in FIFO order, so new transactions take their nonces in the order they came. + snQueue :: MVar (), + -- | Above every nonce this sender saved. + snNextNonce :: TVar Word64, + snInFlight :: TVar (Map Word64 InFlight) + } + +-- | The signatures for one registrar nonce: the first, then each fee-bumped replacement. +data InFlight = InFlight + { ifFor :: TxFor, + ifRequest :: TxRequest, + ifRaw :: ByteString, + -- | newest first + ifHashes :: NonEmpty TxHash, + ifReplaceAt :: UTCTime, + -- | the block at which the nonce was first seen used with no receipt for any hash + ifUsedSince :: Maybe Word64, + ifOutcome :: TMVar TxOutcome + } + +-- | Nothing was signed or saved. +data SendError + = -- | the dry run reverted, its gas is above the cap, or the chain did not answer + SEChain ChainError + | SESigning String + | -- | this registration's or edit's transaction of this kind is still in flight + SEInFlight + deriving (Eq, Show) + +-- | Settled at the configured confirmation depth. +data TxOutcome + = TOConfirmed TxHash Receipt + | -- | The registrar nonce is used and none of its hashes has a receipt: a pruned receipt or another transaction. + -- The sender signs nothing more for it; its owner judges it from chain state. + TONonceUsed + deriving (Eq, Show) + +data PendingTx = PendingTx + { -- | the newest signature's hash + ptHash :: TxHash, + ptNonce :: Word64, + ptOutcome :: TMVar TxOutcome + } + +-- | 15 blocks: a transaction still not mined by then is replaced if the market's fees have passed its own. +replaceAfter :: NominalDiffTime +replaceAfter = 180 + +followInterval :: Int +followInterval = 4000000 + +-- | The max fee covers six full blocks in a row, each raising the base fee by 12.5%. +baseFeeHeadroom :: Word64 +baseFeeHeadroom = 2 + +-- | Nodes accept a replacement only with both fees at least 10% higher. +bumped :: Word64 -> Word64 +bumped fee = fee + fee `div` 8 + 1 + +-- | Resumes every saved transaction without a receipt. Owners resuming after a restart find theirs with 'inFlightTransaction'. +newSender :: TVar ChaChaDRG -> ChainClient -> DBStore -> IO UTCTime -> IO Sender +newSender snRandom snChain snStore snNow = do + saved <- withTransaction snStore pendingTransactions + inFlight <- M.fromList <$> mapM resumed (L.groupWith ntNonce saved) + snQueue <- newMVar () + snNextNonce <- newTVarIO $ maybe 0 ((+ 1) . fst) $ M.lookupMax inFlight + snInFlight <- newTVarIO inFlight + pure Sender {snChain, snRandom, snStore, snNow, snQueue, snNextNonce, snInFlight} + where + resumed txs = do + let NameTransaction {ntFor, ntNonce, ntRaw, ntSentAt} = L.last txs + request <- either (throwIO . StoreDecodeError . ("name_transactions.raw: " <>) . T.pack) pure $ decodeSignedTx ntRaw + outcome <- newEmptyTMVarIO + pure + ( ntNonce, + InFlight + { ifFor = ntFor, + ifRequest = request, + ifRaw = ntRaw, + ifHashes = L.reverse $ L.map ntHash txs, + ifReplaceAt = addUTCTime replaceAfter ntSentAt, + ifUsedSince = Nothing, + ifOutcome = outcome + } + ) + +-- | Dry run, the next nonce, the market's fees, the signature, saved, then sent. A failed send is retried by 'followTransactions'. +submitTransaction :: Sender -> TxFor -> Address -> ByteString -> IO (Either SendError PendingTx) +submitTransaction Sender {snChain = c@ChainClient {ccRegistrar}, snRandom, snStore, snNow, snQueue, snNextNonce, snInFlight} for to calldata = + withMVar snQueue $ \_ -> runExceptT $ do + busy <- any ((== for) . ifFor) <$> liftIO (readTVarIO snInFlight) + when busy $ throwError SEInFlight + gas <- chain $ estimateGas c to calldata + used <- chain $ transactionCount c ccRegistrar Latest + nonce <- max used <$> liftIO (readTVarIO snNextNonce) + (tip, maxFee) <- chain $ marketFees c + let request = TxRequest {trTo = to, trData = calldata, trNonce = nonce, trGasLimit = gas, trMaxFeePerGas = maxFee, trMaxPriorityFeePerGas = tip} + SignedTx {stRaw, stHash} <- withExceptT SESigning $ ExceptT $ signTransaction snRandom c request + liftIO $ do + now <- snNow + saveTransaction snStore for stRaw stHash nonce now + outcome <- newEmptyTMVarIO + atomically $ do + writeTVar snNextNonce $ nonce + 1 + modifyTVar' snInFlight $ + M.insert nonce InFlight {ifFor = for, ifRequest = request, ifRaw = stRaw, ifHashes = stHash :| [], ifReplaceAt = addUTCTime replaceAfter now, ifUsedSince = Nothing, ifOutcome = outcome} + broadcast c nonce stRaw + pure PendingTx {ptHash = stHash, ptNonce = nonce, ptOutcome = outcome} + where + chain = withExceptT SEChain . ExceptT + +inFlightTransaction :: Sender -> TxFor -> IO (Maybe PendingTx) +inFlightTransaction Sender {snInFlight} for = + fmap pending . find ((== for) . ifFor . snd) . M.toList <$> readTVarIO snInFlight + where + pending (nonce, InFlight {ifHashes, ifOutcome}) = PendingTx {ptHash = L.head ifHashes, ptNonce = nonce, ptOutcome = ifOutcome} + +awaitOutcome :: PendingTx -> IO TxOutcome +awaitOutcome = atomically . readTMVar . ptOutcome + +runSender :: Sender -> IO () +runSender s = forever $ followTransactions s >> threadDelay followInterval + +-- | One round over the transactions in flight, lowest nonce first. Only one thread may run it. +followTransactions :: Sender -> IO () +followTransactions s@Sender {snChain = c@ChainClient {ccRegistrar}, snInFlight} = do + inFlight <- readTVarIO snInFlight + unless (M.null inFlight) $ + runExceptT ((,) <$> ExceptT (latestBlock c) <*> ExceptT (transactionCount c ccRegistrar Latest)) >>= \case + Left e -> logWarn $ "names sender: " <> tshow e + Right (Block {blockNumber}, used) -> forM_ (M.toAscList inFlight) $ uncurry $ follow s blockNumber used + +follow :: Sender -> Word64 -> Word64 -> Word64 -> InFlight -> IO () +follow s@Sender {snChain = c@ChainClient {ccConfig = ChainConfig {cConfirmations}}} latest used nonce tx@InFlight {ifHashes, ifUsedSince} = + runExceptT (forM (L.toList ifHashes) $ \h -> (h,) <$> ExceptT (transactionReceipt c h)) >>= \case + Left e -> logWarn $ "names sender: nonce " <> tshow nonce <> ": " <> tshow e + Right receipts -> case [(h, r) | (h, Just r) <- receipts] of + (h, r@Receipt {receiptBlock}) : _ + | deep receiptBlock -> settle s nonce tx $ TOConfirmed h r + | otherwise -> update s nonce $ \t -> t {ifUsedSince = Nothing} + [] + | nonce < used -> do + let since = fromMaybe latest ifUsedSince + if deep since then settle s nonce tx TONonceUsed else update s nonce $ \t -> t {ifUsedSince = Just since} + | otherwise -> do + update s nonce $ \t -> t {ifUsedSince = Nothing} + resend s nonce tx + where + deep block = latest + 1 >= block + fromIntegral cConfirmations + +-- | A replacement when one is due and the market asks for it; otherwise the newest signature again if the node does not know it. +resend :: Sender -> Word64 -> InFlight -> IO () +resend s@Sender {snChain = c, snNow} nonce tx@InFlight {ifRaw, ifHashes = newest :| _, ifReplaceAt} = do + now <- snNow + replaced <- if now >= ifReplaceAt then replace s nonce tx now else pure False + unless replaced $ + transactionByHash c newest >>= \case + Right Nothing -> do + logInfo $ "names sender: rebroadcasting nonce " <> tshow nonce + broadcast c nonce ifRaw + Right (Just _) -> pure () + Left e -> logWarn $ "names sender: nonce " <> tshow nonce <> ": " <> tshow e + +replace :: Sender -> Word64 -> InFlight -> UTCTime -> IO Bool +replace s@Sender {snChain = c, snRandom, snStore} nonce InFlight {ifFor, ifRequest = old@TxRequest {trMaxFeePerGas, trMaxPriorityFeePerGas}} now = + marketFees c >>= \case + Left e -> False <$ logWarn ("names sender: nonce " <> tshow nonce <> ": " <> tshow e) + Right (tip, maxFee) + | tip <= trMaxPriorityFeePerGas && maxFee <= trMaxFeePerGas -> False <$ update s nonce (\t -> t {ifReplaceAt = later}) + | otherwise -> do + let maxFee' = max maxFee $ bumped trMaxFeePerGas + request = old {trMaxPriorityFeePerGas = max tip $ bumped trMaxPriorityFeePerGas, trMaxFeePerGas = maxFee'} + signTransaction snRandom c request >>= \case + Left e -> False <$ logError ("names sender: replacement for nonce " <> tshow nonce <> " not signed: " <> T.pack e) + Right SignedTx {stRaw, stHash} -> do + saveTransaction snStore ifFor stRaw stHash nonce now + update s nonce $ \t -> t {ifRequest = request, ifRaw = stRaw, ifHashes = stHash <| ifHashes t, ifReplaceAt = later} + logInfo $ "names sender: replacing nonce " <> tshow nonce <> " at max fee " <> tshow maxFee' + True <$ broadcast c nonce stRaw + where + later = addUTCTime replaceAfter now + +-- | The confirmed hash gets its receipt's status; every other hash of the nonce can no longer be mined. +settle :: Sender -> Word64 -> InFlight -> TxOutcome -> IO () +settle Sender {snStore, snInFlight} nonce InFlight {ifHashes, ifOutcome} outcome = do + withTransaction snStore $ \db -> forM_ ifHashes $ \h -> recordTransactionOutcome db h TSPending (status h) (block h) + when (outcome == TONonceUsed) $ + logWarn $ "names sender: nonce " <> tshow nonce <> " used with no receipt for its transactions; its owner judges it from chain state" + atomically $ do + modifyTVar' snInFlight $ M.delete nonce + putTMVar ifOutcome outcome + where + status h = case outcome of + TOConfirmed mined Receipt {receiptSuccess} | mined == h -> if receiptSuccess then TSMined else TSReverted + _ -> TSDropped + block h = case outcome of + TOConfirmed mined Receipt {receiptBlock} | mined == h -> Just receiptBlock + _ -> Nothing + +update :: Sender -> Word64 -> (InFlight -> InFlight) -> IO () +update Sender {snInFlight} nonce f = atomically $ modifyTVar' snInFlight $ M.adjust f nonce + +-- | The tip the node suggests, and the max fee from the latest base fee. +marketFees :: ChainClient -> IO (Either ChainError (Word64, Word64)) +marketFees c = runExceptT $ do + tip <- ExceptT $ maxPriorityFee c + Block {blockBaseFee} <- ExceptT $ latestBlock c + pure (tip, baseFeeHeadroom * blockBaseFee + tip) + +saveTransaction :: DBStore -> TxFor -> ByteString -> TxHash -> Word64 -> UTCTime -> IO () +saveTransaction st for raw hash nonce now = + withTransaction st $ \db -> void $ insertTransaction db for NewTransaction {ntxRaw = raw, ntxHash = hash, ntxNonce = nonce} now + +broadcast :: ChainClient -> Word64 -> ByteString -> IO () +broadcast c nonce raw = + sendRawTransaction c raw >>= \case + Left e -> logWarn $ "names sender: nonce " <> tshow nonce <> " not sent: " <> tshow e + Right _ -> pure () diff --git a/simplex-chat.cabal b/simplex-chat.cabal index d2fb222221..f44130f8ba 100644 --- a/simplex-chat.cabal +++ b/simplex-chat.cabal @@ -451,6 +451,7 @@ executable simplex-store-service StoreService.Names.Profiles StoreService.Names.Registration StoreService.Names.Revert + StoreService.Names.Sender StoreService.Names.Signatures StoreService.Names.Store StoreService.Names.Turns @@ -756,6 +757,7 @@ test-suite simplex-chat-test Bots.StoreService.NamesLabelTests Bots.StoreService.NamesLinksTests Bots.StoreService.NamesProfilesTests + Bots.StoreService.NamesSenderTests Bots.StoreService.NamesSignatureTests Bots.StoreService.NamesStoreTests Bots.StoreService.NamesWiringTests @@ -789,6 +791,7 @@ test-suite simplex-chat-test StoreService.Names.Profiles StoreService.Names.Registration StoreService.Names.Revert + StoreService.Names.Sender StoreService.Names.Signatures StoreService.Names.Store StoreService.Names.Turns diff --git a/tests/Bots/StoreService/NamesSenderTests.hs b/tests/Bots/StoreService/NamesSenderTests.hs new file mode 100644 index 0000000000..7d5919684b --- /dev/null +++ b/tests/Bots/StoreService/NamesSenderTests.hs @@ -0,0 +1,284 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} + +module Bots.StoreService.NamesSenderTests (namesSenderTests) where + +import Bots.StoreService.FakeEthNode +import Bots.StoreService.NamesStoreTests (issue, order, ownerA, placeCode, t0, usable) +import Bots.StoreService.WebTests (digestFixture, withServiceStore) +import Control.Concurrent.Async (concurrently) +import Control.Concurrent.STM +import Control.Monad (forM_) +import Crypto.Random (ChaChaDRG) +import Data.ByteArray.Encoding (Base (Base16), convertFromBase) +import Data.ByteString (ByteString) +import qualified Data.ByteString as B +import Data.List (sort) +import Data.Time.Clock (NominalDiffTime, UTCTime, addUTCTime) +import Data.Word (Word64, Word8) +import Simplex.Messaging.Agent.Store.Common (DBStore, withTransaction) +import qualified Simplex.Messaging.Crypto as C +import StoreService.Config (ChainConfig (..)) +import StoreService.Names.Abi (selector, uint256) +import StoreService.Names.Chain +import StoreService.Names.Phases (RegistrationId (..)) +import StoreService.Names.Registration (commitCalldata) +import StoreService.Names.Revert (RevertName (..)) +import StoreService.Names.Sender +import StoreService.Names.Store (NameTransaction (..), TxFor (..), TxStatus (..), pendingTransactions, registrationTransactions) +import System.Timeout (timeout) +import Test.Hspec + +namesSenderTests :: Spec +namesSenderTests = describe "StoreService names: sender" $ do + g <- runIO C.newRandom + it "reads a signed transaction's request back from its raw bytes" $ testDecodeSignedTx g + it "gives concurrent transactions their own nonces, each saved before it is sent" $ testConcurrentNonces g + it "saves nothing and takes no nonce when the dry run reverts or the chain does not answer" $ testNothingSaved g + it "refuses a second transaction for work with one in flight" $ testOneInFlight g + it "settles a receipt only once it is confirmations deep, with its status" $ testConfirmationDepth g + it "keeps a transaction whose send failed, and sends it in the next round" $ testFailedSend g + it "replaces a stuck transaction once the market's fees pass its own, and settles it under the new hash" $ testFeeBump g + it "rebroadcasts a saved raw transaction after a restart while the node does not know it" $ testRestartRebroadcast g + it "hands a dropped transaction whose nonce was used to its owner, who judges it from chain state before any new signature" $ testDroppedNonceUsed g + it "hands a mined transaction whose receipt was pruned to its owner, signing nothing more" $ testPrunedReceipt g + +data Setup = Setup + { node :: FakeEthNode, + store :: DBStore, + clock :: TVar UTCTime, + chain :: ChainClient, + random :: TVar ChaChaDRG + } + +-- | Two code orders, r1 and r2, and two confirmations. +withSetup :: TVar ChaChaDRG -> (Setup -> IO a) -> IO a +withSetup random action = withFakeEthNode $ \node -> withServiceStore $ \store -> do + forM_ [(1, "r1", "alicebakery"), (2, "r2", "bobbakery")] $ \(n, rid, label) -> do + code <- issue store n usable + placeCode store rid ownerA (order label n) code `shouldReturn` Right () + clock <- newTVarIO t0 + chain <- newChainClient random (fakeChainConfig node) {cConfirmations = 2} + action Setup {node, store, clock, chain, random} + +start :: Setup -> IO Sender +start Setup {random, chain, store, clock} = newSender random chain store (readTVarIO clock) + +passTime :: Setup -> NominalDiffTime -> IO () +passTime Setup {clock} t = atomically $ modifyTVar' clock (addUTCTime t) + +testDecodeSignedTx :: TVar ChaChaDRG -> IO () +testDecodeSignedTx g = withFakeEthNode $ \node -> do + c <- newChainClient g $ fakeChainConfig node + -- calldata over 55 bytes takes a long RLP length + let request = TxRequest {trTo = fakeSponsor, trData = B.replicate 300 0xab, trNonce = 70000, trGasLimit = 450000, trMaxFeePerGas = 31000000000, trMaxPriorityFeePerGas = 0} + Right SignedTx {stRaw} <- signTransaction g c request + decodeSignedTx stRaw `shouldBe` Right request + decodeSignedTx (B.cons 0x01 $ B.drop 1 stRaw) `shouldBe` Left "transaction: not an EIP-1559 transaction" + decodeSignedTx (B.take 100 stRaw) `shouldBe` Left "RLP: truncated" + +testConcurrentNonces :: TVar ChaChaDRG -> IO () +testConcurrentNonces g = withSetup g $ \s@Setup {node, store} -> do + sender <- start s + -- both dry runs pass before either reads the registrar's nonce + setFault node "eth_getTransactionCount" $ Slow 300000 + (Right a, Right b) <- concurrently (submitTransaction sender (TxCommit r1) fakeController $ commit 1) (submitTransaction sender (TxCommit r2) fakeController $ commit 2) + clearFault node "eth_getTransactionCount" + sort [ptNonce a, ptNonce b] `shouldBe` [0, 1] + saved <- withTransaction store pendingTransactions + map (\NameTransaction {ntFor, ntNonce, ntHash} -> (ntFor, ntNonce, ntHash)) saved + `shouldMatchList` [(TxCommit r1, ptNonce a, ptHash a), (TxCommit r2, ptNonce b, ptHash b)] + sentTransactions node `shouldReturn` map ntRaw saved + mapM_ (mineHash node) [ptHash a, ptHash b] + _ <- mine node [] + followTransactions sender + forM_ [a, b] $ \p -> outcomeOf p >>= (`shouldSatisfy` confirmedAs (ptHash p)) + Right c <- submitTransaction sender (TxRegister r1) fakeSponsor $ commit 3 + ptNonce c `shouldBe` 2 + +testNothingSaved :: TVar ChaChaDRG -> IO () +testNothingSaved g = withSetup g $ \s@Setup {node, store} -> do + sender <- start s + setFault node "eth_estimateGas" $ revertFault insufficientAllowance + submitTransaction sender (TxCommit r1) fakeController (commit 1) `refusedWith` SEChain (ChainReverted $ Just RNInsufficientAllowance) + clearFault node "eth_estimateGas" + setFault node "eth_maxPriorityFeePerGas" HttpFailure + submitTransaction sender (TxCommit r1) fakeController (commit 1) `refusedWith` SEChain (ChainUnavailable "eth_maxPriorityFeePerGas: HTTP 502") + clearFault node "eth_maxPriorityFeePerGas" + withTransaction store pendingTransactions `shouldReturn` [] + sentTransactions node `shouldReturn` [] + Right p <- submitTransaction sender (TxCommit r1) fakeController (commit 1) + ptNonce p `shouldBe` 0 + +testOneInFlight :: TVar ChaChaDRG -> IO () +testOneInFlight g = withSetup g $ \s@Setup {node} -> do + sender <- start s + Right p <- submitTransaction sender (TxCommit r1) fakeController (commit 1) + submitTransaction sender (TxCommit r1) fakeController (commit 1) `refusedWith` SEInFlight + Right other <- submitTransaction sender (TxRegister r1) fakeSponsor (commit 2) + ptNonce other `shouldBe` 1 + (fmap ptHash <$> inFlightTransaction sender (TxCommit r1)) `shouldReturn` Just (ptHash p) + length <$> sentTransactions node `shouldReturn` 2 + +testConfirmationDepth :: TVar ChaChaDRG -> IO () +testConfirmationDepth g = withSetup g $ \s@Setup {node, store} -> do + sender <- start s + Right p <- submitTransaction sender (TxCommit r1) fakeController (commit 1) + let TxHash h = ptHash p + block <- mine node [(h, False)] + followTransactions sender + settled sender (TxCommit r1) `shouldReturn` False + _ <- mine node [] + followTransactions sender + outcomeOf p `shouldReturn` TOConfirmed (ptHash p) Receipt {receiptSuccess = False, receiptBlock = block} + settled sender (TxCommit r1) `shouldReturn` True + statuses store r1 `shouldReturn` [(ptHash p, TSReverted, Just block)] + +testFailedSend :: TVar ChaChaDRG -> IO () +testFailedSend g = withSetup g $ \s@Setup {node, store} -> do + sender <- start s + setFault node "eth_sendRawTransaction" HttpFailure + Right p <- submitTransaction sender (TxCommit r1) fakeController (commit 1) + clearFault node "eth_sendRawTransaction" + sentTransactions node `shouldReturn` [] + [NameTransaction {ntRaw, ntHash}] <- withTransaction store pendingTransactions + ntHash `shouldBe` ptHash p + followTransactions sender + sentTransactions node `shouldReturn` [ntRaw] + transactionByHash' s (ptHash p) `shouldReturn` Just TxPending + +testFeeBump :: TVar ChaChaDRG -> IO () +testFeeBump g = withSetup g $ \s@Setup {node, store} -> do + sender <- start s + Right p <- submitTransaction sender (TxCommit r1) fakeController (commit 1) + [firstRaw] <- sentTransactions node + Right first@TxRequest {trMaxFeePerGas = firstMax, trMaxPriorityFeePerGas = firstTip} <- pure $ decodeSignedTx firstRaw + (firstTip, firstMax) `shouldBe` (fakeTip, 2 * fakeBaseFee + fakeTip) + passTime s $ replaceAfter - 1 + followTransactions sender + passTime s 1 + followTransactions sender + length <$> sentTransactions node `shouldReturn` 1 + setFees node fakeTip (2 * fakeBaseFee) + followTransactions sender + length <$> sentTransactions node `shouldReturn` 1 + passTime s replaceAfter + followTransactions sender + [_, bumpedRaw] <- sentTransactions node + let bumpedHash = TxHash $ C.keccak256 bumpedRaw + decodeSignedTx bumpedRaw `shouldBe` Right first {trMaxPriorityFeePerGas = fakeTip + fakeTip `div` 8 + 1, trMaxFeePerGas = 4 * fakeBaseFee + fakeTip} + transactionByHash' s (ptHash p) `shouldReturn` Nothing + transactionByHash' s bumpedHash `shouldReturn` Just TxPending + map (\(h, status, _) -> (h, status)) <$> statuses store r1 `shouldReturn` [(ptHash p, TSPending), (bumpedHash, TSPending)] + mineHash node bumpedHash + _ <- mine node [] + followTransactions sender + TOConfirmed minedHash Receipt {receiptSuccess = True, receiptBlock} <- outcomeOf p + minedHash `shouldBe` bumpedHash + statuses store r1 `shouldReturn` [(ptHash p, TSDropped, Nothing), (bumpedHash, TSMined, Just receiptBlock)] + +testRestartRebroadcast :: TVar ChaChaDRG -> IO () +testRestartRebroadcast g = withSetup g $ \s@Setup {node, store} -> do + crashed <- start s + Right p <- submitTransaction crashed (TxCommit r1) fakeController (commit 1) + [raw] <- sentTransactions node + let TxHash h = ptHash p + dropTransaction node h + restarted <- start s + Just resumed <- inFlightTransaction restarted (TxCommit r1) + (ptHash resumed, ptNonce resumed) `shouldBe` (ptHash p, 0) + followTransactions restarted + sentTransactions node `shouldReturn` [raw, raw] + followTransactions restarted + sentTransactions node `shouldReturn` [raw, raw] + Right next <- submitTransaction restarted (TxCommit r2) fakeController (commit 2) + ptNonce next `shouldBe` 1 + _ <- mine node [(h, True)] + _ <- mine node [] + followTransactions restarted + outcomeOf resumed >>= (`shouldSatisfy` confirmedAs (ptHash p)) + map (\(_, status, _) -> status) <$> statuses store r1 `shouldReturn` [TSMined] + +testDroppedNonceUsed :: TVar ChaChaDRG -> IO () +testDroppedNonceUsed g = withSetup g $ \s@Setup {node, store, chain} -> do + sender <- start s + Right p <- submitTransaction sender (TxCommit r1) fakeController (commit 1) + let TxHash h = ptHash p + dropTransaction node h + useNextNonce node + followTransactions sender + settled sender (TxCommit r1) `shouldReturn` False + _ <- mine node [] + followTransactions sender + outcomeOf p `shouldReturn` TONonceUsed + statuses store r1 `shouldReturn` [(ptHash p, TSDropped, Nothing)] + length <$> sentTransactions node `shouldReturn` 1 + -- the owner: the commitment reads 0, so the commit never mined and is sent again + answerCall node fakeController commitmentsCall $ Returns $ uint256 (0 :: Int) + ethCall chain fakeController commitmentsCall `shouldReturn` Right (uint256 (0 :: Int)) + Right again <- submitTransaction sender (TxCommit r1) fakeController (commit 1) + ptNonce again `shouldBe` 1 + length <$> sentTransactions node `shouldReturn` 2 + +testPrunedReceipt :: TVar ChaChaDRG -> IO () +testPrunedReceipt g = withSetup g $ \s@Setup {node, store} -> do + sender <- start s + Right p <- submitTransaction sender (TxCommit r1) fakeController (commit 1) + let TxHash h = ptHash p + _ <- mine node [(h, True)] + pruneReceipt node h + followTransactions sender + settled sender (TxCommit r1) `shouldReturn` False + _ <- mine node [] + followTransactions sender + outcomeOf p `shouldReturn` TONonceUsed + statuses store r1 `shouldReturn` [(ptHash p, TSDropped, Nothing)] + followTransactions sender + length <$> sentTransactions node `shouldReturn` 1 + withTransaction store pendingTransactions `shouldReturn` [] + +-- fixtures + +r1, r2 :: RegistrationId +r1 = RegistrationId "r1" +r2 = RegistrationId "r2" + +commit :: Word8 -> ByteString +commit = commitCalldata . digestFixture + +commitmentsCall :: ByteString +commitmentsCall = selector "commitments(bytes32)" <> digestFixture 1 + +-- | viem's encodeErrorResult of InsufficientAllowance(10000, 2500) +insufficientAllowance :: ByteString +insufficientAllowance = unhex "2a1b2dd8000000000000000000000000000000000000000000000000000000000000271000000000000000000000000000000000000000000000000000000000000009c4" + +mineHash :: FakeEthNode -> TxHash -> IO () +mineHash node (TxHash h) = () <$ mine node [(h, True)] + +confirmedAs :: TxHash -> TxOutcome -> Bool +confirmedAs hash = \case + TOConfirmed h Receipt {receiptSuccess = True} -> h == hash + _ -> False + +outcomeOf :: PendingTx -> IO TxOutcome +outcomeOf p = timeout 2000000 (awaitOutcome p) >>= maybe (fail "the transaction is not settled") pure + +settled :: Sender -> TxFor -> IO Bool +settled sender for = null <$> inFlightTransaction sender for + +statuses :: DBStore -> RegistrationId -> IO [(TxHash, TxStatus, Maybe Word64)] +statuses store rid = withTransaction store $ \db -> map (\NameTransaction {ntHash, ntStatus, ntMinedBlock} -> (ntHash, ntStatus, ntMinedBlock)) <$> registrationTransactions db rid + +transactionByHash' :: Setup -> TxHash -> IO (Maybe TxState) +transactionByHash' Setup {chain} h = either (error . show) id <$> transactionByHash chain h + +refusedWith :: IO (Either SendError PendingTx) -> SendError -> Expectation +refusedWith submit expected = + submit >>= \case + Left e -> e `shouldBe` expected + Right p -> expectationFailure $ "sent with nonce " <> show (ptNonce p) + +unhex :: ByteString -> ByteString +unhex = either error id . convertFromBase Base16 diff --git a/tests/Bots/StoreService/NamesStoreTests.hs b/tests/Bots/StoreService/NamesStoreTests.hs index 2e87fd5768..9ea0993592 100644 --- a/tests/Bots/StoreService/NamesStoreTests.hs +++ b/tests/Bots/StoreService/NamesStoreTests.hs @@ -3,7 +3,7 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} -module Bots.StoreService.NamesStoreTests (namesStoreTests) where +module Bots.StoreService.NamesStoreTests (namesStoreTests, issue, usable, placeCode, order, ownerA, t0) where import Bots.StoreService.WebTests (columnsOf, digestFixture, runMigrations, withServiceStore) import Control.Arrow ((&&&)) diff --git a/tests/Test.hs b/tests/Test.hs index e2622cba97..c8c58c92e8 100644 --- a/tests/Test.hs +++ b/tests/Test.hs @@ -14,6 +14,7 @@ import Bots.StoreService.NamesChainTests import Bots.StoreService.NamesLabelTests import Bots.StoreService.NamesLinksTests import Bots.StoreService.NamesProfilesTests +import Bots.StoreService.NamesSenderTests import Bots.StoreService.NamesSignatureTests import Bots.StoreService.NamesStoreTests import Bots.StoreService.NamesWiringTests @@ -98,6 +99,7 @@ main = do namesLabelTests namesLinksTests namesProfilesTests + namesSenderTests namesSignatureTests namesStoreTests namesWiringTests