From da97eafe3ac669ff515ccada61e2fa7124cd83d5 Mon Sep 17 00:00:00 2001 From: shum Date: Thu, 22 Oct 2026 04:55:21 +0000 Subject: [PATCH 1/7] store: reserve a code after the registration's write --- .../src/StoreService/Names/Codes.hs | 40 +++++++++++-------- tests/Bots/StoreService/NamesCodesTests.hs | 19 +++++++-- 2 files changed, 39 insertions(+), 20 deletions(-) diff --git a/apps/simplex-store-service/src/StoreService/Names/Codes.hs b/apps/simplex-store-service/src/StoreService/Names/Codes.hs index 5709fc1fc9..5b0d44c03d 100644 --- a/apps/simplex-store-service/src/StoreService/Names/Codes.hs +++ b/apps/simplex-store-service/src/StoreService/Names/Codes.hs @@ -21,6 +21,7 @@ module StoreService.Names.Codes where import Control.Applicative ((<|>)) +import qualified Control.Exception as E import Data.ByteString (ByteString) import Data.Functor ((<&>)) import Data.Int (Int64) @@ -102,24 +103,31 @@ reserveRefusal db now codeHash rid len = maybe CRInvalid (fromMaybe CRReserved . readPrepaidCode :: DBStore -> NamePrepaidCode -> IO (Maybe PrepaidCode) readPrepaidCode st code = withTransaction st (`getPrepaidCode` namePrepaidCodeHash code) --- | In the code's turn and one transaction, the code is checked and reserved for the registration, then --- the write runs. A write that refuses gives the code back. +newtype ReservationRefused = ReservationRefused CodeRefusal + deriving (Show) + +instance E.Exception ReservationRefused + +-- | In the code's turn and one transaction, the code is checked, the write runs, then the code is reserved for the +-- registration, so the registration's row is locked before the code's. A refused reservation rolls the write back. reserveCode :: Turns -> DBStore -> UTCTime -> ByteString -> RegistrationId -> Int -> (DB.Connection -> IO (Either e a)) -> IO (Either CodeRefusal (Either e a)) reserveCode turns st now codeHash rid len write = - withCodeTurn turns codeHash $ withTransaction st $ \db -> - getPrepaidCode db codeHash >>= \case - Nothing -> pure $ Left CRInvalid - Just code@PrepaidCode {pcId, pcReservedBy} - | Just refusal <- codeRefusal now rid len code -> pure $ Left refusal - | pcReservedBy == Just rid -> Right <$> write db - | otherwise -> - reservePrepaidCode db pcId rid now >>= \case - -- Only a writer outside this process, which takes no turn here, can refuse it. - False -> Left <$> reserveRefusal db now codeHash rid len - True -> - write db >>= \case - refused@(Left _) -> Right refused <$ releasePrepaidCode db pcId rid - written -> pure $ Right written + withCodeTurn turns codeHash $ either (\(ReservationRefused refusal) -> Left refusal) id <$> E.try (withTransaction st reserve) + where + reserve db = + getPrepaidCode db codeHash >>= \case + Nothing -> pure $ Left CRInvalid + Just code@PrepaidCode {pcId, pcReservedBy} + | Just refusal <- codeRefusal now rid len code -> pure $ Left refusal + | otherwise -> + write db >>= \case + written@(Right _) + | pcReservedBy /= Just rid -> + reservePrepaidCode db pcId rid now >>= \case + True -> pure $ Right written + -- Only a writer outside this process, which takes no turn here, can refuse it. + False -> E.throwIO . ReservationRefused =<< reserveRefusal db now codeHash rid len + written -> pure $ Right written -- | The write runs first, and the code is released only if it succeeds. False when the registration did not hold the code. releaseCode :: Turns -> DBStore -> Int64 -> RegistrationId -> (DB.Connection -> IO (Either e a)) -> IO (Either e (a, Bool)) diff --git a/tests/Bots/StoreService/NamesCodesTests.hs b/tests/Bots/StoreService/NamesCodesTests.hs index f9cf0f26ba..d04d217464 100644 --- a/tests/Bots/StoreService/NamesCodesTests.hs +++ b/tests/Bots/StoreService/NamesCodesTests.hs @@ -34,7 +34,7 @@ import StoreService.Config (ListenerConfig (..)) import StoreService.Group.Command (CmdAction (..), GroupCmd (..), groupCmdAction) import StoreService.Names.Codes import StoreService.Names.Phases (RegistrationId (..)) -import StoreService.Names.Store (NewPrepaidCode (..), PrepaidCode (..), getPrepaidCode, insertPrepaidCode, revokePrepaidCode, spendPrepaidCode) +import StoreService.Names.Store (NewPrepaidCode (..), PrepaidCode (..), getPrepaidCode, insertPrepaidCode, reservePrepaidCode, revokePrepaidCode, spendPrepaidCode) import StoreService.Names.Turns (Turns, newTurns) import StoreService.Store (RevokeResult (..)) import StoreService.Web.Http (codeLimit, newHttpEnv, notFound) @@ -53,11 +53,12 @@ namesCodesTests = describe "StoreService names: prepaid codes" $ do it "answers bad_request to a body that is not an object with a code text, and 405 to GET" testCheckBadBody it "takes a code token for every check, whatever its outcome" testCheckLimit describe "reservations" $ do - it "reserves an unused code in the transaction of the registration's write" testReserve + it "reserves an unused code after the registration's write, in its transaction" testReserve it "refuses each unusable code with its tag, before the write runs" testReserveRefusals it "keeps a code its registration holds even if revoked or expired since, still checking the length" testReserveHeld it "refuses a spent code to its own registration with code_used, before the write runs" testReserveSpent - it "gives the code back when the write refuses" testReserveWriteRefused + it "reserves nothing when the write refuses" testReserveWriteRefused + it "rolls the write back when the code's reservation is refused after it" testReserveRollsBack it "lets one of two concurrent reservations of a code win, the other answered code_reserved" testConcurrentReserve it "releases and spends a code only after the write, and only for its holder" testReleaseSpend describe "group commands" $ do @@ -238,7 +239,8 @@ testReserve = withOrders $ \turns st -> do code <- newCode 8 PrepaidCode {pcCodeHash} <- issueAs st code usable let holderInWrite db = Right . (pcReservedBy =<<) <$> getPrepaidCode db pcCodeHash :: IO (Either Text (Maybe RegistrationId)) - reserveCode turns st tNow pcCodeHash r1 8 holderInWrite `shouldReturn` Right (Right (Just r1)) + reserveCode turns st tNow pcCodeHash r1 8 holderInWrite `shouldReturn` Right (Right Nothing) + (pcReservedBy =<<) <$> withTransaction st (`getPrepaidCode` pcCodeHash) `shouldReturn` Just r1 reserveCode turns st tNow pcCodeHash r1 11 holderInWrite `shouldReturn` Right (Right (Just r1)) testReserveRefusals :: IO () @@ -307,6 +309,15 @@ testReserveWriteRefused = withOrders $ \turns st -> do reserveCode turns st tNow pcCodeHash r2 8 writeOk `shouldReturn` Right (Right ()) (pcReservedBy =<<) <$> readCode st row `shouldReturn` Just r2 +-- | The write reserves the code for another registration, as a writer outside this process could between the check and the reservation. +testReserveRollsBack :: IO () +testReserveRollsBack = withOrders $ \turns st -> do + code <- newCode 8 + row@PrepaidCode {pcId, pcCodeHash} <- issueAs st code usable + let takenMeanwhile db = Right () <$ reservePrepaidCode db pcId r2 tNow :: IO (Either Text ()) + reserveCode turns st tNow pcCodeHash r1 8 takenMeanwhile `shouldReturn` Left CRReserved + readCode st row `shouldReturn` Just row + testConcurrentReserve :: IO () testConcurrentReserve = withOrders $ \turns st -> do code <- newCode 8 From 9515291ace60c07de4b33815b67591b6bd62d559 Mon Sep 17 00:00:00 2001 From: shum Date: Thu, 22 Oct 2026 05:15:37 +0000 Subject: [PATCH 2/7] store: add owner-signed find, name and code --- .../src/StoreService/Names/Orders.hs | 164 +++- .../src/StoreService/Names/Signatures.hs | 1 + .../src/StoreService/Names/Store.hs | 5 + .../src/StoreService/Web/Names.hs | 7 +- .../src/StoreService/Web/Names/Orders.hs | 39 +- .../src/StoreService/Web/Names/Owner.hs | 194 +++++ simplex-chat.cabal | 3 + .../StoreService/GroupIntegrationTests.hs | 9 +- .../Bots/StoreService/NamesContractsTests.hs | 1 + tests/Bots/StoreService/NamesOrdersTests.hs | 12 + tests/Bots/StoreService/NamesOwnerTests.hs | 745 ++++++++++++++++++ tests/Test.hs | 2 + 12 files changed, 1149 insertions(+), 33 deletions(-) create mode 100644 apps/simplex-store-service/src/StoreService/Web/Names/Owner.hs create mode 100644 tests/Bots/StoreService/NamesOwnerTests.hs diff --git a/apps/simplex-store-service/src/StoreService/Names/Orders.hs b/apps/simplex-store-service/src/StoreService/Names/Orders.hs index e048fbba43..c2788bddcd 100644 --- a/apps/simplex-store-service/src/StoreService/Names/Orders.hs +++ b/apps/simplex-store-service/src/StoreService/Names/Orders.hs @@ -10,11 +10,15 @@ module StoreService.Names.Orders OrderRefusal (..), ExistingOrder (..), ClosedOrder (..), + WriteRefusal (..), maxSealedChars, signedRequestSeconds, parseOrderRequest, + parseOrderFields, + textField, integerField, checkLength, + checkSigner, checkOrderSigner, existingOrder, placeOrder, @@ -24,6 +28,15 @@ module StoreService.Names.Orders checkDuration, checkNameFree, checkPrice, + movable, + issuable, + orderFieldsOf, + checkMoveMeets, + checkMovePrice, + retargetOrder, + issuedCodeHash, + checkTakenCodeLength, + issueTakenCode, ) where @@ -34,12 +47,15 @@ import qualified Data.Aeson.KeyMap as KM import Data.Bifunctor (first) import Data.ByteString (ByteString) import Data.Int (Int64) +import Data.Maybe (isJust) import Data.Scientific (toBoundedInteger) +import Data.Text (Text) import qualified Data.Text as T import Data.Time.Clock (UTCTime, getCurrentTime) import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds) import Data.Word (Word64) import Simplex.Chat.Badges.Code (maxNameLength, minNameLength) +import Simplex.Chat.Badges.Types (BadgeCodePaymentStatus (..)) import Simplex.Messaging.Agent.Store.Common (DBStore, withTransaction) import qualified Simplex.Messaging.Agent.Store.DB as DB import Simplex.Messaging.Crypto.Secp256k1 (RecoverableSignature) @@ -48,13 +64,13 @@ import Simplex.Messaging.SimplexName (LabelHash (..)) import Simplex.Messaging.Util (tshow) import StoreService.Config (NamesConfig (..)) import StoreService.Log (logWarn) -import StoreService.Names.Codes (CodeRefusal (..), codeRefusal, reserveRefusal) -import StoreService.Names.Contracts (Contracts, NameStatus (..), chainPriceCents, nameStatus, secondsPerYear) +import StoreService.Names.Codes (CodeRefusal (..), codeRefusal, reserveCode, reserveRefusal) +import StoreService.Names.Contracts (Contracts, NameStatus (..), chainPriceCents, codeLengthFor, nameStatus, secondsPerYear) import StoreService.Names.Env (NamesEnv (..)) import StoreService.Names.Phases (Phases, RegistrationId) import StoreService.Names.Abi (bytes32FromHex) import StoreService.Names.Signatures (OrderFields (..), orderMessage, parseChecksumAddress, parseSignature, personalDigest) -import StoreService.Names.Store (LiveOrder (..), NameRegistration (..), NewRegistration (..), PrepaidCode (..), RegistrationRefused (..), closeOverdue, createCodeRegistration, getLiveOrders, getPrepaidCode, getRegistrationByOrderHash, isLabelRegistering) +import StoreService.Names.Store (CodeHashTaken, LiveOrder (..), NamePhase (..), NameRegistration (..), NewPrepaidCode (..), NewRegistration (..), PrepaidCode (..), RegistrationPayment (..), RegistrationRefused (..), VersionWrite (..), closeOverdue, createCodeRegistration, getLiveOrders, getPrepaidCode, getPrepaidCodeById, getRegistrationByOrderHash, insertPrepaidCode, isLabelRegistering, retargetRegistration, setIssuedCode, updateRegistration) import StoreService.Names.Turns (Turns, withCodeTurn) data OrdersEnv = OrdersEnv @@ -86,6 +102,11 @@ data OrderRefusal | ORNameCheckUnavailable | ORCatalogChanged Int | ORCode CodeRefusal + | ORPriceTooHigh Int + | ORCodeLengthChanged Int + | ORCodeUnavailable + | ORCodeConflict + | ORProviderUnavailable deriving (Eq, Show) newtype OrderRefused = OrderRefused OrderRefusal @@ -99,6 +120,15 @@ data ExistingOrder = EOResent NameRegistration | EONew [NameRegistration] | EOMe -- | An overdue order a new order closed, at its new version; its invoice is now expired. data ClosedOrder = ClosedOrder {coRegistration :: NameRegistration, coVersion :: Int64} +-- | Why an owner's write changed nothing: the registration changed since it was read, or a refusal. +data WriteRefusal = WRChanged | WRRefused OrderRefusal + deriving (Eq, Show) + +newtype TakenCodeConflict = TakenCodeConflict CodeHashTaken + deriving (Show) + +instance E.Exception TakenCodeConflict + maxSealedChars :: Int maxSealedChars = 11095 @@ -109,20 +139,27 @@ signedRequestSeconds = 600 -- | Every format check; the length's range is checkLength's, after the formats a kind of order adds. parseOrderRequest :: J.Object -> Maybe OrderRequest parseOrderRequest o = do - ofLabelHash <- LabelHash <$> (bytes32FromHex =<< text "labelHash") + orOwner <- either (const Nothing) Just . parseChecksumAddress =<< textField o "owner" + (orFields, orTimestamp, orSignature) <- parseOrderFields o + pure OrderRequest {orOwner, orFields, orTimestamp, orSignature} + +-- | The signed fields of an order, or of another name for one, with their timestamp and signature. +parseOrderFields :: J.Object -> Maybe (OrderFields, Word64, RecoverableSignature) +parseOrderFields o = do + ofLabelHash <- LabelHash <$> (bytes32FromHex =<< textField o "labelHash") ofLength <- integerField =<< KM.lookup "length" o ofDuration <- integerField =<< KM.lookup "duration" o - orOwner <- either (const Nothing) Just . parseChecksumAddress =<< text "owner" - ofCommitment <- bytes32FromHex =<< text "commitment" - ofSealed <- text "sealed" + ofCommitment <- bytes32FromHex =<< textField o "commitment" + ofSealed <- textField o "sealed" unless (T.length ofSealed <= maxSealedChars) Nothing - orTimestamp <- integerField =<< KM.lookup "timestamp" o - orSignature <- either (const Nothing) Just . parseSignature =<< text "signature" - pure OrderRequest {orOwner, orFields = OrderFields {ofLabelHash, ofLength, ofDuration, ofCommitment, ofSealed}, orTimestamp, orSignature} - where - text k = case KM.lookup k o of - Just (J.String t) -> Just t - _ -> Nothing + timestamp <- integerField =<< KM.lookup "timestamp" o + signature <- either (const Nothing) Just . parseSignature =<< textField o "signature" + pure (OrderFields {ofLabelHash, ofLength, ofDuration, ofCommitment, ofSealed}, timestamp, signature) + +textField :: J.Object -> J.Key -> Maybe Text +textField o k = case KM.lookup k o of + Just (J.String t) -> Just t + _ -> Nothing -- | A JSON integer within the type's range; a fraction, an exponent past it, or any other value is Nothing. integerField :: (Integral a, Bounded a) => J.Value -> Maybe a @@ -130,16 +167,20 @@ integerField = \case J.Number n -> toBoundedInteger n _ -> Nothing -checkLength :: OrderRequest -> Either OrderRefusal () -checkLength OrderRequest {orFields = OrderFields {ofLength}} = +checkLength :: OrderFields -> Either OrderRefusal () +checkLength OrderFields {ofLength} = unless (ofLength >= minNameLength && ofLength <= maxNameLength) $ Left ORInvalidName -checkOrderSigner :: OrderRequest -> IO (Either OrderRefusal ()) -checkOrderSigner OrderRequest {orOwner, orFields, orTimestamp, orSignature} = - recoverAddress orSignature (personalDigest $ orderMessage orFields orTimestamp) >>= \case - Right signer | signer == orOwner -> pure $ Right () +-- | The owner's EIP-191 signature over the message. +checkSigner :: Address -> ByteString -> RecoverableSignature -> IO (Either OrderRefusal ()) +checkSigner owner msg signature = + recoverAddress signature (personalDigest msg) >>= \case + Right signer | signer == owner -> pure $ Right () _ -> pure $ Left ORBadRequest +checkOrderSigner :: OrderRequest -> IO (Either OrderRefusal ()) +checkOrderSigner OrderRequest {orOwner, orFields, orTimestamp, orSignature} = checkSigner orOwner (orderMessage orFields orTimestamp) orSignature + existingOrder :: DB.Connection -> OrderRequest -> ByteString -> UTCTime -> IO ExistingOrder existingOrder db req hash now = getRegistrationByOrderHash db hash >>= \case @@ -225,3 +266,86 @@ checkPrice ct len years price = unixSeconds :: UTCTime -> Integer unixSeconds = floor . utcTimeToPOSIXSeconds + +-- | A paid order that lost its name, any failed order, and one whose reveal was refused for its links can move to another name. +movable :: NameRegistration -> Bool +movable NameRegistration {nrPhase, nrPayment, nrLinksRefusedAt} = case nrPhase of + PTaken | RPInvoice {} <- nrPayment -> True + PFailed -> True + PCommitted -> isJust nrLinksRefusedAt + _ -> False + +-- | Only a paid order that lost its name turns into a code. +issuable :: NameRegistration -> Bool +issuable NameRegistration {nrPhase, nrPayment} = case (nrPhase, nrPayment) of + (PTaken, RPInvoice {}) -> True + _ -> False + +orderFieldsOf :: NameRegistration -> OrderFields +orderFieldsOf NameRegistration {nrLabelHash, nrLength, nrDuration, nrCommitment, nrSealed} = + OrderFields {ofLabelHash = nrLabelHash, ofLength = nrLength, ofDuration = nrDuration, ofCommitment = nrCommitment, ofSealed = nrSealed} + +-- | Any other live order of the new commitment, or of the owner and the new label hash, refuses the move. +checkMoveMeets :: DBStore -> NameRegistration -> OrderFields -> UTCTime -> IO (Either OrderRefusal ()) +checkMoveMeets st NameRegistration {nrId = rid, nrOwner} OrderFields {ofLabelHash, ofCommitment} now = do + orders <- withTransaction st $ \db -> getLiveOrders db ofCommitment nrOwner ofLabelHash now + pure $ if any ((/= rid) . nrId . loRegistration) orders then Left OROrderExists else Right () + +-- | The new name's chain price for the order's years, at most what the order is worth, becomes its price. +checkMovePrice :: Contracts -> NameRegistration -> Int -> IO (Either OrderRefusal Int) +checkMovePrice ct NameRegistration {nrPrice, nrYears} len = + chainPriceCents ct len nrYears >>= \case + Left e -> Left ORNameCheckUnavailable <$ logWarn ("names: a move's price read failed: " <> tshow e) + Right price + | price > nrPrice -> pure $ Left $ ORPriceTooHigh price + | otherwise -> pure $ Right price + +-- | The move's write, a compare-and-set on the version read. A code order's code is checked and reserved again in the code's turn. +retargetOrder :: OrdersEnv -> NameRegistration -> OrderFields -> Int -> IO (Either WriteRefusal Int64) +retargetOrder OrdersEnv {oeStore, oeTurns, oeNow} r@NameRegistration {nrId, nrPayment} fields@OrderFields {ofLength} price = do + now <- oeNow + let write db = written <$> retargetRegistration db r fields price now + case nrPayment of + RPInvoice {} -> withTransaction oeStore write + RPCode codeId -> + withTransaction oeStore (`getPrepaidCodeById` codeId) >>= \case + Nothing -> pure $ Left $ WRRefused $ ORCode CRInvalid + Just PrepaidCode {pcCodeHash} -> either (Left . WRRefused . ORCode) id <$> reserveCode oeTurns oeStore now pcCodeHash nrId ofLength write + where + written = \case + Written v -> Right v + VersionChanged -> Left WRChanged + LiveOrderExists -> Left $ WRRefused OROrderExists + NotLive -> Left $ WRRefused ORBadRequest + +-- | The hash of the code a taken order was turned into. +issuedCodeHash :: DBStore -> NameRegistration -> IO (Maybe ByteString) +issuedCodeHash st NameRegistration {nrIssuedCodeId} = case nrIssuedCodeId of + Just codeId -> fmap pcCodeHash <$> withTransaction st (`getPrepaidCodeById` codeId) + Nothing -> pure Nothing + +-- | The code's minLength for the order's price and years must be the length the page derived the code with. +checkTakenCodeLength :: Contracts -> NameRegistration -> Int -> IO (Either OrderRefusal ()) +checkTakenCodeLength ct NameRegistration {nrPrice, nrYears} sent = + codeLengthFor ct nrPrice nrYears >>= \case + Left e -> Left ORProviderUnavailable <$ logWarn ("names: a taken code's length read failed: " <> tshow e) + Right Nothing -> pure $ Left ORCodeUnavailable + Right (Just len) + | len /= sent -> pure $ Left $ ORCodeLengthChanged len + | otherwise -> pure $ Right () + +-- | The order becomes code_issued by a compare-and-set on the version read, then its code is inserted and linked, in one +-- transaction, so the registration's row is locked before the code's. A hash another code has rolls the order's write back. +issueTakenCode :: OrdersEnv -> NameRegistration -> ByteString -> Int -> IO (Either WriteRefusal Int64) +issueTakenCode OrdersEnv {oeStore, oeNow} r@NameRegistration {nrId, nrYears} codeHash minLength = do + now <- oeNow + let code = NewPrepaidCode {npcCodeHash = codeHash, npcMinLength = minLength, npcYears = nrYears, npcPaymentStatus = CPSPaid, npcExpiresAt = Nothing} + issue db = + updateRegistration db r {nrPhase = PCodeIssued} now >>= \case + Written v -> + insertPrepaidCode db code now >>= \case + Right codeId -> Right v <$ setIssuedCode db nrId codeId + Left taken -> E.throwIO $ TakenCodeConflict taken + -- a code_issued order is not live, so only a changed version refuses the write + _ -> pure $ Left WRChanged + either (\(TakenCodeConflict _) -> Left $ WRRefused ORCodeConflict) id <$> E.try (withTransaction oeStore issue) diff --git a/apps/simplex-store-service/src/StoreService/Names/Signatures.hs b/apps/simplex-store-service/src/StoreService/Names/Signatures.hs index 369972d2d8..d5be5e3162 100644 --- a/apps/simplex-store-service/src/StoreService/Names/Signatures.hs +++ b/apps/simplex-store-service/src/StoreService/Names/Signatures.hs @@ -57,6 +57,7 @@ data OrderFields = OrderFields ofCommitment :: ByteString, ofSealed :: Text } + deriving (Eq) signatureHexLength :: Int signatureHexLength = 130 diff --git a/apps/simplex-store-service/src/StoreService/Names/Store.hs b/apps/simplex-store-service/src/StoreService/Names/Store.hs index 53787211b2..68e394b418 100644 --- a/apps/simplex-store-service/src/StoreService/Names/Store.hs +++ b/apps/simplex-store-service/src/StoreService/Names/Store.hs @@ -41,6 +41,7 @@ module StoreService.Names.Store closeOverdue, updateRegistration, retargetRegistration, + setIssuedCode, findRegistrations, isLabelRegistering, activeRegistrations, @@ -615,6 +616,10 @@ retargetRegistration db r OrderFields {ofLabelHash, ofLength, ofDuration, ofComm nrError = Nothing } +-- | Links the code a taken order was turned into, in the transaction that wrote its code_issued phase and version. +setIssuedCode :: DB.Connection -> RegistrationId -> Int64 -> IO () +setIssuedCode db (RegistrationId rid) codeId = DB.execute db "UPDATE sx_badge_service_name_registrations SET issued_code_id = ? WHERE registration_id = ?" (codeId, rid) + -- | Newest first, at most findLimit. findRegistrations :: DB.Connection -> Address -> IO [NameRegistration] findRegistrations db owner = diff --git a/apps/simplex-store-service/src/StoreService/Web/Names.hs b/apps/simplex-store-service/src/StoreService/Web/Names.hs index ffefc4f4ee..15924135b8 100644 --- a/apps/simplex-store-service/src/StoreService/Web/Names.hs +++ b/apps/simplex-store-service/src/StoreService/Web/Names.hs @@ -9,9 +9,10 @@ import Network.HTTP.Types (Method) import Network.Wai (Request, ResponseReceived, pathInfo) import StoreService.Names.Env (NamesEnv (..)) import StoreService.Names.Orders (ordersEnv) -import StoreService.Web.Http (HttpEnv, Limit, Respond, codeLimit, holdMicros, limited, only, previewLimit, readLimit, recordsLimit, searchLimit) +import StoreService.Web.Http (HttpEnv, Limit, Respond, codeLimit, createLimit, findLimit, holdMicros, limited, only, previewLimit, readLimit, recordsLimit, searchLimit) 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) import StoreService.Web.Names.Search (previewHandler, searchHandler) @@ -30,7 +31,11 @@ namesRoutes env@NamesEnv {neConfig, neStore, neContracts, neProfiles, neRecords, ["api", "link", "preview"] -> Just Route {rMethod = "POST", rLimit = previewLimit, rHandler = previewHandler neProfiles} -- below every fixed /api/name/ route, which it would otherwise match ["api", "name", hash] -> Just Route {rMethod = "GET", rLimit = searchLimit, rHandler = searchHandler neConfig neStore neContracts neProfiles hash} + -- above /api/registration/:id, which it would otherwise match + ["api", "registration", "find"] -> Just Route {rMethod = "POST", rLimit = findLimit, rHandler = findHandler (ordersEnv env)} ["api", "registration", rid] -> Just Route {rMethod = "GET", rLimit = readLimit, rHandler = registrationHandler (ordersEnv env) holdMicros rid} + ["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} _ -> 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/Orders.hs b/apps/simplex-store-service/src/StoreService/Web/Names/Orders.hs index 38fc5a70c6..7e606a966f 100644 --- a/apps/simplex-store-service/src/StoreService/Web/Names/Orders.hs +++ b/apps/simplex-store-service/src/StoreService/Web/Names/Orders.hs @@ -2,7 +2,19 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} -module StoreService.Web.Names.Orders (nameInvoiceHandler, codeOrderHandler, nameInvoiceView, orderRefusalResponse, registrationChangedResponse) where +module StoreService.Web.Names.Orders + ( Answer (..), + answerNow, + sendAnswer, + firstRefusal, + nameInvoiceHandler, + codeOrderHandler, + nameInvoiceView, + orderRefusalResponse, + registrationChangedResponse, + registrationRefusalResponse, + ) +where import Control.Concurrent.STM (atomically) import qualified Control.Exception as E @@ -35,7 +47,7 @@ import StoreService.Orders (publishRegistration) import StoreService.Providers (OrderDraft (..), Provider (..), ProviderError (..), ProviderInvoice (..), expiresItself) import StoreService.Store.Invoices (InvoiceRow (..), NewNameInvoice (..), getInvoice, insertNameInvoice, newInvoiceId, truncateToSecond) import StoreService.Waiters (Waiters, publish) -import StoreService.Web.Http (Respond, badRequest, confirmationsFor, internalError, invalidName, invoiceAt, invoicePairs, invoiceWindow, jsonError, jsonResponse, nameBodyBytes, notFound, providerFor, providerNamed, providerUnavailable, readBoundedBody) +import StoreService.Web.Http (Respond, badRequest, codeConflict, confirmationsFor, internalError, invalidName, invoiceAt, invoicePairs, invoiceWindow, jsonError, jsonResponse, nameBodyBytes, notFound, providerFor, providerNamed, providerUnavailable, readBoundedBody) import StoreService.Web.Names.Codes (codeRefusalResponse) import StoreService.Web.Names.Registration (registrationAt) @@ -54,7 +66,7 @@ parseInvoiceOrder o = do _ -> Nothing ioPrice <- integerField =<< KM.lookup "price" o pure InvoiceOrder {ioRequest, ioMethod, ioPrice} - order <$ checkLength ioRequest + order <$ checkLength (orFields ioRequest) -- | An order's answer and the work its commit leaves, both done after the name's turn, so a slow client holds no turn. data Answer = Answer {aResponse :: Response, aAfter :: IO ()} @@ -180,12 +192,8 @@ codeOrderHandler env@OrdersEnv {oeStore, oeConfig, oeContracts, oeTurns, oeNow} parseCodeOrder :: J.Object -> Either OrderRefusal (OrderRequest, Text) parseCodeOrder o = do - order@(req, _) <- maybe (Left ORBadRequest) Right $ (,) <$> parseOrderRequest o <*> codeText - order <$ checkLength req - where - codeText = case KM.lookup "code" o of - Just (J.String t) -> Just t - _ -> Nothing + order@(req, _) <- maybe (Left ORBadRequest) Right $ (,) <$> parseOrderRequest o <*> textField o "code" + order <$ checkLength (orFields req) -- | After the commit, the closed orders' invoices and versions are published, and their invoices cancelled at the provider, -- best effort, as the poller's sweep would cancel them. @@ -223,13 +231,17 @@ nameInvoiceView OrdersEnv {oeStore, oeConfig, oeContracts} confirmations row@Inv -- | The registration's current view, for a request that lost the race to change it. registrationChangedResponse :: OrdersEnv -> RegistrationId -> IO Response -registrationChangedResponse OrdersEnv {oeStore, oeConfig, oeContracts, oeNow} rid = +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" .= ("registration_changed" :: Text), "registration" .= view] + pure $ jsonResponse status409 $ J.object ["error" .= tag, "registration" .= view] orderRefusalResponse :: OrderRefusal -> Response orderRefusalResponse = \case @@ -240,3 +252,8 @@ orderRefusalResponse = \case ORNameCheckUnavailable -> jsonError status503 "name_check_unavailable" ORCatalogChanged price -> jsonResponse status409 $ J.object ["error" .= ("catalog_changed" :: Text), "price" .= price] ORCode refusal -> codeRefusalResponse refusal + ORPriceTooHigh price -> jsonResponse status409 $ J.object ["error" .= ("price_too_high" :: Text), "price" .= price] + ORCodeLengthChanged len -> jsonResponse status409 $ J.object ["error" .= ("code_length_changed" :: Text), "codeLength" .= len] + ORCodeUnavailable -> jsonError status409 "code_unavailable" + ORCodeConflict -> codeConflict + ORProviderUnavailable -> providerUnavailable diff --git a/apps/simplex-store-service/src/StoreService/Web/Names/Owner.hs b/apps/simplex-store-service/src/StoreService/Web/Names/Owner.hs new file mode 100644 index 0000000000..31a83620ab --- /dev/null +++ b/apps/simplex-store-service/src/StoreService/Web/Names/Owner.hs @@ -0,0 +1,194 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | The requests only the owner code can sign: find, another name, and a code for a taken order. +module StoreService.Web.Names.Owner (findHandler, retargetHandler, takenCodeHandler) where + +import Control.Concurrent.STM (atomically) +import Data.Aeson ((.=)) +import qualified Data.Aeson as J +import qualified Data.Aeson.KeyMap as KM +import Data.ByteString (ByteString) +import Data.Int (Int64) +import Data.Text (Text) +import Data.Word (Word64) +import Network.HTTP.Types (status200) +import Network.Wai (Request, Response, ResponseReceived) +import Simplex.Chat.PaymentService.Types (InvoiceId (..)) +import Simplex.Messaging.Agent.Store.Common (withTransaction) +import Simplex.Messaging.Crypto.Secp256k1 (RecoverableSignature) +import Simplex.Messaging.Encoding.String (textEncode) +import Simplex.Messaging.Eth.Address (Address) +import Simplex.Messaging.SimplexName (LabelHash (..)) +import Simplex.Messaging.Util (eitherToMaybe, tshow) +import StoreService.Config (NamesConfig (..)) +import StoreService.Log (logError, logInfo) +import StoreService.Names.Abi (hex) +import StoreService.Names.Orders +import StoreService.Names.Phases (RegistrationId (..), publish) +import StoreService.Names.Signatures (OrderFields (..), findMessage, parseAnyCaseAddress, parseSignature, retargetMessage, takenCodeMessage) +import StoreService.Names.Store (NameRegistration (..), RegistrationPayment (..), findRegistrations, getRegistration) +import StoreService.Names.Turns (withLabelTurn, withLabelTurns) +import StoreService.Names.View (registrationView) +import StoreService.Web.Http (Respond, internalError, jsonResponse, maxBodyBytes, nameBodyBytes, notFound, parseCodeHash, readBoundedBody) +import StoreService.Web.Names.Orders (Answer (..), answerNow, firstRefusal, orderRefusalResponse, registrationChangedResponse, registrationRefusalResponse, sendAnswer) +import StoreService.Web.Names.Registration (registrationAt) + +data FindRequest = FindRequest + { frOwner :: Address, + frTimestamp :: Word64, + frSignature :: RecoverableSignature + } + +data TakenCodeRequest = TakenCodeRequest + { tcHashText :: Text, + tcHash :: ByteString, + tcLength :: Int, + tcTimestamp :: Word64, + tcSignature :: RecoverableSignature + } + +-- | POST /api/registration/find, the owner's orders newest first. +findHandler :: OrdersEnv -> Request -> Respond -> IO ResponseReceived +findHandler OrdersEnv {oeStore, oeNow} req respond = + readBoundedBody maxBodyBytes req >>= requested >>= sendAnswer respond + where + requested = \case + Just body | Just (J.Object o) <- J.decode body, Just request <- parseFind o -> found request + _ -> refuse ORBadRequest + found FindRequest {frOwner, frTimestamp, frSignature} = do + now <- oeNow + firstRefusal [checkSigner frOwner (findMessage frOwner frTimestamp) frSignature, pure $ checkTimestamp now frTimestamp] >>= \case + Just refusal -> refuse refusal + Nothing -> + withTransaction oeStore (`findRegistrations` frOwner) >>= \case + [] -> pure $ answerNow notFound + rs -> pure $ answerNow $ jsonResponse status200 $ J.object ["registrations" .= map (foundJSON . registrationAt now) rs] + refuse = refused "POST /api/registration/find" + +parseFind :: J.Object -> Maybe FindRequest +parseFind o = do + frOwner <- eitherToMaybe . parseAnyCaseAddress =<< textField o "owner" + frTimestamp <- integerField =<< KM.lookup "timestamp" o + frSignature <- eitherToMaybe . parseSignature =<< textField o "signature" + pure FindRequest {frOwner, frTimestamp, frSignature} + +foundJSON :: NameRegistration -> J.Value +foundJSON NameRegistration {nrId = RegistrationId rid, nrPayment, nrPhase, nrCreatedAt, nrLabelHash = LabelHash lh, nrSealed} = + J.object + [ "registrationId" .= rid, + "invoiceId" .= invoiceId, + "phase" .= (textEncode nrPhase :: Text), + "createdAt" .= nrCreatedAt, + "labelHash" .= hex lh, + "sealed" .= nrSealed + ] + where + invoiceId = case nrPayment of + RPInvoice _ (InvoiceId t) -> Just t + RPCode _ -> Nothing + +-- | POST /api/registration/:id/name, another name or other links, under the turns of both names. +retargetHandler :: OrdersEnv -> Text -> Request -> Respond -> IO ResponseReceived +retargetHandler env@OrdersEnv {oeStore, oeConfig, oeContracts, oeTurns, oeNow} ridText req respond = + readBoundedBody nameBodyBytes req >>= requested >>= sendAnswer respond + where + rid = RegistrationId ridText + requested = \case + Just body | Just (J.Object o) <- J.decode body, Just request@(fields, _, _) <- parseOrderFields o -> either refuse (const $ signed request) (checkLength fields) + _ -> refuse ORBadRequest + signed (fields, timestamp, signature) = + withTransaction oeStore (`getRegistration` rid) >>= \case + Nothing -> pure $ answerNow notFound + Just NameRegistration {nrOwner, nrLabelHash} -> + checkSigner nrOwner (retargetMessage rid fields timestamp) signature >>= \case + Left refusal -> refuse refusal + Right () -> withLabelTurns oeTurns nrLabelHash (ofLabelHash fields) $ inTurns [nrLabelHash, ofLabelHash fields] fields timestamp + -- another move can take the order to a name whose turn this request does not hold + inTurns held fields timestamp = do + now <- oeNow + withTransaction oeStore (`getRegistration` rid) >>= \case + Nothing -> pure $ answerNow notFound + Just stored + | nrLabelHash stored `notElem` held -> changed + | otherwise -> moveTo now (registrationAt now stored) fields timestamp + moveTo now r@NameRegistration {nrMoves, nrYears, nrPrice, nrPayment} fields@OrderFields {ofLabelHash, ofLength, ofDuration} timestamp + | orderFieldsOf r == fields = answerNow . jsonResponse status200 <$> registrationView oeStore oeConfig oeContracts r + | Left refusal <- checkTimestamp now timestamp = refuse refusal + | not (movable r) = refuse ORBadRequest + | nrMoves >= nMaxOrderMoves oeConfig = answerNow <$> registrationRefusalResponse env "move_limit" rid + | otherwise = + firstRefusal [checkMoveMeets oeStore r fields now, pure $ checkDuration oeConfig now nrYears ofDuration, checkNameFree oeContracts oeStore ofLabelHash] >>= \case + Just refusal -> refuse refusal + Nothing -> case nrPayment of + RPInvoice {} -> checkMovePrice oeContracts r ofLength >>= either refuse (write now r fields) + RPCode _ -> write now r fields nrPrice + write now r fields price = + retargetOrder env r fields price >>= \case + Right v -> movedAnswer now v + Left WRChanged -> changed + Left (WRRefused refusal) -> refuse refusal + movedAnswer now v = + withTransaction oeStore (`getRegistration` rid) >>= \case + Just r -> written env rid v . jsonResponse status200 <$> registrationView oeStore oeConfig oeContracts (registrationAt now r) + Nothing -> answerNow internalError <$ logError ("POST /api/registration/:id/name: order " <> ridText <> " is not readable after its move") + changed = answerNow <$> registrationChangedResponse env rid + refuse = refused "POST /api/registration/:id/name" + +-- | POST /api/registration/:id/code, a paid taken order turned into a prepaid code, under its name's turn. +takenCodeHandler :: OrdersEnv -> Text -> Request -> Respond -> IO ResponseReceived +takenCodeHandler env@OrdersEnv {oeStore, oeContracts, oeTurns, oeNow} ridText req respond = + readBoundedBody maxBodyBytes req >>= requested >>= sendAnswer respond + where + rid = RegistrationId ridText + requested = \case + Just body | Just (J.Object o) <- J.decode body, Just request <- parseTakenCode o -> signed request + _ -> refuse ORBadRequest + signed request@TakenCodeRequest {tcHashText, tcLength, tcTimestamp, tcSignature} = + withTransaction oeStore (`getRegistration` rid) >>= \case + Nothing -> pure $ answerNow notFound + Just NameRegistration {nrOwner, nrLabelHash} -> + checkSigner nrOwner (takenCodeMessage rid tcHashText tcLength tcTimestamp) tcSignature >>= \case + Left refusal -> refuse refusal + Right () -> withLabelTurn oeTurns nrLabelHash $ inTurn nrLabelHash request + inTurn held request@TakenCodeRequest {tcHash} = do + now <- oeNow + withTransaction oeStore (`getRegistration` rid) >>= \case + Nothing -> pure $ answerNow notFound + Just r + | nrLabelHash r /= held -> changed + | otherwise -> + issuedCodeHash oeStore r >>= \case + Just issued | issued == tcHash -> pure $ answerNow codeIssued + _ -> issue now r request + issue now r TakenCodeRequest {tcHash, tcLength, tcTimestamp} + | Left refusal <- checkTimestamp now tcTimestamp = refuse refusal + | not (issuable r) = refuse ORBadRequest + | otherwise = + checkTakenCodeLength oeContracts r tcLength >>= \case + Left refusal -> refuse refusal + Right () -> + issueTakenCode env r tcHash tcLength >>= \case + Right v -> pure $ written env rid v codeIssued + Left WRChanged -> changed + Left (WRRefused refusal) -> refuse refusal + codeIssued = jsonResponse status200 $ J.object [] + changed = answerNow <$> registrationChangedResponse env rid + refuse = refused "POST /api/registration/:id/code" + +parseTakenCode :: J.Object -> Maybe TakenCodeRequest +parseTakenCode o = do + tcHashText <- textField o "codeHash" + tcHash <- parseCodeHash tcHashText + tcLength <- integerField =<< KM.lookup "codeLength" o + tcTimestamp <- integerField =<< KM.lookup "timestamp" o + tcSignature <- eitherToMaybe . parseSignature =<< textField o "signature" + pure TakenCodeRequest {tcHashText, tcHash, tcLength, tcTimestamp, tcSignature} + +-- | Published after the turn, as the answer is sent. +written :: OrdersEnv -> RegistrationId -> Int64 -> Response -> Answer +written OrdersEnv {oePhases} rid v aResponse = Answer {aResponse, aAfter = atomically $ publish oePhases rid v} + +refused :: Text -> OrderRefusal -> IO Answer +refused what refusal = answerNow (orderRefusalResponse refusal) <$ logInfo (what <> " refused: " <> tshow refusal) diff --git a/simplex-chat.cabal b/simplex-chat.cabal index f622ec5de3..454671126a 100644 --- a/simplex-chat.cabal +++ b/simplex-chat.cabal @@ -475,6 +475,7 @@ executable simplex-store-service StoreService.Web.Names StoreService.Web.Names.Codes StoreService.Web.Names.Orders + StoreService.Web.Names.Owner StoreService.Web.Names.Records StoreService.Web.Names.Registration StoreService.Web.Names.Search @@ -770,6 +771,7 @@ test-suite simplex-chat-test Bots.StoreService.NamesLabelTests Bots.StoreService.NamesLinksTests Bots.StoreService.NamesOrdersTests + Bots.StoreService.NamesOwnerTests Bots.StoreService.NamesPhasesTests Bots.StoreService.NamesProfilesTests Bots.StoreService.NamesRecordsTests @@ -832,6 +834,7 @@ test-suite simplex-chat-test StoreService.Web.Names StoreService.Web.Names.Codes StoreService.Web.Names.Orders + StoreService.Web.Names.Owner StoreService.Web.Names.Records StoreService.Web.Names.Registration StoreService.Web.Names.Search diff --git a/tests/Bots/StoreService/GroupIntegrationTests.hs b/tests/Bots/StoreService/GroupIntegrationTests.hs index 42bc5bb133..7fc396366e 100644 --- a/tests/Bots/StoreService/GroupIntegrationTests.hs +++ b/tests/Bots/StoreService/GroupIntegrationTests.hs @@ -134,7 +134,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, registrations to GET, 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 and a code to POST, a path no route knows to 404, and code checks and orders under one limit" testNamesBoot testNamesBoot :: HasCallStack => TestParams -> IO () testNamesBoot ps = do @@ -158,6 +158,13 @@ testNamesBoot ps = do answer registration `shouldReturn` (404, Just $ J.object ["error" J..= ("not_found" :: Text)]) posted <- httpLbs registration {method = "POST"} mgr (statusCode $ responseStatus posted, lookup "Allow" $ responseHeaders posted) `shouldBe` (405, Just "GET") + found <- request "/api/registration/find" + answer found {method = "POST", requestBody = RequestBodyLBS "{}"} `shouldReturn` refused "bad_request" + foundByGet <- httpLbs found mgr + (statusCode $ responseStatus foundByGet, lookup "Allow" $ responseHeaders foundByGet) `shouldBe` (405, Just "POST") + forM_ ["name", "code"] $ \action -> do + owned <- request $ "/api/registration/t2Jk8RmQ4vXw9NcP3yLb6g/" <> action + (action,) <$> answer owned {method = "POST", requestBody = RequestBodyLBS "{}"} `shouldReturn` (action, refused "bad_request") -- 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/NamesContractsTests.hs b/tests/Bots/StoreService/NamesContractsTests.hs index a0c9081a9a..10b8ed379a 100644 --- a/tests/Bots/StoreService/NamesContractsTests.hs +++ b/tests/Bots/StoreService/NamesContractsTests.hs @@ -22,6 +22,7 @@ module Bots.StoreService.NamesContractsTests noncesCall, pricesCall, launchPricesAnswer, + pricesAnswer, oracle, alice, unhex, diff --git a/tests/Bots/StoreService/NamesOrdersTests.hs b/tests/Bots/StoreService/NamesOrdersTests.hs index 260f40278a..8de45eb7e0 100644 --- a/tests/Bots/StoreService/NamesOrdersTests.hs +++ b/tests/Bots/StoreService/NamesOrdersTests.hs @@ -17,6 +17,18 @@ module Bots.StoreService.NamesOrdersTests settled, invoiceRegistration, registrationOf, + keyA, + keyB, + ownerAText, + ownerBText, + yearsDuration, + codeRoutes, + issueCode, + registered, + registrationById, + field, + advance, + refusedWith, ) where diff --git a/tests/Bots/StoreService/NamesOwnerTests.hs b/tests/Bots/StoreService/NamesOwnerTests.hs new file mode 100644 index 0000000000..de5d38322a --- /dev/null +++ b/tests/Bots/StoreService/NamesOwnerTests.hs @@ -0,0 +1,745 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} + +module Bots.StoreService.NamesOwnerTests (namesOwnerTests) where + +import Bots.StoreService.FakeEthNode +import Bots.StoreService.NamesContractsTests (launchPricesAnswer, oracle, pricesAnswer, pricesCall, registrarOf, rentPriceAnswer, rentPriceCall, unhex) +import Bots.StoreService.NamesOrdersTests +import Bots.StoreService.NamesStoreTests (order, ownerA, t0) +import Bots.StoreService.WebTests (digestFixture, jsonObject, statusOf, webGet) +import Control.Applicative ((<|>)) +import Control.Arrow ((&&&)) +import Control.Concurrent (threadDelay) +import Control.Concurrent.Async (Async, async, cancel, wait) +import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar) +import Control.Concurrent.STM (atomically, check) +import Control.Monad (forM, forM_, unless, void) +import qualified Data.Aeson as J +import qualified Data.Aeson.KeyMap as KM +import Data.ByteString (ByteString) +import qualified Data.ByteString.Base64.URL as B64U +import qualified Data.ByteString.Char8 as BC +import Data.IORef (readIORef) +import Data.Foldable (toList) +import Data.List (find, sort, sortOn) +import Data.Maybe (fromJust, fromMaybe) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time.Clock (UTCTime, addUTCTime) +import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds) +import Data.Word (Word64) +import Network.HTTP.Client (defaultManagerSettings, newManager) +import qualified Network.Wai.Handler.Warp as Warp +import Simplex.Chat.Badges.Types (BadgeCodePaymentStatus (..)) +import Simplex.Chat.PaymentService.Types (InvoiceId (..), InvoiceStatus (..)) +import Simplex.Messaging.Agent.Store.Common (withTransaction) +import qualified Simplex.Messaging.Agent.Store.DB as DB +import qualified Simplex.Messaging.Crypto as C +import Simplex.Messaging.Crypto.Secp256k1 (Secp256k1PrivateKey, signRecoverable) +import Simplex.Messaging.Eth.EIP712 (serializeSignature) +import Simplex.Messaging.SimplexName (LabelHash (..), labelHash) +import Simplex.Messaging.Util (safeDecodeUtf8, tshow) +import StoreService.Config (NamesConfig (..)) +import StoreService.Names.Abi (addressWord, hex, uint256) +import StoreService.Names.Chain (TxHash (..)) +import StoreService.Names.Orders (OrdersEnv (..), signedRequestSeconds) +import StoreService.Names.Phases (RegistrationId (..), phasesWaiting) +import StoreService.Names.Signatures (OrderFields (..), findMessage, parseAnyCaseAddress, personalDigest, retargetMessage, takenCodeMessage) +import StoreService.Names.Store hiding (findLimit) +import StoreService.Names.Turns (turnsCount, withLabelTurn) +import StoreService.Store (RevokeResult (..)) +import StoreService.Web.Http (createLimit, findLimit, holdMicros, readLimit) +import StoreService.Web.Names (Route (..), namesApp) +import StoreService.Web.Names.Owner (findHandler, retargetHandler, takenCodeHandler) +import StoreService.Web.Names.Registration (registrationHandler) +import StoreService.Web.Server (WebEnv (..), webApp) +import System.Timeout (timeout) +import Test.Hspec + +namesOwnerTests :: Spec +namesOwnerTests = describe "StoreService names: owner" $ do + describe "find" $ do + it "lists the owner's orders newest first, a moved, an unpaid and a lapsed one read failed included, at most 50, and 404 for none" testFind + it "refuses another signer's signature, a stale timestamp and a malformed body" testFindRefused + describe "another name" $ do + it "refuses a move from registered, queued, and committed without a refused reveal" testMoveRefusedPhases + it "moves a failed order, a lapsed one, and a committed one whose links were refused, to the same name with other links too" testMoveAccepted + it "answers a body equal to the current fields with the view unchanged, counting no move, whatever its timestamp" testMoveRepeat + it "answers the fourth move move_limit with the current view, changing nothing" testMoveLimit + it "refuses a move meeting another live order of the wallet's or the commitment with a bare order_exists, before the price" testMoveMeetsOrder + it "runs the order checks on the new fields: invalid_name, the duration, name_taken, name_check_unavailable" testMoveOrderChecks + it "answers a dearer name price_too_high with its price, and moves to a cheaper one at its price" testMovePrice + it "checks a code order's code again: code_not_covering for a shorter name, a held code kept though revoked and expired since" testMoveCodeOrder + it "reserves a released code again while unused, else answers code_used, code_reserved, code_invalid or code_expired" testMoveReleasedCode + it "refuses sealed over 11095 characters, a body over 16384 bytes and malformed fields, accepting the longest" testMoveSizes + it "refuses another signer's signature and a stale timestamp, and answers an unknown order 404" testMoveRefusedSigner + it "answers registration_changed with the current view when the order changed during the checks, writing nothing" testMoveLostRace + it "moves A to B while another order moves B to A, in the turns' hash order, without deadlock" testMovesCross + describe "a code instead" $ do + it "issues a code for a paid taken order, its minLength 6, 7 and 8 for 6, 7 and 12 letters at the launch prices, kept in the view" testTakenCode + it "answers an identical repeat 200 whatever its codeLength and timestamp, even after a price change" testTakenCodeRepeat + it "answers code_length_changed with the current length after a price change, issuing nothing" testCodeLengthChanged + it "answers code_unavailable when no length qualifies, and 503 provider_unavailable when the prices cannot be read" testCodeUnavailable + it "refuses a code for an order that is not a paid taken one, another signer, a stale timestamp and a malformed hash" testTakenCodeRefused + it "answers code_conflict for a hash another code has, changing nothing" testCodeConflict + it "answers registration_changed with the current view when the order changed during the length read, issuing nothing" testCodeLostRace + describe "polls" $ + it "wakes a held registration poll by another name and by a code" testPollsWoken + +-- fixtures + +-- | The owner routes and the registration poll as namesRoutes registers them, with the code orders, since a NamesEnv needs a running chat controller. +withOwner :: (Ctx -> IO a) -> IO a +withOwner = withOwnerAs id + +withOwnerAs :: (NamesConfig -> NamesConfig) -> (Ctx -> IO a) -> IO a +withOwnerAs change action = withOrders $ \ctx@Ctx {cOrders, cWeb} -> do + let orders = cOrders {oeConfig = change (oeConfig cOrders)} + web = cWeb {weOrders = Just orders} + routes path = ownerRoutes orders path <|> codeRoutes orders (weProviders web) (weWaiters web) path + app req respond = fromMaybe (webApp web req respond) (namesApp (weHttp web) routes req respond) + mgr <- newManager defaultManagerSettings + Warp.testWithApplication (pure app) $ \port -> + action ctx {cOrders = orders, cWeb = web, cClient = (mgr, "http://127.0.0.1:" <> show port)} + +ownerRoutes :: OrdersEnv -> [Text] -> Maybe Route +ownerRoutes orders = \case + ["api", "registration", "find"] -> Just Route {rMethod = "POST", rLimit = findLimit, rHandler = findHandler orders} + ["api", "registration", rid] -> Just Route {rMethod = "GET", rLimit = readLimit, rHandler = registrationHandler orders holdMicros rid} + ["api", "registration", rid, "name"] -> Just Route {rMethod = "POST", rLimit = createLimit, rHandler = retargetHandler orders rid} + ["api", "registration", rid, "code"] -> Just Route {rMethod = "POST", rLimit = createLimit, rHandler = takenCodeHandler orders rid} + _ -> Nothing + +signWith :: Ctx -> Secp256k1PrivateKey -> ByteString -> IO Text +signWith Ctx {cRandom} key msg = hex . serializeSignature . either (error . show) id <$> signRecoverable cRandom key (personalDigest msg) + +clockSeconds :: Ctx -> IO Word64 +clockSeconds Ctx {cClock} = seconds <$> readIORef cClock + +seconds :: UTCTime -> Word64 +seconds = floor . utcTimeToPOSIXSeconds + +signedWindow :: Word64 +signedWindow = fromInteger signedRequestSeconds + +byB :: Order -> Order +byB o = o {oOwner = ownerBText, oKey = keyB} + +dynamisOrder :: Order +dynamisOrder = aliceOrder {oLabel = "dynamis", oCommitment = commitmentOf 3, oSealed = "sealed-dynamis-3", oPrice = 20000} + +-- viem's selectors of nameExpires(uint256) and reservedNames(bytes32), as in the dynamis calls of the orders tests +nameExpiresSelector, reservedNamesSelector :: ByteString +nameExpiresSelector = unhex "d6e4fa86" +reservedNamesSelector = unhex "389c0748" + +-- | The chain answers the name as available. +answerFree :: Ctx -> Text -> IO () +answerFree ctx label = answerReserved ctx label 0 + +answerReserved :: Ctx -> Text -> Int -> IO () +answerReserved Ctx {cNode} label reason = do + answerCall cNode (registrarOf cNode) (nameExpiresSelector <> lh) $ Returns $ uint256 (0 :: Int) + answerCall cNode fakeController (reservedNamesSelector <> lh) $ Returns $ uint256 reason + where + LabelHash lh = labelHash label + +-- | The oracle's price list, as codeLengthFor reads it. +answerPrices :: Ctx -> ByteString -> IO () +answerPrices Ctx {cNode} prices = do + answerCall cNode fakeController pricesCall $ Returns $ addressWord oracle + answerCall cNode oracle pricesCall $ Returns prices + +-- | A paid order, settled, then written as the worker would write it. +paidIn :: Ctx -> Order -> (NameRegistration -> NameRegistration) -> IO NameRegistration +paidIn ctx o change = do + (invId, _) <- placed ctx o + settleNow ctx invId settled `shouldReturn` Right ISPaid + r <- invoiceRegistration ctx invId + rewrite ctx r change + +-- | A code order of a code of this length, then written as the worker would write it. +codeIn :: Ctx -> Int -> Order -> (NameRegistration -> NameRegistration) -> IO (NameRegistration, PrepaidCode) +codeIn ctx len o change = do + (text, code) <- issueCode ctx len 2 id + r <- registrationById ctx =<< registered ctx text o + (,code) <$> rewrite ctx r change + +-- | A write outside the turns, as the worker's, at the stored version. +rewrite :: Ctx -> NameRegistration -> (NameRegistration -> NameRegistration) -> IO NameRegistration +rewrite Ctx {cStore, cClock} NameRegistration {nrId} change = do + t <- readIORef cClock + withTransaction cStore $ \db -> do + current <- fromJust <$> getRegistration db nrId + updateRegistration db (change current) t >>= \case + Written _ -> fromJust <$> getRegistration db nrId + refused -> error $ "not written: " <> show refused + +stored :: Ctx -> NameRegistration -> IO NameRegistration +stored ctx = registrationById ctx . nrId + +failedPhase, takenPhase, registeredPhase, committedPhase, linksRefusedPhase :: NameRegistration -> NameRegistration +failedPhase r = r {nrPhase = PFailed, nrFailedAt = Just orderTime, nrError = Just "The name could not be registered"} +takenPhase r = r {nrPhase = PTaken} +registeredPhase r = r {nrPhase = PRegistered, nrExpiresAt = Just (seconds orderTime + 3 * 31536000)} +committedPhase r = + r + { nrPhase = PCommitted, + nrCommitTx = Just (TxHash $ digestFixture 8), + nrCommitBlock = Just 100, + nrRevealAfter = Just (seconds orderTime + 60), + nrRevealBefore = Just (seconds orderTime + 86400) + } +linksRefusedPhase r = (committedPhase r) {nrLinksRefusedAt = Just orderTime} + +-- | Another name's fields, with the page's duration for 2 years at the service's clock. +moveTo :: Ctx -> Text -> Int -> IO OrderFields +moveTo Ctx {cClock} label n = do + t <- readIORef cClock + pure OrderFields {ofLabelHash = labelHash label, ofLength = T.length label, ofDuration = yearsDuration 2 t, ofCommitment = commitmentOf n, ofSealed = "sealed-" <> label <> "-" <> tshow n} + +moveBody :: Ctx -> Secp256k1PrivateKey -> RegistrationId -> OrderFields -> IO J.Object +moveBody ctx key rid fields = clockSeconds ctx >>= moveBodyAt ctx key rid fields + +moveBodyAt :: Ctx -> Secp256k1PrivateKey -> RegistrationId -> OrderFields -> Word64 -> IO J.Object +moveBodyAt ctx key rid fields@OrderFields {ofLabelHash = LabelHash lh, ofLength, ofDuration, ofCommitment, ofSealed} timestamp = do + sig <- signWith ctx key $ retargetMessage rid fields timestamp + pure $ + KM.fromList + [ ("labelHash", J.String $ hex lh), + ("length", J.toJSON ofLength), + ("duration", J.toJSON ofDuration), + ("commitment", J.String $ hex ofCommitment), + ("sealed", J.String ofSealed), + ("timestamp", J.toJSON timestamp), + ("signature", J.String sig) + ] + +postMove :: Ctx -> RegistrationId -> J.Object -> IO (Int, Maybe J.Object) +postMove ctx rid = post ctx (registrationPath rid <> "/name") . J.encode + +move :: Ctx -> Secp256k1PrivateKey -> NameRegistration -> OrderFields -> IO (Int, Maybe J.Object) +move ctx key NameRegistration {nrId} fields = moveBody ctx key nrId fields >>= postMove ctx nrId + +-- | The view of an accepted move, failing the test otherwise. +moved :: Ctx -> Secp256k1PrivateKey -> NameRegistration -> OrderFields -> IO J.Object +moved ctx key r fields = + move ctx key r fields >>= \case + (200, Just v) -> pure v + other -> error $ "move refused: " <> show other + +registrationPath :: RegistrationId -> String +registrationPath (RegistrationId rid) = "/api/registration/" <> T.unpack rid + +getView :: Ctx -> NameRegistration -> IO J.Object +getView ctx NameRegistration {nrId} = webGet (cClient ctx) (registrationPath nrId) >>= jsonObject + +findBody :: Ctx -> Secp256k1PrivateKey -> Text -> Word64 -> IO J.Object +findBody ctx key owner timestamp = do + sig <- signWith ctx key $ findMessage (either (error . show) id $ parseAnyCaseAddress owner) timestamp + pure $ KM.fromList [("owner", J.String owner), ("timestamp", J.toJSON timestamp), ("signature", J.String sig)] + +postFind :: Ctx -> J.Object -> IO (Int, Maybe J.Object) +postFind ctx = post ctx "/api/registration/find" . J.encode + +-- | A code hash as the page sends it: unpadded base64url of a SHA-256. +takenCodeHash :: Int -> (Text, ByteString) +takenCodeHash n = (T.filter (/= '=') $ safeDecodeUtf8 $ B64U.encode h, h) + where + h = C.sha256Hash $ "taken code " <> BC.pack (show n) + +codeBodyAt :: Ctx -> Secp256k1PrivateKey -> RegistrationId -> Text -> Int -> Word64 -> IO J.Object +codeBodyAt ctx key rid codeHash codeLength timestamp = do + sig <- signWith ctx key $ takenCodeMessage rid codeHash codeLength timestamp + pure $ KM.fromList [("codeHash", J.String codeHash), ("codeLength", J.toJSON codeLength), ("timestamp", J.toJSON timestamp), ("signature", J.String sig)] + +postCode :: Ctx -> RegistrationId -> J.Object -> IO (Int, Maybe J.Object) +postCode ctx rid = post ctx (registrationPath rid <> "/code") . J.encode + +takeCode :: Ctx -> Secp256k1PrivateKey -> NameRegistration -> Text -> Int -> IO (Int, Maybe J.Object) +takeCode ctx key NameRegistration {nrId} codeHash codeLength = clockSeconds ctx >>= codeBodyAt ctx key nrId codeHash codeLength >>= postCode ctx nrId + +currentFields :: NameRegistration -> OrderFields +currentFields NameRegistration {nrLabelHash, nrLength, nrDuration, nrCommitment, nrSealed} = + OrderFields {ofLabelHash = nrLabelHash, ofLength = nrLength, ofDuration = nrDuration, ofCommitment = nrCommitment, ofSealed = nrSealed} + +fieldsIn :: J.Object -> [(Text, J.Value)] -> Expectation +fieldsIn v = mapM_ (\(k, value) -> (k, field k v) `shouldBe` (k, Just value)) + +answered :: Maybe J.Object +answered = Just KM.empty + +refusedWithView :: Text -> J.Object -> (Int, Maybe J.Object) +refusedWithView tag view = (409, Just $ KM.fromList [("error", J.String tag), ("registration", J.Object view)]) + +labelHashText :: Text -> J.Value +labelHashText label = J.String $ hex lh + where + LabelHash lh = labelHash label + +issuedCode :: Ctx -> NameRegistration -> IO PrepaidCode +issuedCode Ctx {cStore} NameRegistration {nrIssuedCodeId} = withTransaction cStore $ \db -> fromJust <$> getPrepaidCodeById db (fromJust nrIssuedCodeId) + +codeRow :: Ctx -> PrepaidCode -> IO PrepaidCode +codeRow Ctx {cStore} PrepaidCode {pcId} = withTransaction cStore $ \db -> fromJust <$> getPrepaidCodeById db pcId + +-- | Bounded, since a deadlock would otherwise hang the suite. +within :: String -> IO a -> IO a +within what action = timeout 10000000 action >>= maybe (error $ what <> " did not finish") pure + +-- | Waits until the turns have at least this many label or code hashes held or waited on. +awaitTurns :: Ctx -> Int -> IO () +awaitTurns Ctx {cOrders} n = within "turns" loop + where + loop = turnsCount (oeTurns cOrders) >>= \held -> unless (held >= n) (threadDelay 1000 >> loop) + +-- | Long enough for a request just sent to reach its turns. +parkDelay :: Int +parkDelay = 200000 + +-- | Each eth_call's delay in the lost-race tests, far longer than a request takes to read its registration. +slowRead :: Int +slowRead = 1000000 + +-- tests + +testFind :: IO () +testFind = withOwner $ \ctx@Ctx {cStore} -> do + forM_ [1 .. 50 :: Int] $ \i -> do + (_, code) <- issueCode ctx 8 2 id + let new = NewRegistration {nrgId = oldOrder i, nrgOwner = ownerA, nrgOrder = order ("alicebakery" <> tshow i) (fromIntegral i), nrgYears = 2} + withTransaction cStore (\db -> createCodeRegistration db new code (addUTCTime (fromIntegral i) t0)) `shouldReturn` Right () + answerFree ctx "alicebakers" + movedOrder <- registrationById ctx (oldOrder 50) >>= \r -> rewrite ctx r failedPhase + to <- moveTo ctx "alicebakers" 10 + void $ moved ctx keyA movedOrder to + (InvoiceId invId, _) <- placed ctx aliceOrder + paid <- invoiceRegistration ctx (InvoiceId invId) + advance ctx 1 + lapsed <- paidIn ctx dynamisOrder $ \r -> (committedPhase r) {nrRevealBefore = Just (seconds orderTime)} + findBody ctx keyA (T.toLower ownerAText) (seconds orderTime) >>= postFind ctx >>= \case + (200, Just v) | Just (J.Array found) <- KM.lookup "registrations" v -> do + let entries = map objectEntry $ toList found + map (field "registrationId") entries `shouldBe` map (Just . idText) (nrId lapsed : nrId paid : [oldOrder i | i <- [50, 49 .. 3]]) + case entries of + lapsedEntry : unpaidEntry : moveEntry : _ -> do + (field "phase" lapsedEntry, nrPhase lapsed) `shouldBe` (Just "failed", PCommitted) + sort (KM.keys unpaidEntry) `shouldBe` sort ["registrationId", "invoiceId", "phase", "createdAt", "labelHash", "sealed"] + unpaidEntry + `shouldBe` KM.fromList + [ ("registrationId", idText $ nrId paid), + ("invoiceId", J.String invId), + ("phase", "unpaid"), + ("createdAt", J.toJSON orderTime), + ("labelHash", labelHashText "alicebakery"), + ("sealed", "sealed-alicebakery-1") + ] + moveEntry + `shouldBe` KM.fromList + [ ("registrationId", "old50"), + ("invoiceId", J.Null), + ("phase", "queued"), + ("createdAt", J.toJSON $ addUTCTime 50 t0), + ("labelHash", labelHashText "alicebakers"), + ("sealed", "sealed-alicebakers-10") + ] + _ -> expectationFailure "fewer than three entries" + other -> expectationFailure $ "find refused: " <> show other + (findBody ctx keyB ownerBText (seconds orderTime) >>= postFind ctx) `shouldReturn` refusedWith 404 "not_found" + where + oldOrder i = RegistrationId $ "old" <> tshow (i :: Int) + idText (RegistrationId t) = J.String t + objectEntry = \case + J.Object o -> o + other -> error $ "not an entry: " <> show other + +testFindRefused :: IO () +testFindRefused = withOwner $ \ctx -> do + void $ placed ctx aliceOrder + let ts = seconds orderTime + (findBody ctx keyB ownerAText ts >>= postFind ctx) `shouldReturn` refusedWith 400 "bad_request" + (findBody ctx keyA ownerAText (ts - signedWindow - 1) >>= postFind ctx) `shouldReturn` refusedWith 400 "bad_request" + (findBody ctx keyA ownerAText (ts + signedWindow + 1) >>= postFind ctx) `shouldReturn` refusedWith 400 "bad_request" + body <- findBody ctx keyA ownerAText ts + postFind ctx (KM.insert "owner" "0x014f9c09" body) `shouldReturn` refusedWith 400 "bad_request" + postFind ctx (KM.delete "signature" body) `shouldReturn` refusedWith 400 "bad_request" + post ctx "/api/registration/find" "[]" `shouldReturn` refusedWith 400 "bad_request" + findBody ctx keyA ownerAText (ts - signedWindow) >>= postFind ctx >>= (`shouldBe` 200) . fst + +testMoveRefusedPhases :: IO () +testMoveRefusedPhases = withOwner $ \ctx -> do + answerFree ctx "alicebakers" + to <- moveTo ctx "alicebakers" 10 + registeredOrder <- paidIn ctx aliceOrder registeredPhase + committedOrder <- paidIn ctx aliceOrder {oCommitment = commitmentOf 2, oTimestamp = seconds orderTime + 1} committedPhase + queuedOrder <- paidIn ctx dynamisOrder id + forM_ [registeredOrder, committedOrder, queuedOrder] $ \r -> do + (nrPhase r,) <$> move ctx keyA r to `shouldReturn` (nrPhase r, refusedWith 400 "bad_request") + stored ctx r `shouldReturn` r + +testMoveAccepted :: IO () +testMoveAccepted = withOwner $ \ctx -> do + answerFree ctx "alicebakers" + failedOrder <- paidIn ctx aliceOrder failedPhase + to <- moveTo ctx "alicebakers" 10 + v <- moved ctx keyA failedOrder to + fieldsIn v + [ ("phase", "queued"), + ("labelHash", labelHashText "alicebakers"), + ("commitment", J.String $ hex $ ofCommitment to), + ("sealed", J.String $ ofSealed to), + ("duration", J.toJSON $ ofDuration to), + ("price", J.Number 10000), + ("moves", J.Number 1), + ("version", J.toJSON $ nrVersion failedOrder + 1), + ("linksRefused", J.Bool False), + ("label", J.Null), + ("commitTx", J.Null), + ("revealAfter", J.Null), + ("revealBefore", J.Null), + ("error", J.Null) + ] + written <- stored ctx failedOrder + (nrPhase written, nrLive written, nrMoves written, nrFailedAt written, nrOrderHash written) `shouldBe` (PQueued, True, 1, Nothing, nrOrderHash failedOrder) + -- the same name with other links, after a reveal refused for its links + refusedOrder <- paidIn ctx (byB aliceOrder) {oCommitment = commitmentOf 2} linksRefusedPhase + sameName <- moveTo ctx "alicebakery" 11 + v2 <- moved ctx keyB refusedOrder sameName + fieldsIn v2 [("phase", "queued"), ("labelHash", labelHashText "alicebakery"), ("linksRefused", J.Bool False), ("commitTx", J.Null), ("revealAfter", J.Null), ("moves", J.Number 1)] + (nrLinksRefusedAt &&& nrCommitTx) <$> stored ctx refusedOrder `shouldReturn` (Nothing, Nothing) + -- a committed order with no reveal past revealBefore reads failed + lapsed <- paidIn ctx dynamisOrder $ \r -> (committedPhase r) {nrRevealBefore = Just (seconds orderTime - 1)} + back <- moveTo ctx "alicebakery" 12 + v3 <- moved ctx keyA lapsed back + fieldsIn v3 [("phase", "queued"), ("error", J.Null), ("price", J.Number 10000)] + +testMoveRepeat :: IO () +testMoveRepeat = withOwner $ \ctx -> do + answerFree ctx "alicebakers" + r <- paidIn ctx aliceOrder failedPhase + -- the current fields from failed: nothing moves + (status, v) <- move ctx keyA r (currentFields r) + (status, field "phase" =<< v, field "moves" =<< v) `shouldBe` (200, Just "failed", Just (J.Number 0)) + stored ctx r `shouldReturn` r + to <- moveTo ctx "alicebakers" 10 + body <- moveBody ctx keyA (nrId r) to + first' <- postMove ctx (nrId r) body + fst first' `shouldBe` 200 + movedOnce <- stored ctx r + advance ctx 3600 + postMove ctx (nrId r) body `shouldReturn` first' + resigned <- moveBody ctx keyA (nrId r) to + postMove ctx (nrId r) resigned `shouldReturn` first' + stored ctx r `shouldReturn` movedOnce + nrMoves movedOnce `shouldBe` 1 + +testMoveLimit :: IO () +testMoveLimit = withOwner $ \ctx -> do + answerFree ctx "alicebakers" + r <- paidIn ctx aliceOrder failedPhase + forM_ (zip [1 :: Int ..] ["alicebakers", "alicebakery", "alicebakers"]) $ \(n, label) -> do + to <- moveTo ctx label (10 + n) + v <- moved ctx keyA r to + field "moves" v `shouldBe` Just (J.toJSON n) + rewrite ctx r failedPhase + limited <- stored ctx r + to <- moveTo ctx "alicebakery" 20 + view <- getView ctx limited + move ctx keyA limited to `shouldReturn` refusedWithView "move_limit" view + (field "moves" view, field "phase" view) `shouldBe` (Just (J.Number 3), Just "failed") + stored ctx r `shouldReturn` limited + +testMoveMeetsOrder :: IO () +testMoveMeetsOrder = withOwner $ \ctx -> do + answerFree ctx "alicebakers" + r <- paidIn ctx aliceOrder failedPhase + void $ placed ctx dynamisOrder + toDynamis <- moveTo ctx "dynamis" 10 + move ctx keyA r toDynamis `shouldReturn` refusedWith 409 "order_exists" + void $ placed ctx (byB aliceOrder) {oLabel = "alicebakers", oCommitment = commitmentOf 4} + toForeign <- moveTo ctx "alicebakers" 4 + move ctx keyA r toForeign `shouldReturn` refusedWith 409 "order_exists" + stored ctx r `shouldReturn` r + +testMoveOrderChecks :: IO () +testMoveOrderChecks = withOwner $ \ctx@Ctx {cNode} -> do + r <- paidIn ctx aliceOrder failedPhase + to <- moveTo ctx "alicebakers" 10 + move ctx keyA r to {ofLength = 5} `shouldReturn` refusedWith 400 "invalid_name" + move ctx keyA r to {ofLength = 64} `shouldReturn` refusedWith 400 "invalid_name" + answerFree ctx "alicebakers" + move ctx keyA r to {ofDuration = ofDuration to + 3601} `shouldReturn` refusedWith 400 "bad_request" + answerReserved ctx "alicebakers" 1 + move ctx keyA r to `shouldReturn` refusedWith 409 "name_taken" + setFault cNode "eth_call" HttpFailure + move ctx keyA r to `shouldReturn` refusedWith 503 "name_check_unavailable" + stored ctx r `shouldReturn` r + +testMovePrice :: IO () +testMovePrice = withOwner $ \ctx -> do + answerFree ctx "alicebakers" + cheap <- paidIn ctx aliceOrder failedPhase + toDynamis <- moveTo ctx "dynamis" 10 + move ctx keyA cheap toDynamis `shouldReturn` (409, Just $ KM.fromList [("error", "price_too_high"), ("price", J.Number 20000)]) + stored ctx cheap `shouldReturn` cheap + dear <- paidIn ctx (byB dynamisOrder) takenPhase + toCheaper <- moveTo ctx "alicebakers" 11 + v <- moved ctx keyB dear toCheaper + (field "price" v, field "phase" v) `shouldBe` (Just (J.Number 10000), Just "queued") + nrPrice <$> stored ctx dear `shouldReturn` 10000 + +testMoveCodeOrder :: IO () +testMoveCodeOrder = withOwner $ \ctx@Ctx {cStore} -> do + answerFree ctx "alicebakers" + (r, code@PrepaidCode {pcCodeHash}) <- codeIn ctx 8 aliceOrder failedPhase + toShorter <- moveTo ctx "dynamis" 10 + move ctx keyA r toShorter `shouldReturn` refusedWith 409 "code_not_covering" + stored ctx r `shouldReturn` r + withTransaction cStore (\db -> revokePrepaidCode db pcCodeHash orderTime) `shouldReturn` Revoked (pcId code) + withTransaction cStore $ \db -> DB.execute db "UPDATE sx_badge_service_name_prepaid_codes SET expires_at = ? WHERE code_hash = ?" (orderTime, DB.Binary pcCodeHash) + to <- moveTo ctx "alicebakers" 11 + v <- moved ctx keyA r to + (field "phase" v, field "price" v) `shouldBe` (Just "queued", Just (J.Number 0)) + (pcReservedBy &&& pcSpentAt) <$> codeRow ctx code `shouldReturn` (Just (nrId r), Nothing) + +testMoveReleasedCode :: IO () +testMoveReleasedCode = withOwner $ \ctx@Ctx {cStore} -> do + answerFree ctx "alicebakers" + spender <- paidIn ctx (byB aliceOrder) {oCommitment = commitmentOf 20} id + holder <- paidIn ctx (byB dynamisOrder) {oCommitment = commitmentOf 21} id + let 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 -> DB.execute db "UPDATE sx_badge_service_name_prepaid_codes SET expires_at = ? WHERE code_hash = ?" (orderTime, DB.Binary pcCodeHash), refusedWith 409 "code_expired") + ] + forM_ (zip [1 :: Int ..] refusals) $ \(n, (what, change, refusal)) -> do + let label = "codeorder" <> tshow n + answerFree ctx label + (r, code) <- codeIn ctx 8 aliceOrder {oLabel = label, oCommitment = commitmentOf (30 + n)} failedPhase + withTransaction cStore (\db -> releasePrepaidCode db (pcId code) (nrId r)) `shouldReturn` True + withTransaction cStore $ change code + to <- moveTo ctx "alicebakers" (40 + n) + (what,) <$> move ctx keyA r to `shouldReturn` (what, refusal) + stored ctx r `shouldReturn` r + (r, code) <- codeIn ctx 8 aliceOrder failedPhase + withTransaction cStore (\db -> releasePrepaidCode db (pcId code) (nrId r)) `shouldReturn` True + to <- moveTo ctx "alicebakers" 50 + void $ moved ctx keyA r to + pcReservedBy <$> codeRow ctx code `shouldReturn` Just (nrId r) + +testMoveSizes :: IO () +testMoveSizes = withOwner $ \ctx -> do + answerFree ctx "alicebakers" + r <- paidIn ctx aliceOrder failedPhase + to <- moveTo ctx "alicebakers" 10 + let longest = to {ofSealed = T.replicate 11095 "s"} + body <- moveBody ctx keyA (nrId r) longest + postMove ctx (nrId r) (KM.insert "owner" (J.String $ T.replicate 5300 "0") body) `shouldReturn` refusedWith 400 "bad_request" + move ctx keyA r to {ofSealed = T.replicate 11096 "s"} `shouldReturn` refusedWith 400 "bad_request" + valid <- moveBody ctx keyA (nrId r) to + forM_ [KM.insert "labelHash" (J.String $ T.toUpper $ hex $ (\(LabelHash h) -> h) $ ofLabelHash to) valid, KM.delete "signature" valid, KM.insert "length" "11" valid] $ \malformed -> + postMove ctx (nrId r) malformed `shouldReturn` refusedWith 400 "bad_request" + post ctx (registrationPath (nrId r) <> "/name") "[]" `shouldReturn` refusedWith 400 "bad_request" + stored ctx r `shouldReturn` r + -- an owner in the body is ignored + (status, v) <- postMove ctx (nrId r) (KM.insert "owner" (J.String ownerBText) body) + (status, field "sealed" =<< v, field "owner" =<< v) `shouldBe` (200, Just (J.String $ ofSealed longest), Just (J.String ownerAText)) + +testMoveRefusedSigner :: IO () +testMoveRefusedSigner = withOwner $ \ctx -> do + answerFree ctx "alicebakers" + r <- paidIn ctx aliceOrder failedPhase + to <- moveTo ctx "alicebakers" 10 + move ctx keyB r to `shouldReturn` refusedWith 400 "bad_request" + ts <- clockSeconds ctx + (moveBodyAt ctx keyA (nrId r) to (ts - signedWindow - 1) >>= postMove ctx (nrId r)) `shouldReturn` refusedWith 400 "bad_request" + stored ctx r `shouldReturn` r + let unknown = RegistrationId "t2Jk8RmQ4vXw9NcP3yLb6g" + (moveBody ctx keyA unknown to >>= postMove ctx unknown) `shouldReturn` refusedWith 404 "not_found" + +testMoveLostRace :: IO () +testMoveLostRace = withOwner $ \ctx@Ctx {cNode} -> do + answerFree ctx "alicebakers" + r <- paidIn ctx aliceOrder failedPhase + to <- moveTo ctx "alicebakers" 10 + setFault cNode "eth_call" (Slow slowRead) + moving <- async $ move ctx keyA r to + awaitTurns ctx 2 + threadDelay (slowRead `div` 5) + changed <- rewrite ctx r id + clearFault cNode "eth_call" + answer <- within "the move" $ wait moving + view <- getView ctx changed + answer `shouldBe` refusedWithView "registration_changed" view + field "version" view `shouldBe` Just (J.toJSON $ nrVersion r + 1) + stored ctx r `shouldReturn` changed + +-- | Each round holds the higher hash's turn while both orders start, the one moving from the lower hash first in odd +-- rounds and last in even ones, so that without the hash order some round has each order holding one turn and waiting +-- for the other's. +testMovesCross :: IO () +testMovesCross = withOwnerAs (\cfg -> cfg {nMaxOrderMoves = 100}) $ \ctx -> do + answerFree ctx "alicebakers" + let (low, high) = case sortOn hashOf ["alicebakery", "alicebakers"] of + [l, h] -> (l, h) + _ -> error "two names" + a <- paidIn ctx aliceOrder {oLabel = low, oCommitment = commitmentOf 60} failedPhase + b <- paidIn ctx (byB aliceOrder) {oLabel = high, oCommitment = commitmentOf 61} failedPhase + forM_ [1 .. 6 :: Int] $ \n -> do + rs <- mapM (stored ctx) [a, b] + let onName label = fromJust $ find ((== labelHash label) . nrLabelHash) rs + keyOf r = if nrOwner r == nrOwner a then keyA else keyB + bodyTo r label k = moveTo ctx label (100 + 2 * n + k) >>= moveBody ctx (keyOf r) (nrId r) + (fromLow, fromHigh) = (onName low, onName high) + lowMove <- (fromLow,) <$> bodyTo fromLow high 0 + highMove <- (fromHigh,) <$> bodyTo fromHigh low 1 + holding <- newEmptyMVar + release <- newEmptyMVar + holder <- async $ withLabelTurn (oeTurns $ cOrders ctx) (labelHash high) $ putMVar holding () >> takeMVar release + takeMVar holding + let started = if odd n then [lowMove, highMove] else [highMove, lowMove] + moves <- forM started $ \(r, body) -> async (postMove ctx (nrId r) body) <* threadDelay parkDelay + putMVar release () + wait holder + outcomes <- within ("round " <> show n) $ mapM wait moves + map fst outcomes `shouldBe` [200, 200] + forM_ [a, b] $ \r -> rewrite ctx r failedPhase + where + hashOf label = (\(LabelHash h) -> h) (labelHash label) + +testTakenCode :: IO () +testTakenCode = withOwner $ \ctx@Ctx {cNode} -> do + answerPrices ctx launchPricesAnswer + answerCall cNode fakeController (rentPriceCall 6) $ Returns $ rentPriceAnswer 40000 + answerCall cNode fakeController (rentPriceCall 12) $ Returns $ rentPriceAnswer 10000 + forM_ (zip [1 :: Int ..] [("bakery", 40000, 6), ("dynamis", 20000, 7), ("alicebakery2", 10000, 8)]) $ \(n, (label, price, len)) -> do + answerFree ctx label + r <- paidIn ctx aliceOrder {oLabel = label, oPrice = price, oCommitment = commitmentOf (70 + n)} takenPhase + field "codeLength" <$> getView ctx r `shouldReturn` Just (J.toJSON len) + let (hashText, hash) = takenCodeHash n + takeCode ctx keyA r hashText len `shouldReturn` (200, answered) + written <- stored ctx r + (nrPhase written, nrLive written, nrVersion written) `shouldBe` (PCodeIssued, False, nrVersion r + 1) + PrepaidCode {pcCodeHash, pcMinLength, pcYears, pcPaymentStatus, pcReservedBy, pcSpentAt, pcRevokedAt, pcExpiresAt} <- issuedCode ctx written + (pcCodeHash, pcMinLength, pcYears, pcPaymentStatus) `shouldBe` (hash, len, 2, CPSPaid) + (pcReservedBy, pcSpentAt, pcRevokedAt, pcExpiresAt) `shouldBe` (Nothing, Nothing, Nothing, Nothing) + v <- getView ctx r + (field "phase" v, field "codeLength" v) `shouldBe` (Just "code_issued", Just (J.toJSON len)) + +-- | 12 letters paid 10000 cents: with these prices 8 letters and longer cost that or less. +takenTwelve :: Ctx -> IO NameRegistration +takenTwelve ctx@Ctx {cNode} = do + answerPrices ctx launchPricesAnswer + answerCall cNode fakeController (rentPriceCall 12) $ Returns $ rentPriceAnswer 10000 + answerFree ctx "alicebakery2" + paidIn ctx aliceOrder {oLabel = "alicebakery2", oPrice = 10000} takenPhase + +testTakenCodeRepeat :: IO () +testTakenCodeRepeat = withOwner $ \ctx -> do + r <- takenTwelve ctx + let (hashText, _) = takenCodeHash 1 + body <- clockSeconds ctx >>= codeBodyAt ctx keyA (nrId r) hashText 8 + postCode ctx (nrId r) body `shouldReturn` (200, answered) + issued <- stored ctx r + -- 9 letters and longer now cost 10000 cents, so a fresh computation would answer 9 + answerPrices ctx $ pricesAnswer 5000 [(8, 6000), (7, 10000), (6, 20000)] + advance ctx 3600 + postCode ctx (nrId r) body `shouldReturn` (200, answered) + takeCode ctx keyA r hashText 9 `shouldReturn` (200, answered) + stored ctx r `shouldReturn` issued + field "codeLength" <$> getView ctx r `shouldReturn` Just (J.Number 8) + takeCode ctx keyA r (fst $ takenCodeHash 2) 9 `shouldReturn` refusedWith 400 "bad_request" + +testCodeLengthChanged :: IO () +testCodeLengthChanged = withOwner $ \ctx@Ctx {cStore} -> do + r <- takenTwelve ctx + field "codeLength" <$> getView ctx r `shouldReturn` Just (J.Number 8) + answerPrices ctx $ pricesAnswer 5000 [(8, 6000), (7, 10000), (6, 20000)] + let (hashText, hash) = takenCodeHash 1 + takeCode ctx keyA r hashText 8 `shouldReturn` (409, Just $ KM.fromList [("error", "code_length_changed"), ("codeLength", J.Number 9)]) + stored ctx r `shouldReturn` r + withTransaction cStore (`getPrepaidCode` hash) `shouldReturn` Nothing + takeCode ctx keyA r hashText 9 `shouldReturn` (200, answered) + pcMinLength <$> (issuedCode ctx =<< stored ctx r) `shouldReturn` 9 + +testCodeUnavailable :: IO () +testCodeUnavailable = withOwner $ \ctx@Ctx {cNode} -> do + r <- takenTwelve ctx + answerPrices ctx $ pricesAnswer 6000 [] + let (hashText, _) = takenCodeHash 1 + takeCode ctx keyA r hashText 8 `shouldReturn` refusedWith 409 "code_unavailable" + field "codeLength" <$> getView ctx r `shouldReturn` Just J.Null + setFault cNode "eth_call" HttpFailure + takeCode ctx keyA r hashText 8 `shouldReturn` refusedWith 503 "provider_unavailable" + stored ctx r `shouldReturn` r + +testTakenCodeRefused :: IO () +testTakenCodeRefused = withOwner $ \ctx -> do + r <- takenTwelve ctx + let (hashText, _) = takenCodeHash 1 + takeCode ctx keyB r hashText 8 `shouldReturn` refusedWith 400 "bad_request" + ts <- clockSeconds ctx + (codeBodyAt ctx keyA (nrId r) hashText 8 (ts - signedWindow - 1) >>= postCode ctx (nrId r)) `shouldReturn` refusedWith 400 "bad_request" + body <- codeBodyAt ctx keyA (nrId r) hashText 8 ts + forM_ [KM.insert "codeHash" (J.String $ T.drop 1 hashText) body, KM.insert "codeLength" "8" body, KM.delete "timestamp" body] $ \malformed -> + postCode ctx (nrId r) malformed `shouldReturn` refusedWith 400 "bad_request" + stored ctx r `shouldReturn` r + (codeOrder, _) <- codeIn ctx 8 aliceOrder {oCommitment = commitmentOf 5} takenPhase + committedOrder <- paidIn ctx dynamisOrder committedPhase + forM_ [codeOrder, committedOrder] $ \o -> do + takeCode ctx keyA o hashText 8 `shouldReturn` refusedWith 400 "bad_request" + stored ctx o `shouldReturn` o + let unknown = RegistrationId "t2Jk8RmQ4vXw9NcP3yLb6g" + (codeBodyAt ctx keyA unknown hashText 8 ts >>= postCode ctx unknown) `shouldReturn` refusedWith 404 "not_found" + +testCodeConflict :: IO () +testCodeConflict = withOwner $ \ctx@Ctx {cStore} -> do + r <- takenTwelve ctx + let (hashText, hash) = takenCodeHash 1 + Right _ <- withTransaction cStore $ \db -> insertPrepaidCode db NewPrepaidCode {npcCodeHash = hash, npcMinLength = 8, npcYears = 2, npcPaymentStatus = CPSPaid, npcExpiresAt = Nothing} orderTime + takeCode ctx keyA r hashText 8 `shouldReturn` refusedWith 409 "code_conflict" + stored ctx r `shouldReturn` r + +testCodeLostRace :: IO () +testCodeLostRace = withOwner $ \ctx@Ctx {cNode, cStore} -> do + r <- takenTwelve ctx + let (hashText, hash) = takenCodeHash 1 + setFault cNode "eth_call" (Slow slowRead) + issuing <- async $ takeCode ctx keyA r hashText 8 + awaitTurns ctx 1 + threadDelay (slowRead `div` 5) + changed <- rewrite ctx r id + clearFault cNode "eth_call" + answer <- within "the code" $ wait issuing + view <- getView ctx changed + answer `shouldBe` refusedWithView "registration_changed" view + stored ctx r `shouldReturn` changed + withTransaction cStore (`getPrepaidCode` hash) `shouldReturn` Nothing + +testPollsWoken :: IO () +testPollsWoken = withOwner $ \ctx -> do + answerFree ctx "alicebakers" + r <- paidIn ctx aliceOrder failedPhase + poll <- held ctx r + to <- moveTo ctx "alicebakers" 10 + void $ moved ctx keyA r to + (status, v) <- woken poll + (status, field "version" v, field "phase" v) `shouldBe` (200, Just (J.toJSON $ nrVersion r + 1), Just "queued") + t <- takenTwelve ctx + poll' <- held ctx t + takeCode ctx keyA t (fst $ takenCodeHash 1) 8 `shouldReturn` (200, answered) + (status', v') <- woken poll' + (status', field "version" v', field "phase" v') `shouldBe` (200, Just (J.toJSON $ nrVersion t + 1), Just "code_issued") + where + held ctx'@Ctx {cOrders} NameRegistration {nrId, nrVersion} = do + waiting <- atomically $ phasesWaiting (oePhases cOrders) + poll <- async $ webGet (cClient ctx') (registrationPath nrId <> "?seenVersion=" <> show nrVersion) >>= \resp -> (statusOf resp,) <$> jsonObject resp + within "the hold" $ atomically $ phasesWaiting (oePhases cOrders) >>= check . (> waiting) + pure poll + woken :: Async (Int, J.Object) -> IO (Int, J.Object) + woken poll = timeout 5000000 (wait poll) >>= maybe (cancel poll >> error "the poll was not woken") pure diff --git a/tests/Test.hs b/tests/Test.hs index 4a1bf2d3d4..cef3aeb4a3 100644 --- a/tests/Test.hs +++ b/tests/Test.hs @@ -16,6 +16,7 @@ import Bots.StoreService.NamesContractsTests import Bots.StoreService.NamesLabelTests import Bots.StoreService.NamesLinksTests import Bots.StoreService.NamesOrdersTests +import Bots.StoreService.NamesOwnerTests import Bots.StoreService.NamesPhasesTests import Bots.StoreService.NamesProfilesTests import Bots.StoreService.NamesRecordsTests @@ -107,6 +108,7 @@ main = do namesLabelTests namesLinksTests namesOrdersTests + namesOwnerTests namesPhasesTests namesProfilesTests namesRecordsTests From 46b8162f8b61d8056fe82ef6084ee86d20fc49a7 Mon Sep 17 00:00:00 2001 From: shum Date: Thu, 22 Oct 2026 05:34:12 +0000 Subject: [PATCH 3/7] store: register a failed order before moving it --- .../src/StoreService/Names/Orders.hs | 64 ++++++++++++--- .../src/StoreService/Web/Names/Owner.hs | 12 ++- tests/Bots/StoreService/NamesOwnerTests.hs | 78 +++++++++++++++++-- 3 files changed, 135 insertions(+), 19 deletions(-) diff --git a/apps/simplex-store-service/src/StoreService/Names/Orders.hs b/apps/simplex-store-service/src/StoreService/Names/Orders.hs index c2788bddcd..2a88707c8f 100644 --- a/apps/simplex-store-service/src/StoreService/Names/Orders.hs +++ b/apps/simplex-store-service/src/StoreService/Names/Orders.hs @@ -1,6 +1,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} -- | The checks every order runs, by paid invoice or prepaid code, in the contract's order. module StoreService.Names.Orders @@ -11,6 +12,7 @@ module StoreService.Names.Orders ExistingOrder (..), ClosedOrder (..), WriteRefusal (..), + Landing (..), maxSealedChars, signedRequestSeconds, parseOrderRequest, @@ -34,14 +36,17 @@ module StoreService.Names.Orders checkMoveMeets, checkMovePrice, retargetOrder, + confirmLanded, issuedCodeHash, checkTakenCodeLength, issueTakenCode, ) where +import Control.Applicative ((<|>)) import qualified Control.Exception as E -import Control.Monad (unless, when) +import Control.Monad (forM, unless, when) +import Control.Monad.Except (ExceptT (..), runExceptT) import qualified Data.Aeson as J import qualified Data.Aeson.KeyMap as KM import Data.Bifunctor (first) @@ -64,13 +69,13 @@ import Simplex.Messaging.SimplexName (LabelHash (..)) import Simplex.Messaging.Util (tshow) import StoreService.Config (NamesConfig (..)) import StoreService.Log (logWarn) -import StoreService.Names.Codes (CodeRefusal (..), codeRefusal, reserveCode, reserveRefusal) -import StoreService.Names.Contracts (Contracts, NameStatus (..), chainPriceCents, codeLengthFor, nameStatus, secondsPerYear) +import StoreService.Names.Codes (CodeRefusal (..), codeRefusal, reserveCode, reserveRefusal, spendCode) +import StoreService.Names.Contracts (Contracts, NameStatus (..), chainPriceCents, codeLengthFor, nameExpires, nameStatus, ownerOfToken, secondsPerYear) import StoreService.Names.Env (NamesEnv (..)) import StoreService.Names.Phases (Phases, RegistrationId) import StoreService.Names.Abi (bytes32FromHex) import StoreService.Names.Signatures (OrderFields (..), orderMessage, parseChecksumAddress, parseSignature, personalDigest) -import StoreService.Names.Store (CodeHashTaken, LiveOrder (..), NamePhase (..), NameRegistration (..), NewPrepaidCode (..), NewRegistration (..), PrepaidCode (..), RegistrationPayment (..), RegistrationRefused (..), VersionWrite (..), closeOverdue, createCodeRegistration, getLiveOrders, getPrepaidCode, getPrepaidCodeById, getRegistrationByOrderHash, insertPrepaidCode, isLabelRegistering, retargetRegistration, setIssuedCode, updateRegistration) +import StoreService.Names.Store (CodeHashTaken, LiveOrder (..), NamePhase (..), NameRegistration (..), NewPrepaidCode (..), NewRegistration (..), PrepaidCode (..), RegistrationPayment (..), RegistrationRefused (..), NameTransaction (..), TxFor (..), TxStatus (..), VersionWrite (..), closeOverdue, createCodeRegistration, getLiveOrders, getPrepaidCode, getPrepaidCodeById, getRegistrationByOrderHash, insertPrepaidCode, isLabelRegistering, registrationTransactions, retargetRegistration, setIssuedCode, updateRegistration) import StoreService.Names.Turns (Turns, withCodeTurn) data OrdersEnv = OrdersEnv @@ -124,6 +129,11 @@ data ClosedOrder = ClosedOrder {coRegistration :: NameRegistration, coVersion :: data WriteRefusal = WRChanged | WRRefused OrderRefusal deriving (Eq, Show) +-- | What /retry's first check found on the order's current name: no register through, the order registered at a new version, +-- the order changed since it was read, or a failed chain read. +data Landing = LNotLanded | LRegistered Int64 | LChanged | LUnread + deriving (Eq, Show) + newtype TakenCodeConflict = TakenCodeConflict CodeHashTaken deriving (Show) @@ -304,19 +314,53 @@ checkMovePrice ct NameRegistration {nrPrice, nrYears} len = retargetOrder :: OrdersEnv -> NameRegistration -> OrderFields -> Int -> IO (Either WriteRefusal Int64) retargetOrder OrdersEnv {oeStore, oeTurns, oeNow} r@NameRegistration {nrId, nrPayment} fields@OrderFields {ofLength} price = do now <- oeNow - let write db = written <$> retargetRegistration db r fields price now + let write db = versionWritten <$> retargetRegistration db r fields price now case nrPayment of RPInvoice {} -> withTransaction oeStore write RPCode codeId -> withTransaction oeStore (`getPrepaidCodeById` codeId) >>= \case Nothing -> pure $ Left $ WRRefused $ ORCode CRInvalid Just PrepaidCode {pcCodeHash} -> either (Left . WRRefused . ORCode) id <$> reserveCode oeTurns oeStore now pcCodeHash nrId ofLength write + +versionWritten :: VersionWrite -> Either WriteRefusal Int64 +versionWritten = \case + Written v -> Right v + VersionChanged -> Left WRChanged + LiveOrderExists -> Left $ WRRefused OROrderExists + NotLive -> Left $ WRRefused ORBadRequest + +-- | /retry's first check, on the order's current name: a register mined with status 1, or the owner holding the name, went through +-- with only its confirmation lost. The order then becomes registered by a compare-and-set on the version read, a code order spending its code. +confirmLanded :: OrdersEnv -> NameRegistration -> IO Landing +confirmLanded OrdersEnv {oeStore, oeContracts, oeTurns, oeNow} r@NameRegistration {nrId, nrOwner, nrLabelHash, nrPayment, nrRegisterTx, nrRegisterBlock} = do + txs <- withTransaction oeStore (`registrationTransactions` nrId) + let mined = [(ntHash, ntMinedBlock) | NameTransaction {ntFor = TxRegister _, ntStatus = TSMined, ntHash, ntMinedBlock} <- txs] + runExceptT (landed mined) >>= \case + Left e -> LUnread <$ logWarn ("names: a register check's chain read failed: " <> tshow e) + Right Nothing -> pure LNotLanded + Right (Just (tx, expiry)) -> either (const LChanged) LRegistered <$> markRegistered tx expiry where - written = \case - Written v -> Right v - VersionChanged -> Left WRChanged - LiveOrderExists -> Left $ WRRefused OROrderExists - NotLive -> Left $ WRRefused ORBadRequest + landed mined = do + registerTx <- case mined of + tx : _ -> pure $ Just $ Just tx + [] -> (\holder -> if holder == Just nrOwner then Just Nothing else Nothing) <$> ExceptT (ownerOfToken oeContracts nrLabelHash) + forM registerTx $ \tx -> (tx,) <$> ExceptT (nameExpires oeContracts nrLabelHash) + markRegistered tx expiry = do + now <- oeNow + let registered = + r + { nrPhase = PRegistered, + nrRegisterTx = (fst <$> tx) <|> nrRegisterTx, + nrRegisterBlock = (snd =<< tx) <|> nrRegisterBlock, + nrExpiresAt = Just expiry, + nrRegisteredAt = Just now, + nrFailedAt = Nothing, + nrError = Nothing + } + write db = versionWritten <$> updateRegistration db registered now + case nrPayment of + RPInvoice {} -> withTransaction oeStore write + RPCode codeId -> fmap fst <$> spendCode oeTurns oeStore now codeId nrId write -- | The hash of the code a taken order was turned into. issuedCodeHash :: DBStore -> NameRegistration -> IO (Maybe ByteString) diff --git a/apps/simplex-store-service/src/StoreService/Web/Names/Owner.hs b/apps/simplex-store-service/src/StoreService/Web/Names/Owner.hs index 31a83620ab..2e302fe3a6 100644 --- a/apps/simplex-store-service/src/StoreService/Web/Names/Owner.hs +++ b/apps/simplex-store-service/src/StoreService/Web/Names/Owner.hs @@ -28,7 +28,7 @@ import StoreService.Names.Abi (hex) import StoreService.Names.Orders import StoreService.Names.Phases (RegistrationId (..), publish) import StoreService.Names.Signatures (OrderFields (..), findMessage, parseAnyCaseAddress, parseSignature, retargetMessage, takenCodeMessage) -import StoreService.Names.Store (NameRegistration (..), RegistrationPayment (..), findRegistrations, getRegistration) +import StoreService.Names.Store (NamePhase (..), NameRegistration (..), RegistrationPayment (..), findRegistrations, getRegistration) import StoreService.Names.Turns (withLabelTurn, withLabelTurns) import StoreService.Names.View (registrationView) import StoreService.Web.Http (Respond, internalError, jsonResponse, maxBodyBytes, nameBodyBytes, notFound, parseCodeHash, readBoundedBody) @@ -113,10 +113,18 @@ retargetHandler env@OrdersEnv {oeStore, oeConfig, oeContracts, oeTurns, oeNow} r Just stored | nrLabelHash stored `notElem` held -> changed | otherwise -> moveTo now (registrationAt now stored) fields timestamp - moveTo now r@NameRegistration {nrMoves, nrYears, nrPrice, nrPayment} fields@OrderFields {ofLabelHash, ofLength, ofDuration} timestamp + moveTo now r@NameRegistration {nrPhase} fields timestamp | orderFieldsOf r == fields = answerNow . jsonResponse status200 <$> registrationView oeStore oeConfig oeContracts r | Left refusal <- checkTimestamp now timestamp = refuse refusal | not (movable r) = refuse ORBadRequest + | nrPhase == PFailed = + confirmLanded env r >>= \case + LNotLanded -> moveChecked now r fields + LRegistered v -> written env rid v <$> registrationChangedResponse env rid + LChanged -> changed + LUnread -> refuse ORNameCheckUnavailable + | otherwise = moveChecked now r fields + moveChecked now r@NameRegistration {nrMoves, nrYears, nrPrice, nrPayment} fields@OrderFields {ofLabelHash, ofLength, ofDuration} | nrMoves >= nMaxOrderMoves oeConfig = answerNow <$> registrationRefusalResponse env "move_limit" rid | otherwise = firstRefusal [checkMoveMeets oeStore r fields now, pure $ checkDuration oeConfig now nrYears ofDuration, checkNameFree oeContracts oeStore ofLabelHash] >>= \case diff --git a/tests/Bots/StoreService/NamesOwnerTests.hs b/tests/Bots/StoreService/NamesOwnerTests.hs index de5d38322a..f59a6adb2c 100644 --- a/tests/Bots/StoreService/NamesOwnerTests.hs +++ b/tests/Bots/StoreService/NamesOwnerTests.hs @@ -30,7 +30,7 @@ import Data.Text (Text) import qualified Data.Text as T import Data.Time.Clock (UTCTime, addUTCTime) import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds) -import Data.Word (Word64) +import Data.Word (Word64, Word8) import Network.HTTP.Client (defaultManagerSettings, newManager) import qualified Network.Wai.Handler.Warp as Warp import Simplex.Chat.Badges.Types (BadgeCodePaymentStatus (..)) @@ -39,6 +39,7 @@ import Simplex.Messaging.Agent.Store.Common (withTransaction) import qualified Simplex.Messaging.Agent.Store.DB as DB import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Crypto.Secp256k1 (Secp256k1PrivateKey, signRecoverable) +import Simplex.Messaging.Eth.Address (Address) import Simplex.Messaging.Eth.EIP712 (serializeSignature) import Simplex.Messaging.SimplexName (LabelHash (..), labelHash) import Simplex.Messaging.Util (safeDecodeUtf8, tshow) @@ -71,6 +72,8 @@ namesOwnerTests = describe "StoreService names: owner" $ do it "answers the fourth move move_limit with the current view, changing nothing" testMoveLimit it "refuses a move meeting another live order of the wallet's or the commitment with a bare order_exists, before the price" testMoveMeetsOrder it "runs the order checks on the new fields: invalid_name, the duration, name_taken, name_check_unavailable" testMoveOrderChecks + it "registers a failed order whose register went through, by its mined register or by ownerOf, answering registration_changed and spending a code" testMoveLanded + it "answers name_check_unavailable when the register check cannot read the chain, changing nothing" testMoveLandedUnread it "answers a dearer name price_too_high with its price, and moves to a cheaper one at its price" testMovePrice it "checks a code order's code again: code_not_covering for a shorter name, a held code kept though revoked and expired since" testMoveCodeOrder it "reserves a released code again while unused, else answers code_used, code_reserved, code_invalid or code_expired" testMoveReleasedCode @@ -101,9 +104,10 @@ withOwnerAs change action = withOrders $ \ctx@Ctx {cOrders, cWeb} -> do web = cWeb {weOrders = Just orders} routes path = ownerRoutes orders path <|> codeRoutes orders (weProviders web) (weWaiters web) path app req respond = fromMaybe (webApp web req respond) (namesApp (weHttp web) routes req respond) + ctx' = ctx {cOrders = orders, cWeb = web} + forM_ ["alicebakery", "dynamis"] $ answerUnowned ctx' mgr <- newManager defaultManagerSettings - Warp.testWithApplication (pure app) $ \port -> - action ctx {cOrders = orders, cWeb = web, cClient = (mgr, "http://127.0.0.1:" <> show port)} + Warp.testWithApplication (pure app) $ \port -> action ctx' {cClient = (mgr, "http://127.0.0.1:" <> show port)} ownerRoutes :: OrdersEnv -> [Text] -> Maybe Route ownerRoutes orders = \case @@ -131,14 +135,38 @@ byB o = o {oOwner = ownerBText, oKey = keyB} dynamisOrder :: Order dynamisOrder = aliceOrder {oLabel = "dynamis", oCommitment = commitmentOf 3, oSealed = "sealed-dynamis-3", oPrice = 20000} --- viem's selectors of nameExpires(uint256) and reservedNames(bytes32), as in the dynamis calls of the orders tests -nameExpiresSelector, reservedNamesSelector :: ByteString +-- viem's selectors of nameExpires(uint256), reservedNames(bytes32) and ownerOf(uint256), as in the calls of the contracts tests +nameExpiresSelector, reservedNamesSelector, ownerOfSelector :: ByteString nameExpiresSelector = unhex "d6e4fa86" reservedNamesSelector = unhex "389c0748" +ownerOfSelector = unhex "6352211e" --- | The chain answers the name as available. +labelBytes :: Text -> ByteString +labelBytes label = lh + where + LabelHash lh = labelHash label + +-- | ownerOf of a name nobody holds: the registrar's bare require, a revert without data. +answerUnowned :: Ctx -> Text -> IO () +answerUnowned Ctx {cNode} label = answerCall cNode (registrarOf cNode) (ownerOfSelector <> labelBytes label) $ Reverts "" + +answerOwner :: Ctx -> Text -> Address -> IO () +answerOwner Ctx {cNode} label owner = answerCall cNode (registrarOf cNode) (ownerOfSelector <> labelBytes label) $ Returns $ addressWord owner + +answerExpiry :: Ctx -> Text -> Word64 -> IO () +answerExpiry Ctx {cNode} label expiry = answerCall cNode (registrarOf cNode) (nameExpiresSelector <> labelBytes label) $ Returns $ uint256 expiry + +-- | A register transaction of the order as the sender saves it, then moved to this outcome. +sentRegister :: Ctx -> NameRegistration -> Word8 -> TxStatus -> IO TxHash +sentRegister Ctx {cStore} NameRegistration {nrId} n status = withTransaction cStore $ \db -> do + let h = TxHash $ digestFixture n + void $ insertTransaction db (TxRegister nrId) NewTransaction {ntxRaw = "raw", ntxHash = h, ntxNonce = fromIntegral n} orderTime + recordTransactionOutcome db h TSPending status (Just 120) `shouldReturn` True + pure h + +-- | The chain answers the name as available and held by nobody. answerFree :: Ctx -> Text -> IO () -answerFree ctx label = answerReserved ctx label 0 +answerFree ctx label = answerReserved ctx label 0 >> answerUnowned ctx label answerReserved :: Ctx -> Text -> Int -> IO () answerReserved Ctx {cNode} label reason = do @@ -313,6 +341,7 @@ testFind = withOwner $ \ctx@Ctx {cStore} -> do let new = NewRegistration {nrgId = oldOrder i, nrgOwner = ownerA, nrgOrder = order ("alicebakery" <> tshow i) (fromIntegral i), nrgYears = 2} withTransaction cStore (\db -> createCodeRegistration db new code (addUTCTime (fromIntegral i) t0)) `shouldReturn` Right () answerFree ctx "alicebakers" + answerUnowned ctx "alicebakery50" movedOrder <- registrationById ctx (oldOrder 50) >>= \r -> rewrite ctx r failedPhase to <- moveTo ctx "alicebakers" 10 void $ moved ctx keyA movedOrder to @@ -478,6 +507,41 @@ testMoveOrderChecks = withOwner $ \ctx@Ctx {cNode} -> do move ctx keyA r to `shouldReturn` refusedWith 503 "name_check_unavailable" stored ctx r `shouldReturn` r +testMoveLanded :: IO () +testMoveLanded = withOwner $ \ctx -> do + answerFree ctx "alicebakers" + minedOrder <- paidIn ctx aliceOrder failedPhase + (ownedOrder, code) <- codeIn ctx 7 dynamisOrder failedPhase + notLanded <- paidIn ctx (byB aliceOrder) {oCommitment = commitmentOf 2} failedPhase + let expiry = seconds orderTime + 2 * 31536000 + forM_ ["alicebakery", "dynamis"] $ \label -> answerExpiry ctx label expiry + TxHash minedHash <- sentRegister ctx minedOrder 1 TSMined + answerOwner ctx "dynamis" (nrOwner ownedOrder) + void $ sentRegister ctx notLanded 2 TSReverted + answerOwner ctx "alicebakery" (nrOwner minedOrder) + forM_ [(minedOrder, Just minedHash), (ownedOrder, Nothing)] $ \(r, hash) -> do + to <- moveTo ctx "alicebakers" 10 + answer <- move ctx keyA r to + view <- getView ctx r + answer `shouldBe` refusedWithView "registration_changed" view + fieldsIn view [("phase", "registered"), ("expiresAt", J.toJSON expiry), ("moves", J.Number 0), ("error", J.Null), ("registerTx", maybe J.Null (J.String . hex) hash)] + written <- stored ctx r + (nrPhase written, nrLive written, nrVersion written, nrLabelHash written) `shouldBe` (PRegistered, False, nrVersion r + 1, nrLabelHash r) + pcSpentAt <$> codeRow ctx code `shouldReturn` Just orderTime + to <- moveTo ctx "alicebakers" 11 + v <- moved ctx keyB notLanded to + fieldsIn v [("phase", "queued"), ("moves", J.Number 1)] + +testMoveLandedUnread :: IO () +testMoveLandedUnread = withOwner $ \ctx@Ctx {cNode} -> do + answerFree ctx "alicebakers" + 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" + to <- moveTo ctx "alicebakers" 10 + move ctx keyA r to `shouldReturn` refusedWith 503 "name_check_unavailable" + stored ctx r `shouldReturn` r + testMovePrice :: IO () testMovePrice = withOwner $ \ctx -> do answerFree ctx "alicebakers" From 4d5e50aa8a99c27db219bc5ca3de2ef334b17391 Mon Sep 17 00:00:00 2001 From: shum Date: Thu, 22 Oct 2026 05:39:54 +0000 Subject: [PATCH 4/7] store: widen the lost-race test windows --- tests/Bots/StoreService/NamesOwnerTests.hs | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/tests/Bots/StoreService/NamesOwnerTests.hs b/tests/Bots/StoreService/NamesOwnerTests.hs index f59a6adb2c..fdee8ebf4e 100644 --- a/tests/Bots/StoreService/NamesOwnerTests.hs +++ b/tests/Bots/StoreService/NamesOwnerTests.hs @@ -330,7 +330,11 @@ parkDelay = 200000 -- | Each eth_call's delay in the lost-race tests, far longer than a request takes to read its registration. slowRead :: Int -slowRead = 1000000 +slowRead = 3000000 + +-- | How long after the turns are held the lost-race tests change the order: past the request's read, before its write. +raceDelay :: Int +raceDelay = 1000000 -- tests @@ -634,7 +638,7 @@ testMoveLostRace = withOwner $ \ctx@Ctx {cNode} -> do setFault cNode "eth_call" (Slow slowRead) moving <- async $ move ctx keyA r to awaitTurns ctx 2 - threadDelay (slowRead `div` 5) + threadDelay raceDelay changed <- rewrite ctx r id clearFault cNode "eth_call" answer <- within "the move" $ wait moving @@ -776,7 +780,7 @@ testCodeLostRace = withOwner $ \ctx@Ctx {cNode, cStore} -> do setFault cNode "eth_call" (Slow slowRead) issuing <- async $ takeCode ctx keyA r hashText 8 awaitTurns ctx 1 - threadDelay (slowRead `div` 5) + threadDelay raceDelay changed <- rewrite ctx r id clearFault cNode "eth_call" answer <- within "the code" $ wait issuing From 4b3631a623271acd5892cba67d95d4784e2fd948 Mon Sep 17 00:00:00 2001 From: shum Date: Thu, 22 Oct 2026 05:50:58 +0000 Subject: [PATCH 5/7] store: spend a landed order's released code --- .../src/StoreService/Names/Codes.hs | 8 ++++- .../src/StoreService/Names/Orders.hs | 18 +++++++--- .../src/StoreService/Names/Store.hs | 16 +++++++++ tests/Bots/StoreService/NamesOwnerTests.hs | 33 ++++++++++++++++++- 4 files changed, 68 insertions(+), 7 deletions(-) diff --git a/apps/simplex-store-service/src/StoreService/Names/Codes.hs b/apps/simplex-store-service/src/StoreService/Names/Codes.hs index 5b0d44c03d..deca04c756 100644 --- a/apps/simplex-store-service/src/StoreService/Names/Codes.hs +++ b/apps/simplex-store-service/src/StoreService/Names/Codes.hs @@ -15,6 +15,7 @@ module StoreService.Names.Codes reserveCode, releaseCode, spendCode, + spendLandedCode, issueNameCode, revokeNameCode, ) @@ -37,7 +38,7 @@ import qualified Simplex.Messaging.Agent.Store.DB as DB import StoreService.Config (minNameYears) import StoreService.Group.Command (maxNameYears) import StoreService.Names.Phases (RegistrationId) -import StoreService.Names.Store (CodeHashTaken (..), NewPrepaidCode (..), PrepaidCode (..), getPrepaidCode, getPrepaidCodeById, insertPrepaidCode, releasePrepaidCode, reservePrepaidCode, revokePrepaidCode, spendPrepaidCode) +import StoreService.Names.Store (CodeHashTaken (..), NewPrepaidCode (..), PrepaidCode (..), getPrepaidCode, getPrepaidCodeById, insertPrepaidCode, releasePrepaidCode, reservePrepaidCode, revokePrepaidCode, spendLandedPrepaidCode, spendPrepaidCode) import StoreService.Names.Turns (Turns, withCodeTurn) import StoreService.Store (RevokeResult (..)) @@ -137,6 +138,11 @@ releaseCode turns st codeId rid = afterWrite turns st codeId (\db -> releasePrep spendCode :: Turns -> DBStore -> UTCTime -> Int64 -> RegistrationId -> (DB.Connection -> IO (Either e a)) -> IO (Either e (a, Bool)) spendCode turns st now codeId rid = afterWrite turns st codeId (\db -> spendPrepaidCode db codeId rid now) +-- | As spendCode, for a registration whose register went through: a code it no longer holds is spent too while still usable. +-- False when the code was released and then spent, revoked or expired meanwhile. +spendLandedCode :: Turns -> DBStore -> UTCTime -> Int64 -> RegistrationId -> (DB.Connection -> IO (Either e a)) -> IO (Either e (a, Bool)) +spendLandedCode turns st now codeId rid = afterWrite turns st codeId (\db -> spendLandedPrepaidCode db codeId rid now) + afterWrite :: Turns -> DBStore -> Int64 -> (DB.Connection -> IO Bool) -> (DB.Connection -> IO (Either e a)) -> IO (Either e (a, Bool)) afterWrite turns st codeId change write = do codeHash_ <- withTransaction st $ \db -> fmap pcCodeHash <$> getPrepaidCodeById db codeId diff --git a/apps/simplex-store-service/src/StoreService/Names/Orders.hs b/apps/simplex-store-service/src/StoreService/Names/Orders.hs index 2a88707c8f..ce50d1c0df 100644 --- a/apps/simplex-store-service/src/StoreService/Names/Orders.hs +++ b/apps/simplex-store-service/src/StoreService/Names/Orders.hs @@ -68,12 +68,12 @@ import Simplex.Messaging.Eth.Address (Address, recoverAddress) import Simplex.Messaging.SimplexName (LabelHash (..)) import Simplex.Messaging.Util (tshow) import StoreService.Config (NamesConfig (..)) -import StoreService.Log (logWarn) -import StoreService.Names.Codes (CodeRefusal (..), codeRefusal, reserveCode, reserveRefusal, spendCode) +import StoreService.Log (logError, logWarn) +import StoreService.Names.Codes (CodeRefusal (..), codeRefusal, reserveCode, reserveRefusal, spendLandedCode) import StoreService.Names.Contracts (Contracts, NameStatus (..), chainPriceCents, codeLengthFor, nameExpires, nameStatus, ownerOfToken, secondsPerYear) import StoreService.Names.Env (NamesEnv (..)) -import StoreService.Names.Phases (Phases, RegistrationId) -import StoreService.Names.Abi (bytes32FromHex) +import StoreService.Names.Phases (Phases, RegistrationId (..)) +import StoreService.Names.Abi (bytes32FromHex, hex) import StoreService.Names.Signatures (OrderFields (..), orderMessage, parseChecksumAddress, parseSignature, personalDigest) import StoreService.Names.Store (CodeHashTaken, LiveOrder (..), NamePhase (..), NameRegistration (..), NewPrepaidCode (..), NewRegistration (..), PrepaidCode (..), RegistrationPayment (..), RegistrationRefused (..), NameTransaction (..), TxFor (..), TxStatus (..), VersionWrite (..), closeOverdue, createCodeRegistration, getLiveOrders, getPrepaidCode, getPrepaidCodeById, getRegistrationByOrderHash, insertPrepaidCode, isLabelRegistering, registrationTransactions, retargetRegistration, setIssuedCode, updateRegistration) import StoreService.Names.Turns (Turns, withCodeTurn) @@ -360,7 +360,15 @@ confirmLanded OrdersEnv {oeStore, oeContracts, oeTurns, oeNow} r@NameRegistratio write db = versionWritten <$> updateRegistration db registered now case nrPayment of RPInvoice {} -> withTransaction oeStore write - RPCode codeId -> fmap fst <$> spendCode oeTurns oeStore now codeId nrId write + RPCode codeId -> spendLandedCode oeTurns oeStore now codeId nrId write >>= traverse (paidWith codeId) + paidWith codeId (v, spent) = do + unless spent $ do + code <- withTransaction oeStore (`getPrepaidCodeById` codeId) + logError $ + "names: registration " <> ridText nrId <> " turned out registered with prepaid code " <> maybe (tshow codeId) (hex . pcCodeHash) code + <> ", which was released and then spent, revoked or expired: the name was paid with it" + pure v + ridText (RegistrationId t) = t -- | The hash of the code a taken order was turned into. issuedCodeHash :: DBStore -> NameRegistration -> IO (Maybe ByteString) diff --git a/apps/simplex-store-service/src/StoreService/Names/Store.hs b/apps/simplex-store-service/src/StoreService/Names/Store.hs index 68e394b418..5b9fd50282 100644 --- a/apps/simplex-store-service/src/StoreService/Names/Store.hs +++ b/apps/simplex-store-service/src/StoreService/Names/Store.hs @@ -54,6 +54,7 @@ module StoreService.Names.Store reservePrepaidCode, releasePrepaidCode, spendPrepaidCode, + spendLandedPrepaidCode, revokePrepaidCode, insertTransaction, recordTransactionOutcome, @@ -761,6 +762,21 @@ spendPrepaidCode db codeId (RegistrationId rid) now = "UPDATE sx_badge_service_name_prepaid_codes SET spent_at = ? WHERE name_prepaid_code_id = ? AND reserved_by = ? AND spent_at IS NULL" (truncateToSecond now, codeId, rid) +-- | For a registration whose register went through: spends the code it holds, or one released and still usable; False otherwise. +spendLandedPrepaidCode :: DB.Connection -> Int64 -> RegistrationId -> UTCTime -> IO Bool +spendLandedPrepaidCode db codeId (RegistrationId rid) now' = + (> 0) + <$> executeChanging + db + [sql| + UPDATE sx_badge_service_name_prepaid_codes SET reserved_by = ?, reserved_at = COALESCE(reserved_at, ?), spent_at = ? + WHERE name_prepaid_code_id = ? AND spent_at IS NULL + AND (reserved_by = ? OR (reserved_by IS NULL AND revoked_at IS NULL AND code_payment_status <> ? AND (expires_at IS NULL OR expires_at > ?))) + |] + (rid, now, now, codeId, rid, CPSUnpaid, now) + where + now = truncateToSecond now' + -- | A reserved code can be revoked, and its order keeps it; a spent one cannot. revokePrepaidCode :: DB.Connection -> ByteString -> UTCTime -> IO RevokeResult revokePrepaidCode db codeHash now = do diff --git a/tests/Bots/StoreService/NamesOwnerTests.hs b/tests/Bots/StoreService/NamesOwnerTests.hs index fdee8ebf4e..87a87d1e85 100644 --- a/tests/Bots/StoreService/NamesOwnerTests.hs +++ b/tests/Bots/StoreService/NamesOwnerTests.hs @@ -9,7 +9,7 @@ import Bots.StoreService.FakeEthNode import Bots.StoreService.NamesContractsTests (launchPricesAnswer, oracle, pricesAnswer, pricesCall, registrarOf, rentPriceAnswer, rentPriceCall, unhex) import Bots.StoreService.NamesOrdersTests import Bots.StoreService.NamesStoreTests (order, ownerA, t0) -import Bots.StoreService.WebTests (digestFixture, jsonObject, statusOf, webGet) +import Bots.StoreService.WebTests (capturingStderr, digestFixture, jsonObject, statusOf, webGet) import Control.Applicative ((<|>)) import Control.Arrow ((&&&)) import Control.Concurrent (threadDelay) @@ -74,6 +74,7 @@ namesOwnerTests = describe "StoreService names: owner" $ do it "runs the order checks on the new fields: invalid_name, the duration, name_taken, name_check_unavailable" testMoveOrderChecks it "registers a failed order whose register went through, by its mined register or by ownerOf, answering registration_changed and spending a code" testMoveLanded it "answers name_check_unavailable when the register check cannot read the chain, changing nothing" testMoveLandedUnread + it "spends a released code still unused when its failed order turns out registered, and alerts once when it was spent elsewhere meanwhile" testMoveLandedReleasedCode it "answers a dearer name price_too_high with its price, and moves to a cheaper one at its price" testMovePrice it "checks a code order's code again: code_not_covering for a shorter name, a held code kept though revoked and expired since" testMoveCodeOrder it "reserves a released code again while unused, else answers code_used, code_reserved, code_invalid or code_expired" testMoveReleasedCode @@ -536,6 +537,36 @@ testMoveLanded = withOwner $ \ctx -> do v <- moved ctx keyB notLanded to fieldsIn v [("phase", "queued"), ("moves", J.Number 1)] +testMoveLandedReleasedCode :: IO () +testMoveLandedReleasedCode = withOwner $ \ctx@Ctx {cStore} -> do + answerFree ctx "alicebakers" + spender <- paidIn ctx (byB aliceOrder) {oCommitment = commitmentOf 20} id + (unused, unusedCode) <- codeIn ctx 7 dynamisOrder failedPhase + (spentElsewhere, spentCode) <- codeIn ctx 8 aliceOrder failedPhase + let expiry = seconds orderTime + 2 * 31536000 + forM_ [("dynamis", unused), ("alicebakery", spentElsewhere)] $ \(label, r) -> do + answerExpiry ctx label expiry + answerOwner ctx label (nrOwner r) + forM_ [(unused, unusedCode), (spentElsewhere, spentCode)] $ \(r, code) -> + withTransaction cStore (\db -> releasePrepaidCode db (pcId code) (nrId r)) `shouldReturn` True + withTransaction cStore $ \db -> do + reservePrepaidCode db (pcId spentCode) (nrId spender) orderTime `shouldReturn` True + spendPrepaidCode db (pcId spentCode) (nrId spender) orderTime `shouldReturn` True + spenderBefore <- stored ctx spender + spentBefore <- codeRow ctx spentCode + to <- moveTo ctx "alicebakers" 10 + fst <$> move ctx keyA unused to `shouldReturn` 409 + nrPhase <$> stored ctx unused `shouldReturn` PRegistered + (pcReservedBy &&& pcSpentAt) <$> codeRow ctx unusedCode `shouldReturn` (Just (nrId unused), Just orderTime) + to' <- moveTo ctx "alicebakers" 11 + logs <- capturingStderr $ fst <$> move ctx keyA spentElsewhere to' `shouldReturn` 409 + nrPhase <$> stored ctx spentElsewhere `shouldReturn` PRegistered + length (filter (\l -> "[ERROR " `T.isInfixOf` l && hex (pcCodeHash spentCode) `T.isInfixOf` l && idText (nrId spentElsewhere) `T.isInfixOf` l) $ T.lines logs) `shouldBe` 1 + codeRow ctx spentCode `shouldReturn` spentBefore + stored ctx spender `shouldReturn` spenderBefore + where + idText (RegistrationId t) = t + testMoveLandedUnread :: IO () testMoveLandedUnread = withOwner $ \ctx@Ctx {cNode} -> do answerFree ctx "alicebakers" From 73e7ba5bcdf62eea1bca012363712b24e77926c3 Mon Sep 17 00:00:00 2001 From: shum Date: Thu, 22 Oct 2026 05:51:02 +0000 Subject: [PATCH 6/7] store: say who holds the turn for confirmLanded --- apps/simplex-store-service/src/StoreService/Names/Orders.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/apps/simplex-store-service/src/StoreService/Names/Orders.hs b/apps/simplex-store-service/src/StoreService/Names/Orders.hs index ce50d1c0df..5db32c645c 100644 --- a/apps/simplex-store-service/src/StoreService/Names/Orders.hs +++ b/apps/simplex-store-service/src/StoreService/Names/Orders.hs @@ -331,6 +331,7 @@ versionWritten = \case -- | /retry's first check, on the order's current name: a register mined with status 1, or the owner holding the name, went through -- with only its confirmation lost. The order then becomes registered by a compare-and-set on the version read, a code order spending its code. +-- The caller holds the turn of the order's label hash and passes the order as registrationAt reads it. confirmLanded :: OrdersEnv -> NameRegistration -> IO Landing confirmLanded OrdersEnv {oeStore, oeContracts, oeTurns, oeNow} r@NameRegistration {nrId, nrOwner, nrLabelHash, nrPayment, nrRegisterTx, nrRegisterBlock} = do txs <- withTransaction oeStore (`registrationTransactions` nrId) From f05d27633c6eeb5748e86b3182164a6d9c0791fa Mon Sep 17 00:00:00 2001 From: shum Date: Thu, 22 Oct 2026 05:52:38 +0000 Subject: [PATCH 7/7] store: test the poll woken by a landed order --- tests/Bots/StoreService/NamesOwnerTests.hs | 23 +++++++++++++--------- 1 file changed, 14 insertions(+), 9 deletions(-) diff --git a/tests/Bots/StoreService/NamesOwnerTests.hs b/tests/Bots/StoreService/NamesOwnerTests.hs index 87a87d1e85..bae0735c66 100644 --- a/tests/Bots/StoreService/NamesOwnerTests.hs +++ b/tests/Bots/StoreService/NamesOwnerTests.hs @@ -323,7 +323,18 @@ within what action = timeout 10000000 action >>= maybe (error $ what <> " did no awaitTurns :: Ctx -> Int -> IO () awaitTurns Ctx {cOrders} n = within "turns" loop where - loop = turnsCount (oeTurns cOrders) >>= \held -> unless (held >= n) (threadDelay 1000 >> loop) + loop = turnsCount (oeTurns cOrders) >>= \count -> unless (count >= n) (threadDelay 1000 >> loop) + +-- | A registration poll at the order's version, once the server holds it. +held :: Ctx -> NameRegistration -> IO (Async (Int, J.Object)) +held ctx@Ctx {cOrders} NameRegistration {nrId, nrVersion} = do + waiting <- atomically $ phasesWaiting (oePhases cOrders) + poll <- async $ webGet (cClient ctx) (registrationPath nrId <> "?seenVersion=" <> show nrVersion) >>= \resp -> (statusOf resp,) <$> jsonObject resp + within "the hold" $ atomically $ phasesWaiting (oePhases cOrders) >>= check . (> waiting) + pure poll + +woken :: Async (Int, J.Object) -> IO (Int, J.Object) +woken poll = timeout 5000000 (wait poll) >>= maybe (cancel poll >> error "the poll was not woken") pure -- | Long enough for a request just sent to reach its turns. parkDelay :: Int @@ -525,10 +536,12 @@ testMoveLanded = withOwner $ \ctx -> do void $ sentRegister ctx notLanded 2 TSReverted answerOwner ctx "alicebakery" (nrOwner minedOrder) forM_ [(minedOrder, Just minedHash), (ownedOrder, Nothing)] $ \(r, hash) -> do + poll <- held ctx r to <- moveTo ctx "alicebakers" 10 answer <- move ctx keyA r to view <- getView ctx r answer `shouldBe` refusedWithView "registration_changed" view + woken poll `shouldReturn` (200, view) fieldsIn view [("phase", "registered"), ("expiresAt", J.toJSON expiry), ("moves", J.Number 0), ("error", J.Null), ("registerTx", maybe J.Null (J.String . hex) hash)] written <- stored ctx r (nrPhase written, nrLive written, nrVersion written, nrLabelHash written) `shouldBe` (PRegistered, False, nrVersion r + 1, nrLabelHash r) @@ -834,11 +847,3 @@ testPollsWoken = withOwner $ \ctx -> do takeCode ctx keyA t (fst $ takenCodeHash 1) 8 `shouldReturn` (200, answered) (status', v') <- woken poll' (status', field "version" v', field "phase" v') `shouldBe` (200, Just (J.toJSON $ nrVersion t + 1), Just "code_issued") - where - held ctx'@Ctx {cOrders} NameRegistration {nrId, nrVersion} = do - waiting <- atomically $ phasesWaiting (oePhases cOrders) - poll <- async $ webGet (cClient ctx') (registrationPath nrId <> "?seenVersion=" <> show nrVersion) >>= \resp -> (statusOf resp,) <$> jsonObject resp - within "the hold" $ atomically $ phasesWaiting (oePhases cOrders) >>= check . (> waiting) - pure poll - woken :: Async (Int, J.Object) -> IO (Int, J.Object) - woken poll = timeout 5000000 (wait poll) >>= maybe (cancel poll >> error "the poll was not woken") pure