store: register each order on chain in a worker

apps/simplex-store-service/src/StoreService/Names/Orders.hs

@@ -36,6 +36,7 @@ module StoreService.Names.Orders
     checkMoveMeets,
     checkMovePrice,
     retargetOrder,
+    versionWritten,
     confirmLanded,
     issuedCodeHash,
     checkTakenCodeLength,

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}

apps/simplex-store-service/src/StoreService/Names/View.hs

@@ -11,6 +11,7 @@ module StoreService.Names.View
     tldText,
     registrationAt,
     lapseMoment,
+    notSignedInTime,
     registrationVersion,
   )
 where

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

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

tests/Bots/StoreService/NamesContractsTests.hs

@@ -25,6 +25,9 @@ module Bots.StoreService.NamesContractsTests
     pricesAnswer,
     oracle,
     alice,
+    availableCall,
+    minCommitmentAgeCall,
+    maxCommitmentAgeCall,
     unhex,
   )
 where

tests/Bots/StoreService/NamesOwnerTests.hs

@@ -9,6 +9,7 @@ module Bots.StoreService.NamesOwnerTests
     answerFree,
     answerOwner,
     answerUnowned,
+    byB,
     codeIn,
     committedPhase,
     dynamisOrder,

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