From 543fd96b1dd815e07601556072fbf1a90dd09b11 Mon Sep 17 00:00:00 2001 From: shum Date: Thu, 22 Oct 2026 08:36:20 +0000 Subject: [PATCH 1/2] store: share the commitment reuse rule --- .../src/StoreService/Names/Worker.hs | 21 ++++++++++++------- 1 file changed, 14 insertions(+), 7 deletions(-) diff --git a/apps/simplex-store-service/src/StoreService/Names/Worker.hs b/apps/simplex-store-service/src/StoreService/Names/Worker.hs index 514a959c3d..1e4b7df32d 100644 --- a/apps/simplex-store-service/src/StoreService/Names/Worker.hs +++ b/apps/simplex-store-service/src/StoreService/Names/Worker.hs @@ -167,17 +167,24 @@ commit w@Worker {wkOrders = OrdersEnv {oeContracts}, wkSender} now r@NameRegistr 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. +-- | At the lapse second a commitment 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 +fromCommitment w@Worker {wkOrders = OrdersEnv {oeConfig}} now r ages t + | reusable oeConfig now lapse = toCommitted w now r ages t + | lapse >= unixSeconds now = 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 + lapse = commitmentLapse ages t + +-- | The revealBefore of a commitment committed at this time. +commitmentLapse :: CommitmentAges -> Word64 -> Integer +commitmentLapse CommitmentAges {caMax} t = toInteger t + caMax + +-- | A live commitment is reused while revealMargin is left before its lapse, time for the page's reveal and the register to mine. +reusable :: NamesConfig -> UTCTime -> Integer -> Bool +reusable NamesConfig {nRevealMarginSeconds} now lapse = lapse - unixSeconds now >= toInteger nRevealMarginSeconds -- | 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 From 65b5d527c2dbe64a89297edd021c4f3e265de9a6 Mon Sep 17 00:00:00 2001 From: shum Date: Thu, 22 Oct 2026 08:39:45 +0000 Subject: [PATCH 2/2] store: queue a failed order again on Try again --- .../src/StoreService/Names/Worker.hs | 76 ++++- .../src/StoreService/Web/Names.hs | 3 +- .../StoreService/Web/Names/Registration.hs | 43 ++- .../StoreService/GroupIntegrationTests.hs | 9 +- tests/Bots/StoreService/NamesOwnerTests.hs | 1 + tests/Bots/StoreService/NamesWorkerTests.hs | 303 +++++++++++++++++- 6 files changed, 406 insertions(+), 29 deletions(-) diff --git a/apps/simplex-store-service/src/StoreService/Names/Worker.hs b/apps/simplex-store-service/src/StoreService/Names/Worker.hs index 1e4b7df32d..b8505dea1e 100644 --- a/apps/simplex-store-service/src/StoreService/Names/Worker.hs +++ b/apps/simplex-store-service/src/StoreService/Names/Worker.hs @@ -2,8 +2,9 @@ {-# 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. +-- | Each registration from queued to registered, taken or failed: its commit, the wait for the page's reveal, and its register; +-- and Try again, which queues a failed one again. 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 (..), @@ -13,6 +14,9 @@ module StoreService.Names.Worker sweepFailedCodes, runCodeSweep, maxUnexpiredWaits, + Retried (..), + RetryRefusal (..), + retryRegistration, ) where @@ -36,8 +40,8 @@ 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.Codes (CodeRefusal (..), codeRefusal, releaseCode, reserveCode) +import StoreService.Names.Contracts (CommitmentAges (..), commitmentAges, commitmentTime, controllerAvailable, sponsorNonce) import StoreService.Names.Orders (Landing (..), OrdersEnv (..), WriteRefusal (..), confirmLanded, versionWritten) import StoreService.Names.Phases (RegistrationId (..), awaitChange, publish) import StoreService.Names.Registration (commitCalldata, registerWithCreditCalldata, sponsorDomain, verifyRegisterIntent) @@ -46,7 +50,7 @@ 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) +import StoreService.Names.View (lapseMoment, notSignedInTime, registrationAt, registrationVersion) data Worker = Worker { wkOrders :: OrdersEnv, @@ -366,6 +370,68 @@ unixSeconds = floor . utcTimeToPOSIXSeconds secondsTime :: Integer -> UTCTime secondsTime = posixSecondsToUTCTime . fromInteger +-- | What Try again did: the version it wrote, the order changed since it was read, or a refusal. +data Retried = RTWritten Int64 | RTChanged | RTRefused RetryRefusal + +data RetryRefusal = RFNotFailed | RFCode CodeRefusal | RFUnread + deriving (Eq, Show) + +-- | Try again, in the caller's turn of the order's name: registered when its register went through; else a code order's code +-- must still pay for it; else queued again at no charge, a released code reserved again in the code's turn. +retryRegistration :: OrdersEnv -> NameRegistration -> IO Retried +retryRegistration oe@OrdersEnv {oeNow} current = do + now <- oeNow + case registrationAt now current of + r@NameRegistration {nrPhase = PFailed} -> + confirmLanded oe r >>= \case + LRegistered v -> pure $ RTWritten v + LChanged -> pure RTChanged + LUnread -> pure $ RTRefused RFUnread + LNotLanded -> retryCode oe now r >>= either (pure . RTRefused . RFCode) (requeue oe now r) + _ -> pure $ RTRefused RFNotFailed + +-- | The code a code order still holds, though revoked or expired since, or a released one it can reserve again. +retryCode :: OrdersEnv -> UTCTime -> NameRegistration -> IO (Either CodeRefusal (Maybe PrepaidCode)) +retryCode OrdersEnv {oeStore} now NameRegistration {nrId, nrLength, nrPayment} = case nrPayment of + RPInvoice {} -> pure $ Right Nothing + RPCode codeId -> + withTransaction oeStore (`getPrepaidCodeById` codeId) <&> \case + Just code -> maybe (Right $ Just code) Left $ codeRefusal now nrId nrLength code + Nothing -> Left CRInvalid + +-- | The register's transactions, which confirmLanded has read, are cleared with the failure; the reveal unless its intent still serves. +requeue :: OrdersEnv -> UTCTime -> NameRegistration -> Maybe PrepaidCode -> IO Retried +requeue oe@OrdersEnv {oeStore, oeTurns} now r@NameRegistration {nrId, nrLength} code = + servingReveal oe now r >>= \case + Left e -> RTRefused RFUnread <$ logWarn ("names: a retry's chain read failed: " <> tshow e) + Right reveal -> do + let requeued = r {nrPhase = PQueued, nrReveal = reveal, nrFailedAt = Nothing, nrError = Nothing, nrRegisterTx = Nothing, nrRegisterBlock = Nothing} + write db = versionWritten <$> updateRegistration db requeued now + outcome <- case code of + Nothing -> Right <$> withTransaction oeStore write + Just PrepaidCode {pcCodeHash} -> reserveCode oeTurns oeStore now pcCodeHash nrId nrLength write + pure $ case outcome of + Left refusal -> RTRefused $ RFCode refusal + Right (Right v) -> RTWritten v + -- a failed order is already live, so only a changed version refuses the write + Right (Left _) -> RTChanged + +-- | The stored reveal while its intent can still register: the sponsor nonce unmoved, and the commitment live with revealMargin +-- left in a window the intent's deadline covers. A new commit or another's re-commit opens a window the old deadline cannot serve. +servingReveal :: OrdersEnv -> UTCTime -> NameRegistration -> IO (Either ChainError (Maybe NameReveal)) +servingReveal OrdersEnv {oeConfig, oeContracts} now NameRegistration {nrOwner, nrCommitment, nrReveal} = case nrReveal of + Nothing -> pure $ Right Nothing + Just rv@NameReveal {rvNonce, rvDeadline} -> runExceptT $ do + nonce <- ExceptT $ sponsorNonce oeContracts nrOwner + if nonce /= rvNonce + then pure Nothing + else do + ages <- ExceptT $ commitmentAges oeContracts + committedAt <- ExceptT $ commitmentTime oeContracts nrCommitment + pure $ case commitmentLapse ages <$> committedAt of + Just lapse | reusable oeConfig now lapse && lapse <= toInteger rvDeadline -> Just rv + _ -> Nothing + -- | 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 diff --git a/apps/simplex-store-service/src/StoreService/Web/Names.hs b/apps/simplex-store-service/src/StoreService/Web/Names.hs index 416a764123..3c50f68119 100644 --- a/apps/simplex-store-service/src/StoreService/Web/Names.hs +++ b/apps/simplex-store-service/src/StoreService/Web/Names.hs @@ -14,7 +14,7 @@ import StoreService.Web.Names.Codes (codeCheckHandler) import StoreService.Web.Names.Orders (codeOrderHandler) import StoreService.Web.Names.Owner (findHandler, retargetHandler, takenCodeHandler) import StoreService.Web.Names.Records (recordsHandler) -import StoreService.Web.Names.Registration (registrationHandler, revealHandler) +import StoreService.Web.Names.Registration (registrationHandler, retryHandler, revealHandler) import StoreService.Web.Names.Search (previewHandler, searchHandler) data Route = Route @@ -37,6 +37,7 @@ namesRoutes env@NamesEnv {neConfig, neStore, neContracts, neProfiles, neRecords, ["api", "registration", rid, "name"] -> Just Route {rMethod = "POST", rLimit = createLimit, rHandler = retargetHandler (ordersEnv env) rid} ["api", "registration", rid, "code"] -> Just Route {rMethod = "POST", rLimit = createLimit, rHandler = takenCodeHandler (ordersEnv env) rid} ["api", "registration", rid, "reveal"] -> Just Route {rMethod = "POST", rLimit = readLimit, rHandler = revealHandler (ordersEnv env) rid} + ["api", "registration", rid, "retry"] -> Just Route {rMethod = "POST", rLimit = createLimit, rHandler = retryHandler (ordersEnv env) rid} _ -> Nothing -- | Nothing for a path no route knows. The limit is taken only once the route and the method match. diff --git a/apps/simplex-store-service/src/StoreService/Web/Names/Registration.hs b/apps/simplex-store-service/src/StoreService/Web/Names/Registration.hs index 3e986e2391..ab5ce2883f 100644 --- a/apps/simplex-store-service/src/StoreService/Web/Names/Registration.hs +++ b/apps/simplex-store-service/src/StoreService/Web/Names/Registration.hs @@ -6,6 +6,7 @@ module StoreService.Web.Names.Registration ( registrationHandler, revealHandler, + retryHandler, registrationChangedResponse, registrationRefusalResponse, heldFor, @@ -35,7 +36,9 @@ import StoreService.Names.Reveal (RevealFields (..), RevealRefusal (..), SignedL import StoreService.Names.Store (NamePhase (..), NameRegistration (..), VersionWrite (..), getRegistration, updateRegistration) import StoreService.Names.Turns (withLabelTurn) import StoreService.Names.View (lapseMoment, registrationAt, registrationVersion, registrationView) +import StoreService.Names.Worker (Retried (..), RetryRefusal (..), retryRegistration) import StoreService.Web.Http (Respond, badRequest, invalidLink, jsonResponse, nameBodyBytes, notFound, providerUnavailable, readBoundedBody) +import StoreService.Web.Names.Codes (codeRefusalResponse) import Text.Read (readMaybe) -- | GET /api/registration/:id, held while its version is seenVersion. @@ -108,19 +111,45 @@ revealHandler env@OrdersEnv {oeStore, oeConfig, oeContracts, oeTurns, oePhases, RDGone -> respond notFound published = mapM_ (atomically . publish oePhases rid) +-- | POST /api/registration/:id/retry, Try again in the name's turn; the publish and the answer come after the turn. +retryHandler :: OrdersEnv -> Text -> Request -> Respond -> IO ResponseReceived +retryHandler env@OrdersEnv {oeStore, oeTurns, oePhases} ridText _ respond = + withTransaction oeStore (`getRegistration` rid) >>= \case + Nothing -> respond notFound + Just NameRegistration {nrLabelHash} -> withLabelTurn oeTurns nrLabelHash (decide nrLabelHash) >>= maybe (respond notFound) answer + where + rid = RegistrationId ridText + decide turnHash = withTransaction oeStore (`getRegistration` rid) >>= traverse (inTurn turnHash) + inTurn turnHash r + -- moved to another name while this request waited for the turn + | nrLabelHash r /= turnHash = pure RTChanged + | otherwise = retryRegistration env r + answer = \case + RTWritten v -> do + atomically $ publish oePhases rid v + respond . maybe notFound (jsonResponse status200) =<< currentView env rid + RTChanged -> respond =<< registrationChangedResponse env rid + RTRefused refusal -> do + logInfo ("POST /api/registration/:id/retry refused: " <> tshow refusal) + respond $ case refusal of + RFNotFailed -> badRequest + RFCode code -> codeRefusalResponse code + RFUnread -> providerUnavailable + -- | The registration's current view, for a request that lost the race to change it. registrationChangedResponse :: OrdersEnv -> RegistrationId -> IO Response registrationChangedResponse env = registrationRefusalResponse env "registration_changed" -- | A refusal with the registration's current view, so the page follows its state. registrationRefusalResponse :: OrdersEnv -> Text -> RegistrationId -> IO Response -registrationRefusalResponse OrdersEnv {oeStore, oeConfig, oeContracts, oeNow} tag rid = - withTransaction oeStore (`getRegistration` rid) >>= \case - Nothing -> pure notFound - Just r -> do - now <- oeNow - view <- registrationView oeStore oeConfig oeContracts (registrationAt now r) - pure $ jsonResponse status409 $ J.object ["error" .= tag, "registration" .= view] +registrationRefusalResponse env tag rid = maybe notFound refusal <$> currentView env rid + where + refusal view = jsonResponse status409 $ J.object ["error" .= tag, "registration" .= view] + +-- | The registration's view as it reads now. +currentView :: OrdersEnv -> RegistrationId -> IO (Maybe J.Value) +currentView OrdersEnv {oeStore, oeConfig, oeContracts, oeNow} rid = + withTransaction oeStore (`getRegistration` rid) >>= traverse (\r -> oeNow >>= \now -> registrationView oeStore oeConfig oeContracts (registrationAt now r)) -- | The hold, cut to end just past the next moment at which the answer changes with time alone. heldFor :: Int -> UTCTime -> [UTCTime] -> Int diff --git a/tests/Bots/StoreService/GroupIntegrationTests.hs b/tests/Bots/StoreService/GroupIntegrationTests.hs index 2431e0afba..f37bbb0f3d 100644 --- a/tests/Bots/StoreService/GroupIntegrationTests.hs +++ b/tests/Bots/StoreService/GroupIntegrationTests.hs @@ -137,7 +137,7 @@ badgeGroupIntegrationTests = do it "leaves a tracker it cannot edit alone rather than publishing the code again" testUneditableTrackerLeftAlone namesBootTests :: SpecWith TestParams -namesBootTests = it "boots with [names] and [chain], routing fixed /api/name paths ahead of a search, find ahead of registrations, registrations to GET, another name, a code and a reveal to POST, a path no route knows to 404, and code checks and orders under one limit" testNamesBoot +namesBootTests = it "boots with [names] and [chain], routing fixed /api/name paths ahead of a search, find ahead of registrations, registrations to GET, another name, a code, a reveal and a retry to POST, a path no route knows to 404, code checks and orders under one limit, and the owner's requests and retries under another" testNamesBoot testNamesBoot :: HasCallStack => TestParams -> IO () testNamesBoot ps = do @@ -172,6 +172,13 @@ testNamesBoot ps = do answer revealed {method = "POST", requestBody = RequestBodyLBS "{}"} `shouldReturn` (404, Just $ J.object ["error" J..= ("not_found" :: Text)]) revealedByGet <- httpLbs revealed mgr (statusCode $ responseStatus revealedByGet, lookup "Allow" $ responseHeaders revealedByGet) `shouldBe` (405, Just "POST") + retried <- request "/api/registration/t2Jk8RmQ4vXw9NcP3yLb6g/retry" + answer retried {method = "POST"} `shouldReturn` (404, Just $ J.object ["error" J..= ("not_found" :: Text)]) + retriedByGet <- httpLbs retried mgr + (statusCode $ responseStatus retriedByGet, lookup "Allow" $ responseHeaders retriedByGet) `shouldBe` (405, Just "POST") + -- another name, a code and the retry above took 3 of this client's 5 create requests a minute + replicateM_ 2 $ statusCode . responseStatus <$> httpLbs retried {method = "POST"} mgr `shouldReturn` 404 + statusCode . responseStatus <$> httpLbs retried {method = "POST"} mgr `shouldReturn` 429 -- the register above took the first of this client's 10 code requests a minute, which the code check shares let codeRequest path = request path >>= \r -> statusCode . responseStatus <$> httpLbs r {method = "POST", requestBody = RequestBodyLBS "{}"} mgr forM_ (take 9 $ cycle ["/api/code/check", "/api/name/register"]) $ \path -> (path,) <$> codeRequest path `shouldReturn` (path, 400) diff --git a/tests/Bots/StoreService/NamesOwnerTests.hs b/tests/Bots/StoreService/NamesOwnerTests.hs index 4ed46414d4..f8ebc30fa1 100644 --- a/tests/Bots/StoreService/NamesOwnerTests.hs +++ b/tests/Bots/StoreService/NamesOwnerTests.hs @@ -21,6 +21,7 @@ module Bots.StoreService.NamesOwnerTests paidIn, postMove, rewrite, + sentRegister, stored, ) where diff --git a/tests/Bots/StoreService/NamesWorkerTests.hs b/tests/Bots/StoreService/NamesWorkerTests.hs index 178e374c70..7bb30fc745 100644 --- a/tests/Bots/StoreService/NamesWorkerTests.hs +++ b/tests/Bots/StoreService/NamesWorkerTests.hs @@ -6,19 +6,21 @@ module Bots.StoreService.NamesWorkerTests (namesWorkerTests) where import Bots.StoreService.FakeEthNode -import Bots.StoreService.NamesContractsTests (availableCall, maxCommitmentAgeCall, minCommitmentAgeCall, registrarOf, unhex) +import Bots.StoreService.NamesContractsTests (availableCall, maxCommitmentAgeCall, minCommitmentAgeCall, noncesCall, registrarOf, unhex) import Bots.StoreService.NamesOrdersTests -import Bots.StoreService.NamesOwnerTests (answerExpiry, answerOwner, answerUnowned, byB, codeIn, committedPhase, dynamisOrder, failedPhase, labelBytes, ownerOfSelector, paidIn, rewrite, stored) +import Bots.StoreService.NamesOwnerTests (answerExpiry, answerFree, answerOwner, answerUnowned, byB, codeIn, committedPhase, dynamisOrder, failedPhase, labelBytes, ownerOfSelector, paidIn, rewrite, sentRegister, stored) import Bots.StoreService.NamesPhasesTests (held, prompt, registrationPath, woken) import Bots.StoreService.NamesStoreTests (reveal) -import Bots.StoreService.WebTests (capturingStderr, jsonObject, statusOf, webGet) +import Bots.StoreService.WebTests (capturingStderr, jsonObject, statusOf, webGet, webRequestBody) import Control.Applicative ((<|>)) +import Control.Arrow ((&&&)) import Control.Concurrent.Async (wait, withAsync) import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar) import Control.Concurrent.STM (atomically, check) -import Control.Monad (forM_, replicateM_, void) +import Control.Monad (forM_, replicateM, replicateM_, void) import Data.ByteString (ByteString) import qualified Data.Aeson as J +import qualified Data.Aeson.KeyMap as KM import Data.IORef (readIORef) import Data.Maybe (fromJust, fromMaybe, isJust) import Data.Text (Text) @@ -29,9 +31,12 @@ import Data.Word (Word64) import Network.HTTP.Client (defaultManagerSettings, newManager) import qualified Network.Wai.Handler.Warp as Warp import Simplex.Messaging.Agent.Store.Common (withTransaction) +import qualified Simplex.Messaging.Agent.Store.DB as DB import Simplex.Messaging.Crypto (keccak256) import Simplex.Messaging.Crypto.Secp256k1 (Secp256k1PrivateKey, signRecoverable) -import StoreService.Names.Abi (abiBytes, abiTuple, addressWord, AbiValue (..), selector, uint256) +import Simplex.Messaging.SimplexName (labelHash) +import Simplex.Messaging.Util (tshow) +import StoreService.Names.Abi (abiBytes, abiTuple, addressWord, AbiValue (..), hex, 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 (RegistrationId (..), awaitChange) @@ -41,9 +46,9 @@ import StoreService.Names.Sender import StoreService.Names.Store import StoreService.Names.Turns (labelTurnCount, withLabelTurn) import StoreService.Names.Worker -import StoreService.Web.Http (holdMicros, readLimit) +import StoreService.Web.Http (createLimit, holdMicros, readLimit) import StoreService.Web.Names (Route (..), namesApp) -import StoreService.Web.Names.Registration (registrationHandler) +import StoreService.Web.Names.Registration (registrationHandler, retryHandler) import StoreService.Web.Server (WebEnv (..), webApp) import System.Timeout (timeout) import Test.Hspec @@ -86,6 +91,20 @@ namesWorkerTests = describe "StoreService names: worker" $ do it "judges a register landed by ownerOf only once the owner holds the name at the confirmation depth" testLandedAtDepth describe "sender" $ it "bounds the wait for a transaction's outcome" testOutcomeBound + describe "retry" $ do + it "refuses Try again outside failed with bad_request, changing nothing, and answers an unknown order 404" testRetryNotFailed + it "registers a failed order whose register went through: by its mined register after a redeem, spending its code, and by ownerOf with no register shown" testRetryLanded + it "answers provider_unavailable when the register check or a read for the stored intent fails, changing nothing" testRetryUnread + it "answers a released code's error while it cannot pay again, before any read for the intent, and reserves it again while unused" testRetryReleasedCode + it "requeues clearing failed_at, error and the register's hashes, waking a held poll" testRetryRequeue + it "keeps the intent while our commitment is live with revealMargin left, going straight to committed" testRetryLiveCommitment + it "clears the label and intent when the sponsor nonce moved, our live commit keeping its hashes" testRetryNonceMoved + it "clears the intent of a third party's live re-commit, and the worker the commit's hashes" testRetryThirdParty + it "clears the intent with less than revealMargin left, committing again a second after revealBefore" testRetryMargin + it "requeues a lapsed committed order, which reads failed, answering an old version at once after it" testRetryLapsed + it "answers registration_changed with the current view when the order changed during its checks, writing nothing" testRetryLostRace + it "runs in the name's turn, answering registration_changed for an order moved to another name meanwhile" testRetryInNameTurn + it "takes one create token per request" testRetryLimit -- fixtures @@ -96,7 +115,7 @@ data W = W wWorker :: Worker } --- | The worker over the orders' store and fake node, with the registration poll as namesRoutes registers it. +-- | The worker over the orders' store and fake node, with the registration poll and Try again as namesRoutes registers them. withWorker :: (W -> IO a) -> IO a withWorker action = withOrders $ \ctx@Ctx {cNode, cOrders, cWeb} -> do answerCall cNode fakeController minCommitmentAgeCall $ Returns $ uint256 minAge @@ -106,6 +125,7 @@ withWorker action = withOrders $ \ctx@Ctx {cNode, cOrders, cWeb} -> do 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} + ["api", "registration", rid, "retry"] -> Just Route {rMethod = "POST", rLimit = createLimit, rHandler = retryHandler cOrders rid} _ -> Nothing app req respond = fromMaybe (webApp web req respond) (namesApp (weHttp web) routes req respond) mgr <- newManager defaultManagerSettings @@ -139,17 +159,16 @@ day = 86400 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 +-- | The reveal the page sends, its intent signed with the owner's key. +signedReveal :: Ctx -> Secp256k1PrivateKey -> NameReveal -> NameRegistration -> IO NameReveal +signedReveal Ctx {cRandom, cOrders} key rv r = do + let 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. +-- | The registration with the page's reveal of the label 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}) +revealed ctx key label r = signedReveal ctx key reveal {rvLabel = 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 @@ -723,3 +742,257 @@ testOutcomeBound = withOrders $ \ctx@Ctx {cNode, cStore, cRandom, cClock} -> do stored ctx r `shouldReturn` r where shortWait = 300000 + +-- retry + +retryOf :: Ctx -> NameRegistration -> IO (Int, Maybe J.Object) +retryOf ctx NameRegistration {nrId} = post ctx (registrationPath nrId <> "/retry") "" + +-- | The view of an accepted Try again, failing the test otherwise. +retried :: Ctx -> NameRegistration -> IO J.Object +retried ctx r = + retryOf ctx r >>= \case + (200, Just v) -> pure v + other -> fail $ "retry refused: " <> show other + +viewOf :: Ctx -> NameRegistration -> IO J.Object +viewOf Ctx {cClient} NameRegistration {nrId} = webGet cClient (registrationPath nrId) >>= jsonObject + +answerNonce :: W -> Word64 -> IO () +answerNonce W {wCtx = Ctx {cNode}} n = answerCall cNode fakeSponsor noncesCall $ Returns $ uint256 n + +txJSON :: Maybe TxHash -> Maybe J.Value +txJSON = Just . maybe J.Null (\(TxHash h) -> J.String $ hex h) + +-- | Committed by the worker's own commit; its block's time. +committedByUs :: W -> NameRegistration -> IO (NameRegistration, Word64) +committedByUs w@W {wCtx = ctx} r = do + answerCommitment w r 0 + void $ steps w r >>= awaiting + t <- mineNewest w True >>= blockTime w + answerCommitment w r t + void $ steps w r >>= waitingUntil + (,t) <$> stored ctx r + +-- | Failed after its register reverted, with the intent the page signed for the commit's window. +failedAfterRegister :: W -> NameRegistration -> IO NameRegistration +failedAfterRegister W {wCtx = ctx} r = do + rv <- signedReveal ctx keyA reveal {rvDeadline = fromJust $ nrRevealBefore r} r + h <- sentRegister ctx r 2 TSReverted + rewrite ctx r $ \o -> (failedPhase o) {nrReveal = Just rv, nrRegisterTx = Just h, nrRegisterBlock = Just 120} + +testRetryNotFailed :: IO () +testRetryNotFailed = withWorker $ \W {wCtx = ctx} -> do + queued <- paidIn ctx aliceOrder id + committed <- paidIn ctx (byB aliceOrder) {oCommitment = commitmentOf 2} committedPhase + registeredOrder <- paidIn ctx dynamisOrder $ \o -> o {nrPhase = PRegistered, nrExpiresAt = Just expiry} + taken <- paidIn ctx (byB dynamisOrder) {oCommitment = commitmentOf 4} $ \o -> o {nrPhase = PTaken} + forM_ [queued, committed, registeredOrder, taken] $ \r -> do + (nrPhase r,) <$> retryOf ctx r `shouldReturn` (nrPhase r, refusedWith 400 "bad_request") + stored ctx r `shouldReturn` r + retryOf ctx queued {nrId = RegistrationId "t2Jk8RmQ4vXw9NcP3yLb6g"} `shouldReturn` refusedWith 404 "not_found" + +testRetryLanded :: IO () +testRetryLanded = withWorker $ \W {wCtx = ctx} -> do + -- redeemed since its register mined: the name left the owner, and the register consumed its commitment + (redeemed, code) <- codeIn ctx 8 aliceOrder failedPhase + TxHash minedHash <- sentRegister ctx redeemed 1 TSMined + answerExpiry ctx "alicebakery" expiry + v <- retried ctx redeemed + (field "phase" v, field "registerTx" v, field "expiresAt" v, field "error" v) `shouldBe` (Just "registered", Just (J.String $ hex minedHash), Just (J.toJSON expiry), Just J.Null) + x <- stored ctx redeemed + (nrPhase x, nrVersion x, nrFailedAt x, nrLive x) `shouldBe` (PRegistered, nrVersion redeemed + 1, Nothing, False) + isJust . pcSpentAt <$> codeOf ctx code `shouldReturn` True + -- no register known to have mined: judged by ownerOf, none is shown + owned <- paidIn ctx dynamisOrder failedPhase + answerOwner ctx "dynamis" (nrOwner owned) + answerExpiry ctx "dynamis" expiry + v' <- retried ctx owned + (field "phase" v', field "registerTx" v', field "expiresAt" v') `shouldBe` (Just "registered", Just J.Null, Just (J.toJSON expiry)) + +testRetryUnread :: IO () +testRetryUnread = withWorker $ \w@W {wCtx = ctx@Ctx {cNode}} -> do + r <- paidIn ctx aliceOrder failedPhase + -- a revert with data is a failed read, not an unowned name + answerCall cNode (registrarOf cNode) (ownerOfSelector <> labelBytes "alicebakery") $ Reverts $ unhex "37ed32e8" + retryOf ctx r `shouldReturn` refusedWith 503 "provider_unavailable" + stored ctx r `shouldReturn` r + -- with an intent stored, the sponsor nonce and then the commitment unanswered + p <- paidIn ctx dynamisOrder openPhase >>= revealed ctx keyA "dynamis" >>= \x -> rewrite ctx x failedPhase + answerUnowned ctx "dynamis" + retryOf ctx p `shouldReturn` refusedWith 503 "provider_unavailable" + answerNonce w $ rvNonce reveal + retryOf ctx p `shouldReturn` refusedWith 503 "provider_unavailable" + stored ctx p `shouldReturn` p + +testRetryReleasedCode :: IO () +testRetryReleasedCode = withWorker $ \W {wCtx = ctx@Ctx {cStore}} -> do + spender <- paidIn ctx (byB aliceOrder) {oCommitment = commitmentOf 20} id + holder <- paidIn ctx (byB dynamisOrder) {oCommitment = commitmentOf 21} id + let codeOrder n change = do + let label = "codeorder" <> tshow n + answerFree ctx label + codeIn ctx 8 aliceOrder {oLabel = label, oCommitment = commitmentOf (30 + n)} change + released (r, code) = (r, code) <$ (withTransaction cStore (\db -> releasePrepaidCode db (pcId code) (nrId r)) `shouldReturn` True) + refusals :: [(Text, PrepaidCode -> DB.Connection -> IO (), (Int, Maybe J.Object))] + refusals = + [ ("spent", \PrepaidCode {pcId} db -> reservePrepaidCode db pcId (nrId spender) orderTime >> void (spendPrepaidCode db pcId (nrId spender) orderTime), refusedWith 409 "code_used"), + ("held", \PrepaidCode {pcId} db -> void $ reservePrepaidCode db pcId (nrId holder) orderTime, refusedWith 409 "code_reserved"), + ("revoked", \PrepaidCode {pcCodeHash} db -> void $ revokePrepaidCode db pcCodeHash orderTime, refusedWith 400 "code_invalid"), + ("expired", \PrepaidCode {pcCodeHash} db -> expire db pcCodeHash, refusedWith 409 "code_expired") + ] + expire db codeHash = DB.execute db "UPDATE sx_badge_service_name_prepaid_codes SET expires_at = ? WHERE code_hash = ?" (orderTime, DB.Binary codeHash) + forM_ (zip [1 :: Int ..] refusals) $ \(n, (what, change, refusal)) -> do + (r, code) <- codeOrder n failedPhase >>= released + withTransaction cStore $ change code + (what,) <$> retryOf ctx r `shouldReturn` (what, refusal) + stored ctx r `shouldReturn` r + -- with an intent stored and the sponsor nonce unanswered, the code's error still comes first + (withIntent, spentCode) <- codeOrder 5 openPhase >>= traverseFst (revealed ctx keyA "codeorder5") >>= traverseFst (\x -> rewrite ctx x failedPhase) >>= released + -- a registration holds one code at most + answerFree ctx "anotherpays" + spender' <- paidIn ctx (byB aliceOrder) {oLabel = "anotherpays", oCommitment = commitmentOf 22} id + withTransaction cStore $ \db -> reservePrepaidCode db (pcId spentCode) (nrId spender') orderTime >> void (spendPrepaidCode db (pcId spentCode) (nrId spender') orderTime) + retryOf ctx withIntent `shouldReturn` refusedWith 409 "code_used" + -- a code its order still holds stays good for it, though revoked and expired since + (holding, heldCode@PrepaidCode {pcCodeHash}) <- codeOrder 6 failedPhase + withTransaction cStore $ \db -> revokePrepaidCode db pcCodeHash orderTime >> expire db pcCodeHash + field "phase" <$> retried ctx holding `shouldReturn` Just "queued" + pcReservedBy <$> codeOf ctx heldCode `shouldReturn` Just (nrId holding) + -- a released code still unused is reserved again + (unused, unusedCode) <- codeOrder 7 failedPhase >>= released + field "phase" <$> retried ctx unused `shouldReturn` Just "queued" + (pcReservedBy &&& pcSpentAt) <$> codeOf ctx unusedCode `shouldReturn` (Just (nrId unused), Nothing) + +testRetryRequeue :: IO () +testRetryRequeue = withWorker $ \w@W {wCtx = ctx} -> do + committed <- paidIn ctx aliceOrder openPhase + h <- sentRegister ctx committed 1 TSReverted + r <- rewrite ctx committed $ \o -> (failedPhase o) {nrRegisterTx = Just h, nrRegisterBlock = Just 120} + v <- published w r $ retried ctx r + (field "phase" v, field "registerTx" v, field "error" v, field "version" v) `shouldBe` (Just "queued", Just J.Null, Just J.Null, Just (J.toJSON $ nrVersion r + 1)) + x <- stored ctx r + (nrPhase x, nrFailedAt x, nrError x, nrRegisterTx x, nrRegisterBlock x, nrLive x) `shouldBe` (PQueued, Nothing, Nothing, Nothing, Nothing, True) + (nrCommitTx x, nrCommitBlock x, nrRevealAfter x, nrRevealBefore x) `shouldBe` (nrCommitTx r, nrCommitBlock r, nrRevealAfter r, nrRevealBefore r) + +testRetryLiveCommitment :: IO () +testRetryLiveCommitment = withWorker $ \w@W {wCtx = ctx} -> do + (r, t) <- paidIn ctx aliceOrder id >>= committedByUs w + f <- failedAfterRegister w r + answerNonce w $ rvNonce reveal + v <- retried ctx f + (field "phase" v, field "label" v) `shouldBe` (Just "queued", Just "alicebakery") + steps w f >>= waitingUntil >>= (`shouldBe` at (t + minAge)) + x <- stored ctx f + (nrPhase x, nrReveal x, nrCommitTx x, nrCommitBlock x, nrRevealBefore x) `shouldBe` (PCommitted, nrReveal f, nrCommitTx f, nrCommitBlock f, Just (t + maxAge)) + length <$> sent w `shouldReturn` 1 + +testRetryNonceMoved :: IO () +testRetryNonceMoved = withWorker $ \w@W {wCtx = ctx} -> do + (r, t) <- paidIn ctx aliceOrder id >>= committedByUs w + f <- failedAfterRegister w r + answerNonce w $ rvNonce reveal + 1 + v <- retried ctx f + (field "phase" v, field "label" v, field "commitTx" v) `shouldBe` (Just "queued", Just J.Null, txJSON (nrCommitTx f)) + nrReveal <$> stored ctx f `shouldReturn` Nothing + steps w f >>= waitingUntil >>= (`shouldBe` at (t + maxAge + 1)) + x <- stored ctx f + (nrPhase x, nrReveal x, nrCommitTx x, nrCommitBlock x, nrRevealBefore x) `shouldBe` (PCommitted, Nothing, nrCommitTx f, nrCommitBlock f, Just (t + maxAge)) + field "commitTx" <$> viewOf ctx f `shouldReturn` txJSON (nrCommitTx f) + +testRetryThirdParty :: IO () +testRetryThirdParty = withWorker $ \w@W {wCtx = ctx} -> do + (r, t) <- paidIn ctx aliceOrder id >>= committedByUs w + f <- failedAfterRegister w r + answerNonce w $ rvNonce reveal + -- our commitment lapsed, and someone committed it again + let t' = t + maxAge + 100 + answerCommitment w f t' + advance ctx $ fromIntegral (t' + 10 - orderSeconds) + v <- retried ctx f + (field "label" v, field "commitTx" v) `shouldBe` (Just J.Null, txJSON (nrCommitTx f)) + steps w f >>= waitingUntil >>= (`shouldBe` at (t' + maxAge + 1)) + x <- stored ctx f + (nrPhase x, nrReveal x, nrCommitTx x, nrCommitBlock x, nrRevealBefore x) `shouldBe` (PCommitted, Nothing, Nothing, Nothing, Just (t' + maxAge)) + field "commitTx" <$> viewOf ctx f `shouldReturn` Just J.Null + length <$> sent w `shouldReturn` 1 + +testRetryMargin :: IO () +testRetryMargin = withWorker $ \w@W {wCtx = ctx} -> do + (r, t) <- paidIn ctx aliceOrder id >>= committedByUs w + f <- failedAfterRegister w r + answerNonce w $ rvNonce reveal + let lapse = t + maxAge + advance ctx $ fromIntegral (lapse - 600 - orderSeconds) + field "label" <$> retried ctx f `shouldReturn` Just J.Null + steps w f >>= waitingUntil >>= (`shouldBe` at (lapse + 1)) + advance ctx 601 + void $ steps w f >>= awaiting + commitTx <- newestHash w + x <- stored ctx f + (nrPhase x, nrReveal x, nrCommitTx x, nrRevealBefore x) `shouldBe` (PCommitting, Nothing, Just commitTx, Nothing) + length <$> sent w `shouldReturn` 2 + +testRetryLapsed :: IO () +testRetryLapsed = withWorker $ \w@W {wCtx = ctx@Ctx {cClient}} -> do + (r, code) <- codeIn ctx 8 aliceOrder committedPhase + advance ctx $ day + 1 + -- the lapse alone changes no version, so a poll with the version seen before it is held + let path = registrationPath (nrId r) <> "?seenVersion=" <> show (nrVersion r) + poll <- held ctx (0, 1) path + v <- retried ctx r + (field "phase" v, field "version" v, field "error" v) `shouldBe` (Just "queued", Just (J.toJSON $ nrVersion r + 1), Just J.Null) + (status, view) <- woken "the poll held at the lapse" poll + (status, field "phase" view) `shouldBe` (200, Just "queued") + -- prompt is far below the 30-second hold + (status', view') <- timeout prompt (webGet cClient path >>= \resp -> (statusOf resp,) <$> jsonObject resp) >>= maybe (fail "the old version was held") pure + (status', field "version" view') `shouldBe` (200, Just (J.toJSON $ nrVersion r + 1)) + pcReservedBy <$> codeOf ctx code `shouldReturn` Just (nrId r) + -- the commitment lapsed, so the worker commits it again + answerCommitment w r $ fromJust (nrRevealBefore r) - maxAge + void $ steps w r >>= awaiting + nrPhase <$> stored ctx r `shouldReturn` PCommitting + +testRetryLostRace :: IO () +testRetryLostRace = withWorker $ \W {wCtx = ctx@Ctx {cNode}} -> do + r <- paidIn ctx aliceOrder failedPhase + -- held at the register check's ownerOf read, in the name's turn + (retrying', gate) <- pausedAt cNode "eth_call" $ retryOf ctx r + changed <- rewrite ctx r id + releaseGate gate + answer <- timeout prompt (wait retrying') >>= maybe (fail "the retry did not finish") pure + view <- viewOf ctx r + answer `shouldBe` (409, Just $ KM.fromList [("error", "registration_changed"), ("registration", J.Object view)]) + field "version" view `shouldBe` Just (J.toJSON $ nrVersion r + 1) + stored ctx r `shouldReturn` changed + +testRetryInNameTurn :: IO () +testRetryInNameTurn = withWorker $ \W {wCtx = ctx@Ctx {cOrders}} -> do + r <- paidIn ctx aliceOrder failedPhase + moving <- paidIn ctx (byB aliceOrder) {oCommitment = commitmentOf 2} failedPhase + answerUnowned ctx "dynamis" + let turns = oeTurns cOrders + whileHeld :: IO a -> IO () -> IO a + whileHeld request meanwhile = do + holding <- newEmptyMVar + release <- newEmptyMVar + withAsync (withLabelTurn turns (nrLabelHash r) $ putMVar holding () >> takeMVar release) $ \_ -> do + takeMVar holding + withAsync request $ \requesting -> do + timeout prompt (atomically $ labelTurnCount turns (nrLabelHash r) >>= check . (== 2)) >>= maybe (fail "the retry did not queue on the turn") pure + meanwhile + putMVar release () + timeout prompt (wait requesting) >>= maybe (fail "the retry did not finish") pure + (status, v) <- whileHeld (retryOf ctx r) (stored ctx r `shouldReturn` r) + (status, field "phase" =<< v) `shouldBe` (200, Just "queued") + -- moved to another name while the retry waited for the old name's turn + (status', v') <- whileHeld (retryOf ctx moving) (void $ rewrite ctx moving $ \o -> o {nrLabelHash = labelHash "dynamis", nrLength = 7}) + (status', field "error" =<< v') `shouldBe` (409, Just "registration_changed") + nrPhase <$> stored ctx moving `shouldReturn` PFailed + +testRetryLimit :: IO () +testRetryLimit = withWorker $ \W {wCtx = ctx@Ctx {cClient}} -> do + r <- paidIn ctx aliceOrder id + let fromClient = statusOf <$> webRequestBody cClient "POST" (registrationPath (nrId r) <> "/retry") [("X-Forwarded-For", "203.0.113.8")] "" + replicateM 5 fromClient `shouldReturn` replicate 5 400 + fromClient `shouldReturn` 429