From d7913cdab7ec904ab5575cb84a6ffe175eb8e339 Mon Sep 17 00:00:00 2001 From: shum Date: Thu, 22 Oct 2026 07:21:21 +0000 Subject: [PATCH] store: register each order on chain in a worker --- .../src/StoreService/Names/Orders.hs | 1 + .../src/StoreService/Names/Reveal.hs | 8 + .../src/StoreService/Names/View.hs | 1 + .../src/StoreService/Names/Worker.hs | 353 +++++++++++ simplex-chat.cabal | 2 + .../Bots/StoreService/NamesContractsTests.hs | 3 + tests/Bots/StoreService/NamesOwnerTests.hs | 1 + tests/Bots/StoreService/NamesWorkerTests.hs | 594 +++++++++++++++++- 8 files changed, 948 insertions(+), 15 deletions(-) create mode 100644 apps/simplex-store-service/src/StoreService/Names/Worker.hs diff --git a/apps/simplex-store-service/src/StoreService/Names/Orders.hs b/apps/simplex-store-service/src/StoreService/Names/Orders.hs index 4265817482..5d59d98e37 100644 --- a/apps/simplex-store-service/src/StoreService/Names/Orders.hs +++ b/apps/simplex-store-service/src/StoreService/Names/Orders.hs @@ -36,6 +36,7 @@ module StoreService.Names.Orders checkMoveMeets, checkMovePrice, retargetOrder, + versionWritten, confirmLanded, issuedCodeHash, checkTakenCodeLength, diff --git a/apps/simplex-store-service/src/StoreService/Names/Reveal.hs b/apps/simplex-store-service/src/StoreService/Names/Reveal.hs index 2edb92bbfa..57287f3977 100644 --- a/apps/simplex-store-service/src/StoreService/Names/Reveal.hs +++ b/apps/simplex-store-service/src/StoreService/Names/Reveal.hs @@ -15,6 +15,7 @@ module StoreService.Names.Reveal checkIntent, linksValid, revealOf, + intentOf, ) where @@ -124,3 +125,10 @@ linksValid Registration {rContactLink, rChannelLink} = all (ofKind LKContact) rC revealOf :: RegisterIntent -> NameReveal revealOf RegisterIntent {riRegistration = Registration {rLabel, rSecret, rContactLink, rChannelLink}, riNonce, riDeadline, riSignature} = NameReveal {rvLabel = rLabel, rvSecret = rSecret, rvContactLink = rContactLink, rvChannelLink = rChannelLink, rvNonce = riNonce, rvDeadline = riDeadline, rvSignature = riSignature} + +-- | The intent an accepted reveal stored, as the register sends it. +intentOf :: NamesConfig -> NameRegistration -> NameReveal -> RegisterIntent +intentOf NamesConfig {nTLD, nChain = ChainConfig {cResolver}} NameRegistration {nrOwner, nrDuration} NameReveal {rvLabel, rvSecret, rvContactLink, rvChannelLink, rvNonce, rvDeadline, rvSignature} = + RegisterIntent {riRegistration = registration, riNonce = rvNonce, riDeadline = rvDeadline, riSignature = rvSignature} + where + registration = Registration {rLabel = rvLabel, rTLD = nTLD, rOwner = nrOwner, rDuration = nrDuration, rSecret = rvSecret, rResolver = cResolver, rContactLink = rvContactLink, rChannelLink = rvChannelLink} diff --git a/apps/simplex-store-service/src/StoreService/Names/View.hs b/apps/simplex-store-service/src/StoreService/Names/View.hs index fda9cf2519..bea5bd9ca8 100644 --- a/apps/simplex-store-service/src/StoreService/Names/View.hs +++ b/apps/simplex-store-service/src/StoreService/Names/View.hs @@ -11,6 +11,7 @@ module StoreService.Names.View tldText, registrationAt, lapseMoment, + notSignedInTime, registrationVersion, ) where diff --git a/apps/simplex-store-service/src/StoreService/Names/Worker.hs b/apps/simplex-store-service/src/StoreService/Names/Worker.hs new file mode 100644 index 0000000000..712411eeb0 --- /dev/null +++ b/apps/simplex-store-service/src/StoreService/Names/Worker.hs @@ -0,0 +1,353 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | Each registration from queued to registered, taken or failed: its commit, the wait for the page's reveal, and its register. +-- A step starts from the stored registration, the sender's transactions in flight and the chain, so a restart resumes any phase. +module StoreService.Names.Worker + ( Worker, + Next (..), + newWorker, + stepRegistration, + runWorkers, + sweepFailedCodes, + runCodeSweep, + ) +where + +import Control.Concurrent (threadDelay) +import Control.Concurrent.Async (Async, asyncWithUnmask, cancel, poll) +import Control.Concurrent.STM +import Control.Exception (finally, mask_) +import Control.Monad (forM, forM_, forever, void, when) +import Control.Monad.Except (ExceptT (..), runExceptT) +import Data.Functor ((<&>)) +import Data.Int (Int64) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as M +import Data.Text (Text) +import Data.Time.Clock (NominalDiffTime, UTCTime, addUTCTime, diffUTCTime) +import Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds) +import Data.Word (Word64) +import Simplex.Messaging.Agent.Store.Common (withTransaction) +import Simplex.Messaging.Util (tshow) +import StoreService.Config (ChainConfig (..), NamesConfig (..)) +import StoreService.Log (logError, logInfo, logWarn, safely, safelyWith) +import StoreService.Names.Chain (Block (..), ChainClient, ChainError (..), TxHash, blockAt) +import StoreService.Names.Codes (releaseCode) +import StoreService.Names.Contracts (CommitmentAges (..), commitmentAges, commitmentTime, controllerAvailable) +import StoreService.Names.Orders (Landing (..), OrdersEnv (..), WriteRefusal (..), confirmLanded, versionWritten) +import StoreService.Names.Phases (RegistrationId (..), awaitChange, publish) +import StoreService.Names.Registration (commitCalldata, registerWithCreditCalldata, sponsorDomain, verifyRegisterIntent) +import StoreService.Names.Reveal (intentOf) +import StoreService.Names.Revert (RevertName (..)) +import StoreService.Names.Sender (PendingTx, SendError (..), Sender, awaitOutcome, inFlightTransaction, ptHash, submitTransaction) +import StoreService.Names.Store +import StoreService.Names.Turns (withLabelTurn) +import StoreService.Names.View (lapseMoment, notSignedInTime, registrationVersion) + +data Worker = Worker + { wkOrders :: OrdersEnv, + wkChain :: ChainClient, + wkSender :: Sender, + -- | the thread following each registration, kept by the scan + wkThreads :: TVar (Map RegistrationId (Async ())) + } + +-- | What a step leaves to the next one. +data Next + = -- | the registration is in none of the worker's phases + Done + | -- | the step wrote, or the registration changed since it was read + Again + | -- | nothing to do before this time, unless the registration moves on from this version + WaitUntil Int64 UTCTime + | -- | a chain read or a send failed, and the phase is kept + Retry Int64 Text + | -- | a transaction of the registration is in flight + Await PendingTx + +-- | How often the stored registrations are scanned for one without a thread, such as an order just paid or requeued. +scanInterval :: Int +scanInterval = 5000000 + +retryInterval :: NominalDiffTime +retryInterval = 15 + +-- | The registration is read again after this wait for its transaction's outcome. +outcomeWait :: Int +outcomeWait = 60000000 + +-- | A long wait is cut into waits of at most this, so a clock adjustment delays a moment by no more. +maxWait :: NominalDiffTime +maxWait = 60 + +-- | Block times are whole seconds. +chainSecond :: NominalDiffTime +chainSecond = 1 + +-- | A failed code order keeps its code this long for Try again. +failedCodeHold :: NominalDiffTime +failedCodeHold = 30 * 86400 + +sweepInterval :: Int +sweepInterval = 86400 * 1000000 + +notRegistered :: Text +notRegistered = "The name could not be registered" + +newWorker :: OrdersEnv -> ChainClient -> Sender -> IO Worker +newWorker wkOrders wkChain wkSender = Worker wkOrders wkChain wkSender <$> newTVarIO M.empty + +-- | A thread for each registration in the worker's phases, started by a scan every scanInterval; they stop with it. +runWorkers :: Worker -> IO () +runWorkers w@Worker {wkThreads} = + forever (safely "names worker: the scan" (startWorkers w) >> threadDelay scanInterval) + `finally` (readTVarIO wkThreads >>= mapM_ cancel) + +startWorkers :: Worker -> IO () +startWorkers w@Worker {wkOrders = OrdersEnv {oeStore}, wkThreads} = do + running <- readTVarIO wkThreads >>= M.traverseMaybeWithKey (\_ a -> maybe (Just a) (const Nothing) <$> poll a) + atomically $ writeTVar wkThreads running + active <- withTransaction oeStore activeRegistrations + forM_ [nrId | NameRegistration {nrId} <- active, M.notMember nrId running] $ \rid -> + mask_ $ asyncWithUnmask (\unmask -> unmask $ work w rid) >>= atomically . modifyTVar' wkThreads . M.insert rid + +work :: Worker -> RegistrationId -> IO () +work w rid@(RegistrationId ridText) = void $ safely ("names worker: registration " <> ridText) $ follow w rid Nothing + +-- | Steps until the registration leaves the worker's phases, logging a lasting failure once. +follow :: Worker -> RegistrationId -> Maybe Text -> IO () +follow w@Worker {wkOrders = OrdersEnv {oeStore, oePhases, oeNow}} rid@(RegistrationId ridText) lastFailure = + stepRegistration w rid >>= \case + Done -> pure () + Again -> follow w rid Nothing + WaitUntil v t -> waitFor v t >> follow w rid Nothing + Retry v reason -> do + when (Just reason /= lastFailure) $ logWarn $ "names worker: registration " <> ridText <> " waits: " <> reason + now <- oeNow + waitFor v $ addUTCTime retryInterval now + follow w rid $ Just reason + Await p -> awaitOutcome outcomeWait p >> follow w rid Nothing + where + waitFor v t = do + now <- oeNow + let micros = max 0 $ ceiling $ min maxWait (diffUTCTime t now) * 1000000 + void $ awaitChange oePhases rid (registrationVersion oeStore rid) v micros + +stepRegistration :: Worker -> RegistrationId -> IO Next +stepRegistration w@Worker {wkOrders = OrdersEnv {oeStore, oeNow}} rid = do + now <- oeNow + withTransaction oeStore (`getRegistration` rid) >>= \case + Nothing -> pure Done + Just r -> case nrPhase r of + PQueued -> commit w now r + PCommitting -> commit w now r + PCommitted -> committed w now r + PRegistering -> registering w now r + _ -> pure Done + +-- | A commit of the registration in flight is waited for; otherwise commitments(commitment) decides. +commit :: Worker -> UTCTime -> NameRegistration -> IO Next +commit w@Worker {wkOrders = OrdersEnv {oeContracts}, wkSender} now r@NameRegistration {nrId, nrCommitment} = + inFlightTransaction wkSender (TxCommit nrId) >>= \case + Just p -> commitSent w now r p + Nothing -> + runExceptT ((,) <$> ExceptT (commitmentAges oeContracts) <*> ExceptT (commitmentTime oeContracts nrCommitment)) >>= \case + Left e -> pure $ failure r e + Right (_, Nothing) -> sendCommit w now r + Right (ages, Just t) -> fromCommitment w now r ages t + +-- | A live commitment is reused while revealMargin is left before its lapse. At the lapse second it can neither register +-- nor be committed again, so the worker waits a second past it, then commits again with the stale fields cleared. +fromCommitment :: Worker -> UTCTime -> NameRegistration -> CommitmentAges -> Word64 -> IO Next +fromCommitment w@Worker {wkOrders = OrdersEnv {oeConfig = NamesConfig {nRevealMarginSeconds}}} now r ages@CommitmentAges {caMax} t + | left >= toInteger nRevealMarginSeconds = toCommitted w now r ages t + | left >= 0 = pure $ waitUntil r $ addUTCTime chainSecond $ secondsTime lapse + | lapsedFields r /= r = save w now $ lapsedFields r + | otherwise = sendCommit w now r + where + lapse = toInteger t + caMax + left = lapse - unixSeconds now + +-- | The intent's deadline is the lapsed revealBefore, so it goes with the old transactions and reveal times; the page signs again. +lapsedFields :: NameRegistration -> NameRegistration +lapsedFields r = + r + { nrReveal = Nothing, + nrError = Nothing, + nrCommitTx = Nothing, + nrCommitBlock = Nothing, + nrRegisterTx = Nothing, + nrRegisterBlock = Nothing, + nrRevealAfter = Nothing, + nrRevealBefore = Nothing + } + +-- | The reveal times come from the commitment's time. When that is not the block of our commit mined with status 1, +-- someone committed it again after a lapse, so our commit and the reveal signed for its window are cleared. +toCommitted :: Worker -> UTCTime -> NameRegistration -> CommitmentAges -> Word64 -> IO Next +toCommitted w now r CommitmentAges {caMin, caMax} t = + ourCommit w r t >>= \case + Left e -> pure $ failure r e + Right ours -> save w now (minedBy ours) {nrPhase = PCommitted, nrRevealAfter = Just $ after caMin, nrRevealBefore = Just $ after caMax} + where + after age = fromInteger $ toInteger t + age + minedBy = \case + Just (h, block) -> r {nrCommitTx = Just h, nrCommitBlock = Just block} + Nothing -> r {nrReveal = Nothing, nrCommitTx = Nothing, nrCommitBlock = Nothing} + +-- | Among the signatures of the commit last sent, the one mined with status 1 at the commitment's time. +ourCommit :: Worker -> NameRegistration -> Word64 -> IO (Either ChainError (Maybe (TxHash, Word64))) +ourCommit Worker {wkOrders = OrdersEnv {oeStore}, wkChain} NameRegistration {nrId, nrCommitTx} t = do + txs <- withTransaction oeStore (`registrationTransactions` nrId) + let commits = [tx | tx@NameTransaction {ntFor = TxCommit _} <- txs] + lastSent = [ntNonce | NameTransaction {ntHash, ntNonce} <- commits, Just ntHash == nrCommitTx] + case [(ntHash, block) | NameTransaction {ntHash, ntNonce, ntStatus = TSMined, ntMinedBlock = Just block} <- commits, ntNonce `elem` lastSent] of + (h, block) : _ -> fmap (\Block {blockTimestamp} -> if blockTimestamp == t then Just (h, block) else Nothing) <$> blockAt wkChain block + [] -> pure $ Right Nothing + +sendCommit :: Worker -> UTCTime -> NameRegistration -> IO Next +sendCommit w@Worker {wkOrders = OrdersEnv {oeConfig}, wkSender} now r@NameRegistration {nrId, nrCommitment} = + submitTransaction wkSender (TxCommit nrId) (cController $ nChain oeConfig) (commitCalldata nrCommitment) >>= \case + Right p -> commitSent w now r p + Left SEInFlight -> pure Again + -- a commit mined since the read, or a latest block still at the lapse second + Left (SEChain (ChainReverted (Just RNUnexpiredCommitmentExists))) -> pure $ waitUntil r $ addUTCTime chainSecond now + Left e -> pure $ failure r e + +-- | Recorded with the newest signature's hash, so a fee-bumped replacement is the one the view shows. +commitSent :: Worker -> UTCTime -> NameRegistration -> PendingTx -> IO Next +commitSent w now r@NameRegistration {nrPhase, nrCommitTx} p + | nrPhase == PCommitting && nrCommitTx == Just (ptHash p) = pure $ Await p + | otherwise = save w now r {nrPhase = PCommitting, nrCommitTx = Just $ ptHash p, nrCommitBlock = Nothing} + +-- | Waits for the page's reveal until the lapse, and for revealAfter, then registers. +committed :: Worker -> UTCTime -> NameRegistration -> IO Next +committed w@Worker {wkSender} now r@NameRegistration {nrId, nrReveal, nrRevealAfter} = + inFlightTransaction wkSender (TxRegister nrId) >>= \case + Just p -> registerSent w now r p + Nothing -> case nrReveal of + Nothing -> case lapseMoment r of + Just lapse | now <= lapse -> pure $ waitUntil r $ addUTCTime chainSecond lapse + _ -> save w now r {nrPhase = PFailed, nrFailedAt = Just now, nrError = Just notSignedInTime} + Just rv -> case secondsTime . toInteger <$> nrRevealAfter of + Just revealAfter | now < revealAfter -> pure $ waitUntil r revealAfter + _ -> sendRegister w now r rv + +-- | The stored intent is checked before its dry run, whose revert decides at once; no label turn is held across the send. +sendRegister :: Worker -> UTCTime -> NameRegistration -> NameReveal -> IO Next +sendRegister w@Worker {wkOrders = OrdersEnv {oeConfig = cfg@NamesConfig {nChain = ChainConfig {cChainId, cSponsor}}}, wkSender} now r@NameRegistration {nrId} rv = + verifyRegisterIntent (sponsorDomain cChainId cSponsor) (fromInteger $ unixSeconds now) intent >>= \case + -- past its deadline, the commitment it was signed for has lapsed too + Left _ -> judge w now r Nothing + Right () -> + submitTransaction wkSender (TxRegister nrId) cSponsor (registerWithCreditCalldata intent) >>= \case + Right p -> registerSent w now r p + Left SEInFlight -> pure Again + Left (SEChain (ChainReverted reason)) -> judge w now r reason + Left e -> pure $ failure r e + where + intent = intentOf cfg r rv + +registerSent :: Worker -> UTCTime -> NameRegistration -> PendingTx -> IO Next +registerSent w now r@NameRegistration {nrPhase, nrRegisterTx} p + | nrPhase == PRegistering && nrRegisterTx == Just (ptHash p) = pure $ Await p + | otherwise = save w now r {nrPhase = PRegistering, nrRegisterTx = Just $ ptHash p, nrRegisterBlock = Nothing} + +-- | With none of its register transactions in flight, none can be mined any more: each mined, or its nonce taken. +registering :: Worker -> UTCTime -> NameRegistration -> IO Next +registering w@Worker {wkSender} now r@NameRegistration {nrId} = + inFlightTransaction wkSender (TxRegister nrId) >>= \case + Just p -> registerSent w now r p + Nothing -> judge w now r Nothing + +-- | A register that did not go through, by its dry run's revert or once every transaction settled: registered when one mined +-- with status 1 or the owner holds the name; committed again on InvalidNonce, for the page to sign again; taken on +-- NameNotAvailable, NameReserved, or any revert while the name is not available; failed otherwise. +judge :: Worker -> UTCTime -> NameRegistration -> Maybe RevertName -> IO Next +judge w@Worker {wkOrders = oe@OrdersEnv {oeContracts}} now r@NameRegistration {nrReveal} reason = + inTurn w r $ + confirmLanded oe r >>= \case + LRegistered v -> pure (Just v, Again) + LChanged -> pure (Nothing, Again) + LUnread -> pure (Nothing, Retry (nrVersion r) "the register check's chain read failed") + LNotLanded -> case reason of + Just RNInvalidNonce -> store w now r {nrReveal = Nothing} + Just RNCommitmentTooNew -> pure (Nothing, waitUntil r $ addUTCTime chainSecond now) + Just name | name `elem` [RNNameNotAvailable, RNNameReserved] -> taken w now r + _ -> case nrReveal of + Just NameReveal {rvLabel} -> + controllerAvailable oeContracts rvLabel >>= \case + Left e -> pure (Nothing, failure r e) + Right False -> taken w now r + Right True -> failed w now r reason + Nothing -> failed w now r reason + +-- | The payment is kept, and a code order's code released. +taken :: Worker -> UTCTime -> NameRegistration -> IO (Maybe Int64, Next) +taken Worker {wkOrders = OrdersEnv {oeStore, oeTurns}} now r@NameRegistration {nrId, nrPayment} = case nrPayment of + RPInvoice {} -> written r <$> withTransaction oeStore write + RPCode codeId -> written r . fmap fst <$> releaseCode oeTurns oeStore codeId nrId write + where + write db = versionWritten <$> updateRegistration db r {nrPhase = PTaken, nrError = Nothing} now + +-- | A code order keeps its code for Try again. +failed :: Worker -> UTCTime -> NameRegistration -> Maybe RevertName -> IO (Maybe Int64, Next) +failed w now r@NameRegistration {nrId = RegistrationId rid} reason = do + when (reason == Just RNInsufficientAllowance) $ + logError $ "names worker: registration " <> rid <> " failed: the registrar's allowance on the sponsor is used up; the guardian raises it with setRegistrarAllowance" + store w now r {nrPhase = PFailed, nrFailedAt = Just now, nrError = Just notRegistered} + +-- | A compare-and-set on the version read, in the caller's turn of the name. +store :: Worker -> UTCTime -> NameRegistration -> IO (Maybe Int64, Next) +store Worker {wkOrders = OrdersEnv {oeStore}} now r = written r <$> withTransaction oeStore (\db -> versionWritten <$> updateRegistration db r now) + +save :: Worker -> UTCTime -> NameRegistration -> IO Next +save w now r = inTurn w r $ store w now r + +-- | In the name's turn, as the requests that change an order; the version written is published after the turn. +inTurn :: Worker -> NameRegistration -> IO (Maybe Int64, Next) -> IO Next +inTurn Worker {wkOrders = OrdersEnv {oeTurns, oePhases}} NameRegistration {nrId, nrLabelHash} action = do + (v, next) <- withLabelTurn oeTurns nrLabelHash action + mapM_ (atomically . publish oePhases nrId) v + pure next + +written :: NameRegistration -> Either WriteRefusal Int64 -> (Maybe Int64, Next) +written r = \case + Right v -> (Just v, Again) + Left WRChanged -> (Nothing, Again) + Left (WRRefused refusal) -> (Nothing, Retry (nrVersion r) $ "its write was refused: " <> tshow refusal) + +failure :: Show e => NameRegistration -> e -> Next +failure r e = Retry (nrVersion r) $ tshow e + +waitUntil :: NameRegistration -> UTCTime -> Next +waitUntil r = WaitUntil (nrVersion r) + +unixSeconds :: UTCTime -> Integer +unixSeconds = floor . utcTimeToPOSIXSeconds + +secondsTime :: Integer -> UTCTime +secondsTime = posixSecondsToUTCTime . fromInteger + +-- | Each code order failed for failedCodeHold gives its code back, in its name's and its code's turns, unless it was requeued meanwhile. +sweepFailedCodes :: Worker -> IO () +sweepFailedCodes Worker {wkOrders = OrdersEnv {oeStore, oeTurns, oeNow}} = do + cutoff <- addUTCTime (negate failedCodeHold) <$> oeNow + orders <- withTransaction oeStore (`failedCodeOrdersBefore` cutoff) + released <- forM orders $ \(rid@(RegistrationId ridText), codeId) -> + safelyWith ("names code sweep: registration " <> ridText) False $ + withTransaction oeStore (`getRegistration` rid) >>= \case + Just NameRegistration {nrLabelHash} -> withLabelTurn oeTurns nrLabelHash $ either (const False) snd <$> releaseCode oeTurns oeStore codeId rid (stillFailed cutoff rid) + Nothing -> pure False + let count = length $ filter id released + when (count > 0) $ logInfo $ "names code sweep: released the codes of " <> tshow count <> " failed order(s)" + where + stillFailed cutoff rid db = + getRegistration db rid <&> \case + Just NameRegistration {nrPhase = PFailed, nrFailedAt = Just failedAt} | failedAt < cutoff -> Right () + _ -> Left () + +runCodeSweep :: Worker -> IO () +runCodeSweep w = forever $ safely "names code sweep" (sweepFailedCodes w) >> threadDelay sweepInterval diff --git a/simplex-chat.cabal b/simplex-chat.cabal index c5d1dd21af..8ca6a8526a 100644 --- a/simplex-chat.cabal +++ b/simplex-chat.cabal @@ -461,6 +461,7 @@ executable simplex-store-service StoreService.Names.Store StoreService.Names.Turns StoreService.Names.View + StoreService.Names.Worker StoreService.Options StoreService.Orders StoreService.Poller @@ -823,6 +824,7 @@ test-suite simplex-chat-test StoreService.Names.Store StoreService.Names.Turns StoreService.Names.View + StoreService.Names.Worker StoreService.Options StoreService.Orders StoreService.Poller diff --git a/tests/Bots/StoreService/NamesContractsTests.hs b/tests/Bots/StoreService/NamesContractsTests.hs index b0381fd28e..07aafbac81 100644 --- a/tests/Bots/StoreService/NamesContractsTests.hs +++ b/tests/Bots/StoreService/NamesContractsTests.hs @@ -25,6 +25,9 @@ module Bots.StoreService.NamesContractsTests pricesAnswer, oracle, alice, + availableCall, + minCommitmentAgeCall, + maxCommitmentAgeCall, unhex, ) where diff --git a/tests/Bots/StoreService/NamesOwnerTests.hs b/tests/Bots/StoreService/NamesOwnerTests.hs index 832c850640..4ed46414d4 100644 --- a/tests/Bots/StoreService/NamesOwnerTests.hs +++ b/tests/Bots/StoreService/NamesOwnerTests.hs @@ -9,6 +9,7 @@ module Bots.StoreService.NamesOwnerTests answerFree, answerOwner, answerUnowned, + byB, codeIn, committedPhase, dynamisOrder, diff --git a/tests/Bots/StoreService/NamesWorkerTests.hs b/tests/Bots/StoreService/NamesWorkerTests.hs index 6373e0f5ac..f30da13784 100644 --- a/tests/Bots/StoreService/NamesWorkerTests.hs +++ b/tests/Bots/StoreService/NamesWorkerTests.hs @@ -1,27 +1,81 @@ +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} module Bots.StoreService.NamesWorkerTests (namesWorkerTests) where import Bots.StoreService.FakeEthNode -import Bots.StoreService.NamesContractsTests (registrarOf) +import Bots.StoreService.NamesContractsTests (availableCall, maxCommitmentAgeCall, minCommitmentAgeCall, registrarOf, unhex) import Bots.StoreService.NamesOrdersTests -import Bots.StoreService.NamesOwnerTests (answerExpiry, answerUnowned, failedPhase, labelBytes, ownerOfSelector, paidIn, stored) -import Control.Monad (replicateM_) +import Bots.StoreService.NamesOwnerTests (answerExpiry, answerOwner, answerUnowned, byB, codeIn, committedPhase, dynamisOrder, failedPhase, labelBytes, ownerOfSelector, paidIn, rewrite, stored) +import Bots.StoreService.NamesPhasesTests (held, prompt, registrationPath, woken) +import Bots.StoreService.NamesStoreTests (reveal) +import Bots.StoreService.WebTests (bounded, capturingStderr, jsonObject, statusOf, webGet) +import Control.Applicative ((<|>)) +import Control.Concurrent.Async (wait, withAsync) +import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar) +import Control.Concurrent.STM (atomically, check) +import Control.Monad (replicateM_, void) +import Data.ByteString (ByteString) +import qualified Data.Aeson as J import Data.IORef (readIORef) -import Data.Time.Clock (diffUTCTime, getCurrentTime) -import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds) +import Data.Maybe (fromJust, fromMaybe, isJust) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time.Clock (NominalDiffTime, UTCTime, addUTCTime, diffUTCTime, getCurrentTime) +import Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds) import Data.Word (Word64) -import StoreService.Names.Abi (addressWord) -import StoreService.Names.Chain (Receipt (..), TxHash (..), newChainClient) -import StoreService.Names.Orders (Landing (..), confirmLanded) -import StoreService.Names.Registration (commitCalldata) +import Network.HTTP.Client (defaultManagerSettings, newManager) +import qualified Network.Wai.Handler.Warp as Warp +import Simplex.Messaging.Agent.Store.Common (withTransaction) +import Simplex.Messaging.Crypto (keccak256) +import Simplex.Messaging.Crypto.Secp256k1 (Secp256k1PrivateKey, signRecoverable) +import StoreService.Names.Abi (abiBytes, abiTuple, addressWord, AbiValue (..), selector, uint256) +import StoreService.Names.Chain (Block (..), ChainClient, Receipt (..), TxHash (..), TxRequest (..), blockAt, decodeSignedTx, newChainClient) +import StoreService.Names.Orders (Landing (..), OrdersEnv (..), confirmLanded) +import StoreService.Names.Phases (awaitChange) +import StoreService.Names.Registration (RegisterIntent (..), commitCalldata, registerIntentDigest, sponsorDomain) +import StoreService.Names.Reveal (intentOf) import StoreService.Names.Sender -import StoreService.Names.Store (NamePhase (..), NameRegistration (..), TxFor (..)) +import StoreService.Names.Store +import StoreService.Names.Turns (labelTurnCount, withLabelTurn) +import StoreService.Names.Worker +import StoreService.Web.Http (holdMicros, readLimit) +import StoreService.Web.Names (Route (..), namesApp) +import StoreService.Web.Names.Registration (registrationHandler) +import StoreService.Web.Server (WebEnv (..), webApp) +import System.Timeout (timeout) import Test.Hspec namesWorkerTests :: Spec namesWorkerTests = describe "StoreService names: worker" $ do + describe "commit" $ do + it "commits, waits for the reveal and revealAfter, and registers a code order, spending its code and publishing each change" testCommitWaitRegister + it "waits for a pending commit without sending another, following its fee-bumped replacement" testPendingCommit + it "goes to committed when the commit reverts UnexpiredCommitmentExists, in its dry run or mined, with the commitment's times" testUnexpiredCommitment + it "sends a commit mined out of gas again" testCommitOutOfGas + it "waits a second at the lapse second, and again when the dry run still reverts, then commits" testLapseSecond + it "clears a requeued order's stale intent before committing again after a lapse, and a third party's commitment's" testStaleIntent + it "keeps the phase while the latest block needs more than the fee cap, then commits" testFeeAboveCap + describe "writes" $ do + it "writes nothing when the registration changed since it was read" testLostRace + it "writes in the name's turn" testInNameTurn + describe "register" $ do + it "ends the later of two wallets' paid orders for one name taken, with its value kept" testTwoWallets + it "ends taken on any revert while the name is not available, releasing a code" testRevertTaken + it "ends failed on a revert while the name is available, alerting on InsufficientAllowance and keeping a code" testRevertFailed + it "clears the reveal on InvalidNonce, staying committed" testInvalidNonce + it "relays no intent past its deadline, ending failed" testExpiredIntent + it "writes failed only once no register can still be mined, and registered when the owner holds the name" testFailedOnlySettled + describe "lapse" $ do + it "ends a committed order not revealed by revealBefore failed, keeping its code" testLapseFailed + it "wakes a held poll with failed at the lapse, and answers an old version at once after it" testLapsePoll + describe "restart" $ + it "resumes every phase after a restart, a commit saved but not recorded included" testRestart + describe "lanes" $ do + it "starts a worker for each registration in its phases" testRunWorkers + it "releases the codes of code orders failed for 30 days, and no others" testCodeSweep describe "confirmation depth" $ it "judges a register landed by ownerOf only once the owner holds the name at the confirmation depth" testLandedAtDepth describe "sender" $ @@ -29,14 +83,524 @@ namesWorkerTests = describe "StoreService names: worker" $ do -- fixtures +data W = W + { wCtx :: Ctx, + wChain :: ChainClient, + wSender :: Sender, + wWorker :: Worker + } + +-- | The worker over the orders' store and fake node, with the registration poll as namesRoutes registers it. +withWorker :: (W -> IO a) -> IO a +withWorker action = withOrders $ \ctx@Ctx {cNode, cOrders, cWeb} -> do + answerCall cNode fakeController minCommitmentAgeCall $ Returns $ uint256 minAge + answerCall cNode fakeController maxCommitmentAgeCall $ Returns $ uint256 maxAge + answerUnowned ctx "alicebakery" + let web = cWeb {weOrders = Just cOrders} + routes path = registrationRoute path <|> codeRoutes cOrders (weProviders web) (weWaiters web) path + registrationRoute = \case + ["api", "registration", rid] -> Just Route {rMethod = "GET", rLimit = readLimit, rHandler = registrationHandler cOrders holdMicros rid} + _ -> Nothing + app req respond = fromMaybe (webApp web req respond) (namesApp (weHttp web) routes req respond) + mgr <- newManager defaultManagerSettings + Warp.testWithApplication (pure app) $ \port -> started ctx {cWeb = web, cClient = (mgr, "http://127.0.0.1:" <> show port)} >>= action + +-- | A new sender and worker over the same store, as after a restart. +started :: Ctx -> IO W +started wCtx@Ctx {cNode, cStore, cRandom, cClock, cOrders} = do + wChain <- newChainClient cRandom $ fakeChainConfig cNode + wSender <- newSender cRandom wChain cStore (readIORef cClock) + wWorker <- newWorker cOrders wChain wSender + pure W {wCtx, wChain, wSender, wWorker} + +minAge, maxAge :: Word64 +minAge = 60 +maxAge = 86400 + orderSeconds :: Word64 orderSeconds = floor $ utcTimeToPOSIXSeconds orderTime expiry :: Word64 expiry = orderSeconds + 2 * 31536000 +at :: Word64 -> UTCTime +at = posixSecondsToUTCTime . fromIntegral + +day :: NominalDiffTime +day = 86400 + +-- | Committed a minute before the order. +openPhase :: NameRegistration -> NameRegistration +openPhase r = (committedPhase r) {nrRevealAfter = Just (orderSeconds - minAge), nrRevealBefore = Just (orderSeconds - minAge + maxAge)} + +-- | The reveal the page sends for the label, its intent signed with the owner's key. +signedReveal :: Ctx -> Secp256k1PrivateKey -> Text -> NameRegistration -> IO NameReveal +signedReveal Ctx {cRandom, cOrders} key label r = do + let rv = reveal {rvLabel = label} + RegisterIntent {riRegistration} = intentOf (oeConfig cOrders) r rv + sig <- either (error . show) id <$> signRecoverable cRandom key (registerIntentDigest (sponsorDomain fakeChainId fakeSponsor) riRegistration (rvNonce rv) (rvDeadline rv)) + pure rv {rvSignature = sig} + +-- | The registration with the page's reveal accepted. +revealed :: Ctx -> Secp256k1PrivateKey -> Text -> NameRegistration -> IO NameRegistration +revealed ctx key label r = signedReveal ctx key label r >>= \rv -> rewrite ctx r (\o -> o {nrReveal = Just rv}) + +-- | Steps until the worker has nothing to do at once. +steps :: W -> NameRegistration -> IO Next +steps W {wWorker} NameRegistration {nrId} = go (10 :: Int) + where + go 0 = fail "the worker kept stepping" + go n = + stepRegistration wWorker nrId >>= \case + Again -> go (n - 1) + next -> pure next + +shape :: Next -> String +shape = \case + Done -> "Done" + Again -> "Again" + WaitUntil v t -> "WaitUntil " <> show v <> " " <> show t + Retry v reason -> "Retry " <> show v <> " " <> T.unpack reason + Await p -> "Await " <> show (ptHash p) + +awaiting :: Next -> IO PendingTx +awaiting = \case + Await p -> pure p + next -> fail $ "not awaiting a transaction: " <> shape next + +waitingUntil :: Next -> IO UTCTime +waitingUntil = \case + WaitUntil _ t -> pure t + next -> fail $ "not waiting: " <> shape next + +retrying :: Next -> IO () +retrying = \case + Retry {} -> pure () + next -> fail $ "not retrying: " <> shape next + +done :: Next -> IO () +done = \case + Done -> pure () + next -> fail $ "not done: " <> shape next + +-- | The raw transactions the node received, in the order they were sent. +sent :: W -> IO [ByteString] +sent W {wCtx = Ctx {cNode}} = sentTransactions cNode + +newestHash :: W -> IO TxHash +newestHash w = TxHash . keccak256 . last <$> sent w + +-- | Mines the newest transaction sent, with this status, and the blocks after it that settle it; the receipt's block. +mineNewest :: W -> Bool -> IO Word64 +mineNewest w@W {wCtx = Ctx {cNode}, wSender} ok = do + TxHash h <- newestHash w + block <- mine cNode [(h, ok)] + replicateM_ 2 $ mine cNode [] + followTransactions wSender + pure block + +blockTime :: W -> Word64 -> IO Word64 +blockTime W {wChain} n = either (error . show) blockTimestamp <$> blockAt wChain n + +commitmentsCall :: NameRegistration -> ByteString +commitmentsCall NameRegistration {nrCommitment} = selector "commitments(bytes32)" <> nrCommitment + +-- | The commitment's time on chain, 0 for none. +answerCommitment :: W -> NameRegistration -> Word64 -> IO () +answerCommitment W {wCtx = Ctx {cNode}} r t = answerCall cNode fakeController (commitmentsCall r) $ Returns $ uint256 t + +answerAvailable :: W -> Bool -> IO () +answerAvailable W {wCtx = Ctx {cNode}} available = answerCall cNode fakeController availableCall $ Returns $ uint256 (if available then 1 else 0 :: Int) + +-- | The dry runs revert with the contracts' error of this signature. +dryRunsRevert :: W -> ByteString -> ByteString -> IO () +dryRunsRevert W {wCtx = Ctx {cNode}} signature args = setFault cNode "eth_estimateGas" $ revertFault $ selector signature <> args + +dryRunsPass :: W -> IO () +dryRunsPass W {wCtx = Ctx {cNode}} = clearFault cNode "eth_estimateGas" + +-- | The action's result, failing unless it published the version it wrote to a poll held at the version before. +published :: W -> NameRegistration -> IO a -> IO a +published W {wCtx = ctx} r action = do + NameRegistration {nrId, nrVersion} <- stored ctx r + poll <- held ctx (0, 1) $ registrationPath nrId <> "?seenVersion=" <> show nrVersion + a <- action + (status, view) <- woken "the registration poll" poll + NameRegistration {nrVersion = written} <- stored ctx r + (status, field "version" view, written > nrVersion) `shouldBe` (200, Just (J.toJSON written), True) + pure a + +traverseFst :: (a -> IO c) -> (a, b) -> IO (c, b) +traverseFst f (a, b) = (,b) <$> f a + +codeOf :: Ctx -> PrepaidCode -> IO PrepaidCode +codeOf Ctx {cStore} PrepaidCode {pcId} = withTransaction cStore $ \db -> fromJust <$> getPrepaidCodeById db pcId + +nowOf :: Ctx -> IO UTCTime +nowOf Ctx {cClock} = readIORef cClock + -- tests +testCommitWaitRegister :: IO () +testCommitWaitRegister = withWorker $ \w@W {wCtx = ctx} -> do + (r, code) <- codeIn ctx 8 aliceOrder id + answerExpiry ctx "alicebakery" expiry + answerCommitment w r 0 + void $ published w r $ steps w r >>= awaiting + [commitRaw] <- sent w + committing <- stored ctx r + (nrPhase committing, nrCommitTx committing, nrVersion committing) `shouldBe` (PCommitting, Just (TxHash $ keccak256 commitRaw), nrVersion r + 1) + -- the commit in flight is waited for + steps w r >>= awaiting >>= (`shouldBe` TxHash (keccak256 commitRaw)) . ptHash + length <$> sent w `shouldReturn` 1 + commitBlock <- mineNewest w True + t <- blockTime w commitBlock + answerCommitment w r t + -- committed, waiting for the reveal until the lapse + published w r (steps w r >>= waitingUntil) `shouldReturn` at (t + maxAge + 1) + committed <- stored ctx r + (nrPhase committed, nrRevealAfter committed, nrRevealBefore committed, nrCommitTx committed, nrCommitBlock committed) + `shouldBe` (PCommitted, Just (t + minAge), Just (t + maxAge), Just (TxHash $ keccak256 commitRaw), Just commitBlock) + -- the page reveals before revealAfter + void $ revealed ctx keyA "alicebakery" r + steps w r >>= waitingUntil >>= (`shouldBe` at (t + minAge)) + advance ctx $ fromIntegral (t + minAge) - fromIntegral orderSeconds + void $ published w r $ steps w r >>= awaiting + registerTx <- newestHash w + registering <- stored ctx r + (nrPhase registering, nrRegisterTx registering) `shouldBe` (PRegistering, Just registerTx) + registerBlock <- mineNewest w True + now <- nowOf ctx + published w r (steps w r) >>= done + x <- stored ctx r + (nrPhase x, nrRegisterTx x, nrRegisterBlock x, nrExpiresAt x, nrRegisteredAt x, nrLive x) `shouldBe` (PRegistered, Just registerTx, Just registerBlock, Just expiry, Just now, False) + isJust . pcSpentAt <$> codeOf ctx code `shouldReturn` True + steps w r >>= done + +testPendingCommit :: IO () +testPendingCommit = withWorker $ \w@W {wCtx = ctx@Ctx {cNode}, wSender} -> do + r <- paidIn ctx aliceOrder id + answerCommitment w r 0 + first <- ptHash <$> (steps w r >>= awaiting) + replicateM_ 3 $ steps w r >>= awaiting >>= (`shouldBe` first) . ptHash + length <$> sent w `shouldReturn` 1 + -- the market's fees pass the commit's, so the sender replaces it + setFees cNode (2 * fakeTip) (2 * fakeBaseFee) + advance ctx 181 + followTransactions wSender + replacement <- newestHash w + replacement `shouldNotBe` first + inFlight <- stored ctx r + steps w r >>= awaiting >>= (`shouldBe` replacement) . ptHash + x <- stored ctx r + (nrPhase x, nrCommitTx x, nrVersion x) `shouldBe` (PCommitting, Just replacement, nrVersion inFlight + 1) + length <$> sent w `shouldReturn` 2 + +testUnexpiredCommitment :: IO () +testUnexpiredCommitment = withWorker $ \w@W {wCtx = ctx@Ctx {cNode}} -> do + -- an earlier commit of the commitment mined between the read and the dry run + r <- paidIn ctx aliceOrder id + let t = orderSeconds - 600 + answerCommitment w r t + answerCallOnce cNode fakeController (commitmentsCall r) $ Returns $ uint256 (0 :: Int) + dryRunsRevert w "UnexpiredCommitmentExists(bytes32)" (nrCommitment r) + steps w r >>= waitingUntil >>= (`shouldBe` addUTCTime 1 orderTime) + sent w `shouldReturn` [] + stored ctx r `shouldReturn` r + dryRunsPass w + steps w r >>= waitingUntil >>= (`shouldBe` at (t + maxAge + 1)) + x <- stored ctx r + (nrPhase x, nrRevealAfter x, nrRevealBefore x, nrCommitTx x) `shouldBe` (PCommitted, Just (t + minAge), Just (t + maxAge), Nothing) + -- a commit sent, mined with status 0 after another commit of it + r2 <- paidIn ctx (byB aliceOrder) {oCommitment = commitmentOf 2} id + answerCommitment w r2 0 + void $ steps w r2 >>= awaiting + void $ mineNewest w False + let t2 = orderSeconds - 30 + answerCommitment w r2 t2 + steps w r2 >>= waitingUntil >>= (`shouldBe` at (t2 + maxAge + 1)) + x2 <- stored ctx r2 + (nrPhase x2, nrRevealBefore x2, nrCommitTx x2, nrCommitBlock x2) `shouldBe` (PCommitted, Just (t2 + maxAge), Nothing, Nothing) + length <$> sent w `shouldReturn` 1 + +testCommitOutOfGas :: IO () +testCommitOutOfGas = withWorker $ \w@W {wCtx = ctx} -> do + r <- paidIn ctx aliceOrder id + answerCommitment w r 0 + first <- ptHash <$> (steps w r >>= awaiting) + void $ mineNewest w False + second <- ptHash <$> (steps w r >>= awaiting) + second `shouldNotBe` first + [_, raw] <- sent w + trNonce <$> either error pure (decodeSignedTx raw) `shouldReturn` 1 + x <- stored ctx r + (nrPhase x, nrCommitTx x) `shouldBe` (PCommitting, Just second) + +testLapseSecond :: IO () +testLapseSecond = withWorker $ \w@W {wCtx = ctx} -> do + r <- paidIn ctx aliceOrder id + -- a live commitment with less than the reveal margin left is not reused + answerCommitment w r (orderSeconds + 600 - maxAge) + steps w r >>= waitingUntil >>= (`shouldBe` addUTCTime 601 orderTime) + -- at the lapse second it can neither register nor be committed again + advance ctx 600 + steps w r >>= waitingUntil >>= (`shouldBe` addUTCTime 601 orderTime) + stored ctx r `shouldReturn` r + advance ctx 1 + -- the node's latest block is still at the lapse second + dryRunsRevert w "UnexpiredCommitmentExists(bytes32)" (nrCommitment r) + steps w r >>= waitingUntil >>= (`shouldBe` addUTCTime 602 orderTime) + sent w `shouldReturn` [] + stored ctx r `shouldReturn` r + dryRunsPass w + advance ctx 1 + void $ steps w r >>= awaiting + nrPhase <$> stored ctx r `shouldReturn` PCommitting + length <$> sent w `shouldReturn` 1 + +testStaleIntent :: IO () +testStaleIntent = withWorker $ \w@W {wCtx = ctx} -> do + -- requeued by Try again with its intent, its commitment lapsed + r <- paidIn ctx aliceOrder $ \o -> (openPhase o) {nrPhase = PQueued, nrReveal = Just reveal} + answerCommitment w r (orderSeconds - maxAge - 1) + void $ steps w r >>= awaiting + x <- stored ctx r + commitTx <- newestHash w + (nrPhase x, nrReveal x, nrRevealAfter x, nrRevealBefore x, nrCommitTx x, nrVersion x) `shouldBe` (PCommitting, Nothing, Nothing, Nothing, Just commitTx, nrVersion r + 2) + -- requeued with its intent while a third party's commit of the commitment is live: not ours, so the intent goes + r2 <- paidIn ctx (byB aliceOrder) {oCommitment = commitmentOf 2} $ \o -> (openPhase o) {nrPhase = PQueued, nrReveal = Just reveal} + answerCommitment w r2 (orderSeconds - 60) + steps w r2 >>= waitingUntil >>= (`shouldBe` at (orderSeconds - 60 + maxAge + 1)) + x2 <- stored ctx r2 + (nrPhase x2, nrReveal x2, nrCommitTx x2, nrRevealBefore x2) `shouldBe` (PCommitted, Nothing, Nothing, Just (orderSeconds - 60 + maxAge)) + length <$> sent w `shouldReturn` 1 + +testFeeAboveCap :: IO () +testFeeAboveCap = withWorker $ \w@W {wCtx = ctx@Ctx {cNode}} -> do + r <- paidIn ctx aliceOrder id + answerCommitment w r 0 + setFees cNode fakeTip fakeMaxFeePerGas + steps w r >>= retrying + stored ctx r `shouldReturn` r + sent w `shouldReturn` [] + setFees cNode fakeTip fakeBaseFee + void $ steps w r >>= awaiting + nrPhase <$> stored ctx r `shouldReturn` PCommitting + +testLostRace :: IO () +testLostRace = withWorker $ \w@W {wCtx = ctx@Ctx {cNode}, wWorker} -> do + r <- paidIn ctx aliceOrder openPhase >>= revealed ctx keyA "alicebakery" + answerAvailable w False + dryRunsRevert w "NameNotAvailable(string)" $ abiTuple [Dynamic $ abiBytes "alicebakery"] + -- held at the register check's ownerOf read, after the registration was read + (stepping, gate) <- pausedAt cNode "eth_call" $ stepRegistration wWorker (nrId r) + changed <- rewrite ctx r $ \o -> o {nrRevealAfter = (+ 1) <$> nrRevealAfter o} + releaseGate gate + timeout prompt (wait stepping) >>= maybe (fail "the step did not finish") (pure . shape) >>= (`shouldBe` "Again") + stored ctx r `shouldReturn` changed + -- held at the commitment's read, a fresh worker's first chain read + r2 <- paidIn ctx (byB aliceOrder) {oCommitment = commitmentOf 2} id + answerCommitment w r2 $ orderSeconds - 60 + W {wWorker = fresh} <- started ctx + (stepping', gate') <- pausedAt cNode "eth_call" $ stepRegistration fresh (nrId r2) + changed' <- rewrite ctx r2 $ \o -> o {nrError = Just "changed"} + releaseGate gate' + timeout prompt (wait stepping') >>= maybe (fail "the step did not finish") (pure . shape) >>= (`shouldBe` "Again") + stored ctx r2 `shouldReturn` changed' + +testInNameTurn :: IO () +testInNameTurn = withWorker $ \w@W {wCtx = ctx@Ctx {cOrders}} -> do + r <- paidIn ctx aliceOrder committedPhase + advance ctx $ day + 1 + holding <- newEmptyMVar + release <- newEmptyMVar + withAsync (withLabelTurn (oeTurns cOrders) (nrLabelHash r) $ putMVar holding () >> takeMVar release) $ \_ -> do + takeMVar holding + withAsync (steps w r) $ \stepping -> do + -- the lapse's write waits for the turn the holder has + timeout prompt (atomically $ labelTurnCount (oeTurns cOrders) (nrLabelHash r) >>= check . (== 2)) >>= maybe (fail "the worker did not queue on the turn") pure + stored ctx r `shouldReturn` r + putMVar release () + timeout prompt (wait stepping) >>= maybe (fail "the step did not finish") done + nrPhase <$> stored ctx r `shouldReturn` PFailed + +testTwoWallets :: IO () +testTwoWallets = withWorker $ \w@W {wCtx = ctx} -> do + a <- paidIn ctx aliceOrder openPhase >>= revealed ctx keyA "alicebakery" + b <- paidIn ctx (byB aliceOrder) {oCommitment = commitmentOf 2} openPhase >>= revealed ctx keyB "alicebakery" + answerExpiry ctx "alicebakery" expiry + void $ steps w a >>= awaiting + void $ mineNewest w True + steps w a >>= done + nrPhase <$> stored ctx a `shouldReturn` PRegistered + answerOwner ctx "alicebakery" (nrOwner a) + answerAvailable w False + dryRunsRevert w "NameNotAvailable(string)" $ abiTuple [Dynamic $ abiBytes "alicebakery"] + published w b (steps w b) >>= done + x <- stored ctx b + (nrPhase x, nrLive x, nrPrice x, nrPayment x, nrError x) `shouldBe` (PTaken, True, nrPrice b, nrPayment b, Nothing) + length <$> sent w `shouldReturn` 1 + +testRevertTaken :: IO () +testRevertTaken = withWorker $ \w@W {wCtx = ctx@Ctx {cNode}} -> do + (r, code) <- codeIn ctx 8 aliceOrder openPhase >>= traverseFst (revealed ctx keyA "alicebakery") + answerAvailable w False + -- a reason kept in the message without data: not one of the contracts' errors + setFault cNode "eth_estimateGas" $ RpcError 3 "execution reverted: ERC721: invalid token ID" Nothing + published w r (steps w r) >>= done + x <- stored ctx r + (nrPhase x, nrLive x) `shouldBe` (PTaken, False) + PrepaidCode {pcReservedBy, pcSpentAt} <- codeOf ctx code + (pcReservedBy, pcSpentAt) `shouldBe` (Nothing, Nothing) + sent w `shouldReturn` [] + +testRevertFailed :: IO () +testRevertFailed = withWorker $ \w@W {wCtx = ctx@Ctx {cNode}} -> do + (r, code) <- codeIn ctx 8 aliceOrder openPhase >>= traverseFst (revealed ctx keyA "alicebakery") + answerAvailable w True + -- viem's encodeErrorResult of InsufficientAllowance(10000, 2500) + setFault cNode "eth_estimateGas" $ revertFault $ unhex "2a1b2dd8000000000000000000000000000000000000000000000000000000000000271000000000000000000000000000000000000000000000000000000000000009c4" + logs <- capturingStderr $ steps w r >>= done + logs `shouldSatisfy` T.isInfixOf "setRegistrarAllowance" + now <- nowOf ctx + x <- stored ctx r + (nrPhase x, nrFailedAt x, nrError x, nrLive x) `shouldBe` (PFailed, Just now, Just "The name could not be registered", True) + pcReservedBy <$> codeOf ctx code `shouldReturn` Just (nrId r) + -- a revert without data while the name is available fails a paid order too + p <- paidIn ctx dynamisOrder openPhase >>= revealed ctx keyA "dynamis" + answerCall cNode fakeController (selector "available(string)" <> abiTuple [Dynamic $ abiBytes "dynamis"]) $ Returns $ uint256 (1 :: Int) + answerUnowned ctx "dynamis" + setFault cNode "eth_estimateGas" $ RpcError (-32000) "execution reverted" Nothing + steps w p >>= done + nrPhase <$> stored ctx p `shouldReturn` PFailed + sent w `shouldReturn` [] + +testInvalidNonce :: IO () +testInvalidNonce = withWorker $ \w@W {wCtx = ctx} -> do + r <- paidIn ctx aliceOrder openPhase >>= revealed ctx keyA "alicebakery" + dryRunsRevert w "InvalidNonce()" "" + published w r (steps w r >>= waitingUntil) `shouldReturn` at (orderSeconds - minAge + maxAge + 1) + x <- stored ctx r + (nrPhase x, nrReveal x, nrVersion x, nrRevealBefore x) `shouldBe` (PCommitted, Nothing, nrVersion r + 1, nrRevealBefore r) + sent w `shouldReturn` [] + +testExpiredIntent :: IO () +testExpiredIntent = withWorker $ \w@W {wCtx = ctx} -> do + r <- paidIn ctx aliceOrder (\o -> (openPhase o) {nrRevealBefore = Just (rvDeadline reveal)}) >>= revealed ctx keyA "alicebakery" + answerAvailable w True + advance ctx $ fromIntegral (rvDeadline reveal - orderSeconds) + 1 + steps w r >>= done + nrPhase <$> stored ctx r `shouldReturn` PFailed + sent w `shouldReturn` [] + +testFailedOnlySettled :: IO () +testFailedOnlySettled = withWorker $ \w@W {wCtx = ctx@Ctx {cNode}, wSender} -> do + r <- paidIn ctx aliceOrder openPhase >>= revealed ctx keyA "alicebakery" + r2 <- paidIn ctx (byB aliceOrder) {oCommitment = commitmentOf 2} (\o -> (openPhase o) {nrRevealBefore = Just (orderSeconds + 3 * 86400)}) >>= revealed ctx keyB "alicebakery" + answerAvailable w True + p <- steps w r >>= awaiting + -- past revealBefore, the register in flight can still be mined + advance ctx $ 2 * day + steps w r >>= awaiting >>= (`shouldBe` ptHash p) . ptHash + nrPhase <$> stored ctx r `shouldReturn` PRegistering + void $ mineNewest w False + steps w r >>= done + nrPhase <$> stored ctx r `shouldReturn` PFailed + -- a register whose nonce another transaction took, while the owner holds the name: it went through + p2 <- steps w r2 >>= awaiting + useNextNonce cNode + followTransactions wSender + steps w r2 >>= awaiting >>= (`shouldBe` ptHash p2) . ptHash + replicateM_ 2 $ mine cNode [] + followTransactions wSender + answerOwner ctx "alicebakery" (nrOwner r2) + answerExpiry ctx "alicebakery" expiry + steps w r2 >>= done + x2 <- stored ctx r2 + (nrPhase x2, nrExpiresAt x2) `shouldBe` (PRegistered, Just expiry) + +testLapseFailed :: IO () +testLapseFailed = withWorker $ \w@W {wCtx = ctx} -> do + (r, code) <- codeIn ctx 8 aliceOrder committedPhase + steps w r >>= waitingUntil >>= (`shouldBe` at (orderSeconds + maxAge + 1)) + advance ctx $ day + 1 + published w r (steps w r) >>= done + now <- nowOf ctx + x <- stored ctx r + (nrPhase x, nrFailedAt x, nrError x, nrLive x) `shouldBe` (PFailed, Just now, Just "The name was not signed in time", True) + pcReservedBy <$> codeOf ctx code `shouldReturn` Just (nrId r) + +testLapsePoll :: IO () +testLapsePoll = withWorker $ \w@W {wCtx = ctx@Ctx {cClient}} -> do + r <- paidIn ctx aliceOrder committedPhase + advance ctx $ day + 1 + let path = registrationPath (nrId r) <> "?seenVersion=" <> show (nrVersion r) + -- the lapse alone changes no version, so a poll with the version seen before it is held + poll <- held ctx (0, 1) path + steps w r >>= done + (status, view) <- woken "the poll held at the lapse" poll + (status, field "version" view, field "phase" view) `shouldBe` (200, Just (J.toJSON $ nrVersion r + 1), Just "failed") + started' <- getCurrentTime + (status', view') <- timeout prompt (webGet cClient path >>= \resp -> (statusOf resp,) <$> jsonObject resp) >>= maybe (fail "the old version was held") pure + waited <- (`diffUTCTime` started') <$> getCurrentTime + (status', field "phase" view', waited < 2) `shouldBe` (200, Just "failed", True) + +testRestart :: IO () +testRestart = withWorker $ \w@W {wCtx = ctx@Ctx {cStore}, wSender} -> do + (r, code) <- codeIn ctx 8 aliceOrder id + answerExpiry ctx "alicebakery" expiry + answerCommitment w r 0 + -- the commit saved and sent, the service stopped before recording committing + Right p <- submitTransaction wSender (TxCommit $ nrId r) fakeController (commitCalldata $ nrCommitment r) + w1 <- started ctx + steps w1 r >>= awaiting >>= (`shouldBe` ptHash p) . ptHash + x <- stored ctx r + (nrPhase x, nrCommitTx x) `shouldBe` (PCommitting, Just (ptHash p)) + length <$> sent w `shouldReturn` 1 + commitBlock <- mineNewest w1 True + t <- blockTime w1 commitBlock + answerCommitment w r t + w2 <- started ctx + void $ steps w2 r >>= waitingUntil + nrPhase <$> stored ctx r `shouldReturn` PCommitted + void $ revealed ctx keyA "alicebakery" r + advance ctx $ fromIntegral (t + minAge) - fromIntegral orderSeconds + register <- steps w2 r >>= awaiting + w3 <- started ctx + steps w3 r >>= awaiting >>= (`shouldBe` ptHash register) . ptHash + nrPhase <$> stored ctx r `shouldReturn` PRegistering + void $ mineNewest w3 True + w4 <- started ctx + steps w4 r >>= done + nrPhase <$> stored ctx r `shouldReturn` PRegistered + isJust . pcSpentAt <$> codeOf ctx code `shouldReturn` True + map ntStatus <$> withTransaction cStore (`registrationTransactions` nrId r) `shouldReturn` [TSMined, TSMined] + length <$> sent w `shouldReturn` 2 + +testRunWorkers :: IO () +testRunWorkers = withWorker $ \w@W {wCtx = ctx@Ctx {cNode, cOrders}, wWorker} -> do + r <- paidIn ctx aliceOrder id + (unpaid, _) <- placed ctx (byB aliceOrder) {oCommitment = commitmentOf 2} + answerCommitment w r 0 + withAsync (runWorkers wWorker) $ \_ -> do + timeout prompt (awaitSent cNode 1) >>= maybe (fail "no commit was sent") (const $ pure ()) + changed <- awaitChange (oePhases cOrders) (nrId r) (nrVersion <$> stored ctx r) (nrVersion r) prompt + changed `shouldBe` True + nrPhase <$> stored ctx r `shouldReturn` PCommitting + nrPhase <$> invoiceRegistration ctx unpaid `shouldReturn` PUnpaid + length <$> sent w `shouldReturn` 1 + +testCodeSweep :: IO () +testCodeSweep = withWorker $ \W {wCtx = ctx, wWorker} -> do + (old, oldCode) <- codeIn ctx 8 aliceOrder failedPhase + (recent, recentCode) <- codeIn ctx 7 dynamisOrder $ \x -> (failedPhase x) {nrFailedAt = Just $ addUTCTime (2 * day) orderTime} + -- failed long ago, then requeued by Try again + (requeued, requeuedCode) <- codeIn ctx 8 (byB aliceOrder) {oCommitment = commitmentOf 2} $ \x -> (failedPhase x) {nrPhase = PQueued} + advance ctx $ 31 * day + sweepFailedCodes wWorker + map pcReservedBy <$> mapM (codeOf ctx) [oldCode, recentCode, requeuedCode] `shouldReturn` [Nothing, Just (nrId recent), Just (nrId requeued)] + mapM (stored ctx) [old, recent, requeued] `shouldReturn` [old, recent, requeued] + testLandedAtDepth :: IO () testLandedAtDepth = withOrders $ \ctx@Ctx {cNode, cOrders} -> do r <- paidIn ctx aliceOrder failedPhase @@ -50,18 +614,18 @@ testLandedAtDepth = withOrders $ \ctx@Ctx {cNode, cOrders} -> do -- confirmations 3: two more blocks put it at the depth replicateM_ 2 $ mine cNode [] confirmLanded cOrders r `shouldReturn` LRegistered (nrVersion r + 1) - NameRegistration {nrPhase, nrExpiresAt, nrRegisterTx} <- stored ctx r - (nrPhase, nrExpiresAt, nrRegisterTx) `shouldBe` (PRegistered, Just expiry, Nothing) + x <- stored ctx r + (nrPhase x, nrExpiresAt x, nrRegisterTx x) `shouldBe` (PRegistered, Just expiry, Nothing) testOutcomeBound :: IO () -testOutcomeBound = withOrders $ \ctx@Ctx {cNode, cStore, cRandom, cClock} -> do +testOutcomeBound = bounded "the outcome's wait" $ withOrders $ \ctx@Ctx {cNode, cStore, cRandom, cClock} -> do r@NameRegistration {nrId, nrCommitment} <- paidIn ctx aliceOrder id chain <- newChainClient cRandom $ fakeChainConfig cNode sender <- newSender cRandom chain cStore (readIORef cClock) Right p <- submitTransaction sender (TxCommit nrId) fakeController (commitCalldata nrCommitment) - started <- getCurrentTime + started' <- getCurrentTime awaitOutcome shortWait p `shouldReturn` Nothing - waited <- (`diffUTCTime` started) <$> getCurrentTime + waited <- (`diffUTCTime` started') <$> getCurrentTime waited `shouldSatisfy` (< 2) let TxHash h = ptHash p block <- mine cNode [(h, True)]