store: send the registrar key's transactions

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}

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 ()

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

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

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 ((&&&))

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