From 1dbccd8be16a299f09c52fdbfb73e7871544b036 Mon Sep 17 00:00:00 2001 From: shum Date: Thu, 22 Oct 2026 03:42:36 +0000 Subject: [PATCH 1/7] store: one addressText for the names views --- apps/simplex-store-service/src/StoreService/Names/View.hs | 2 +- .../src/StoreService/Web/Names/Search.hs | 8 +------- 2 files changed, 2 insertions(+), 8 deletions(-) diff --git a/apps/simplex-store-service/src/StoreService/Names/View.hs b/apps/simplex-store-service/src/StoreService/Names/View.hs index c67f5c6b1c..96de0f3847 100644 --- a/apps/simplex-store-service/src/StoreService/Names/View.hs +++ b/apps/simplex-store-service/src/StoreService/Names/View.hs @@ -2,7 +2,7 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} -module StoreService.Names.View (ViewReads (..), registrationView, readViewChain, viewJSON, tldText) where +module StoreService.Names.View (ViewReads (..), registrationView, readViewChain, viewJSON, addressText, tldText) where import Data.Aeson ((.=)) import qualified Data.Aeson as J diff --git a/apps/simplex-store-service/src/StoreService/Web/Names/Search.hs b/apps/simplex-store-service/src/StoreService/Web/Names/Search.hs index 35bf4d1555..4ab8d095c5 100644 --- a/apps/simplex-store-service/src/StoreService/Web/Names/Search.hs +++ b/apps/simplex-store-service/src/StoreService/Web/Names/Search.hs @@ -16,14 +16,11 @@ import qualified Data.ByteString.Char8 as B import Data.Char (isDigit) import Data.Text (Text) import qualified Data.Text as T -import Data.Text.Encoding (decodeLatin1) import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds) import Network.HTTP.Types (status200) import Network.Wai (Request, Response, ResponseReceived, queryString) import Simplex.Chat.Badges.Code (maxNameLength, minNameLength) import Simplex.Messaging.Agent.Store.Common (DBStore, withTransaction) -import Simplex.Messaging.Encoding.String (strEncode) -import Simplex.Messaging.Eth.Address (Address) import Simplex.Messaging.SimplexName (LabelHash (..)) import Simplex.Messaging.Util (tshow) import StoreService.Config (ChainConfig (..), NamesConfig (..)) @@ -33,7 +30,7 @@ import StoreService.Names.Contracts import StoreService.Names.Links (LinkKind (..), linkKindOf) import StoreService.Names.Profiles (Entity, Profiles, linkEntity, linkPreview) import StoreService.Names.Store (isLabelRegistering) -import StoreService.Names.View (tldText) +import StoreService.Names.View (addressText, tldText) import StoreService.Web.Http (Respond, badRequest, invalidLink, invalidName, jsonResponse, maxBodyBytes, providerUnavailable, readBoundedBody) import System.Timeout (timeout) import Text.Read (readMaybe) @@ -125,6 +122,3 @@ previewHandler ps req respond = Just (J.String link) | Just kind <- linkKindOf link -> respond . jsonResponse status200 . J.toJSON =<< linkPreview ps kind link _ -> respond invalidLink _ -> respond badRequest - -addressText :: Address -> Text -addressText = decodeLatin1 . strEncode From 7e2e860b0722dbfef8c005cfd36158c353931629 Mon Sep 17 00:00:00 2001 From: shum Date: Thu, 22 Oct 2026 03:58:49 +0000 Subject: [PATCH 2/7] store: reuse the code's reservation refusal --- apps/simplex-store-service/src/StoreService/Names/Codes.hs | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/apps/simplex-store-service/src/StoreService/Names/Codes.hs b/apps/simplex-store-service/src/StoreService/Names/Codes.hs index d94458a7dc..5709fc1fc9 100644 --- a/apps/simplex-store-service/src/StoreService/Names/Codes.hs +++ b/apps/simplex-store-service/src/StoreService/Names/Codes.hs @@ -10,6 +10,7 @@ module StoreService.Names.Codes CodeRefusal (..), codeRefusal, codeRefusalTag, + reserveRefusal, readPrepaidCode, reserveCode, releaseCode, @@ -94,6 +95,10 @@ stateRefusal = \case CSExpired -> Just CRExpired CSUnpaid -> Just CRPaymentPending +-- | Why a conditional reservation of the code refused it, as the code reads now. +reserveRefusal :: DB.Connection -> UTCTime -> ByteString -> RegistrationId -> Int -> IO CodeRefusal +reserveRefusal db now codeHash rid len = maybe CRInvalid (fromMaybe CRReserved . codeRefusal now rid len) <$> getPrepaidCode db codeHash + readPrepaidCode :: DBStore -> NamePrepaidCode -> IO (Maybe PrepaidCode) readPrepaidCode st code = withTransaction st (`getPrepaidCode` namePrepaidCodeHash code) @@ -110,7 +115,7 @@ reserveCode turns st now codeHash rid len write = | otherwise -> reservePrepaidCode db pcId rid now >>= \case -- Only a writer outside this process, which takes no turn here, can refuse it. - False -> Left . maybe CRInvalid (fromMaybe CRReserved . codeRefusal now rid len) <$> getPrepaidCode db codeHash + False -> Left <$> reserveRefusal db now codeHash rid len True -> write db >>= \case refused@(Left _) -> Right refused <$ releasePrepaidCode db pcId rid From 74947310098bc380a7c82803b6b5aaaa1170a734 Mon Sep 17 00:00:00 2001 From: shum Date: Thu, 22 Oct 2026 03:58:50 +0000 Subject: [PATCH 3/7] store: take name orders paid with a prepaid code --- .../src/StoreService/Names/Env.hs | 12 +- .../src/StoreService/Names/Orders.hs | 35 ++- .../src/StoreService/Service.hs | 9 +- .../src/StoreService/Web/Names.hs | 5 +- .../src/StoreService/Web/Names/Orders.hs | 98 ++++-- .../StoreService/GroupIntegrationTests.hs | 2 + tests/Bots/StoreService/NamesOrdersTests.hs | 278 +++++++++++++++++- 7 files changed, 400 insertions(+), 39 deletions(-) diff --git a/apps/simplex-store-service/src/StoreService/Names/Env.hs b/apps/simplex-store-service/src/StoreService/Names/Env.hs index d437096018..9229e9e2ba 100644 --- a/apps/simplex-store-service/src/StoreService/Names/Env.hs +++ b/apps/simplex-store-service/src/StoreService/Names/Env.hs @@ -14,6 +14,8 @@ import StoreService.Names.Profiles (Profiles, chatProfile, defaultProfileLimits, import StoreService.Names.Records (Records, newRecords) import StoreService.Names.Sender (Sender, newSender) import StoreService.Names.Turns (Turns) +import StoreService.Providers (Provider) +import StoreService.Waiters (Waiters) data NamesEnv = NamesEnv { neChat :: ChatController, @@ -26,15 +28,17 @@ data NamesEnv = NamesEnv neContracts :: Contracts, neProfiles :: Profiles, neSender :: Sender, - neRecords :: Records + neRecords :: Records, + neWaiters :: Waiters, + neProviders :: [Provider] } -newNamesEnv :: ChatController -> UserId -> NamesConfig -> DBStore -> Turns -> IO NamesEnv -newNamesEnv neChat@ChatController {random} neUserId neConfig@NamesConfig {nTLD, nChain} neStore neTurns = do +newNamesEnv :: ChatController -> UserId -> NamesConfig -> DBStore -> Turns -> Waiters -> [Provider] -> IO NamesEnv +newNamesEnv neChat@ChatController {random} neUserId neConfig@NamesConfig {nTLD, nChain} neStore neTurns neWaiters neProviders = do nePhases <- newPhases neChain <- newChainClient random nChain neContracts <- newContracts nTLD neChain neProfiles <- newProfiles defaultProfileLimits monotonicSeconds (chatProfile neChat neUserId) systemResolver neSender <- newSender random neChain neStore getCurrentTime neRecords <- newRecords neStore neTurns neContracts neChain neSender nTLD getCurrentTime - pure NamesEnv {neChat, neUserId, neConfig, neStore, nePhases, neTurns, neChain, neContracts, neProfiles, neSender, neRecords} + pure NamesEnv {neChat, neUserId, neConfig, neStore, nePhases, neTurns, neChain, neContracts, neProfiles, neSender, neRecords, neWaiters, neProviders} diff --git a/apps/simplex-store-service/src/StoreService/Names/Orders.hs b/apps/simplex-store-service/src/StoreService/Names/Orders.hs index 1f28acf81d..e048fbba43 100644 --- a/apps/simplex-store-service/src/StoreService/Names/Orders.hs +++ b/apps/simplex-store-service/src/StoreService/Names/Orders.hs @@ -18,6 +18,8 @@ module StoreService.Names.Orders checkOrderSigner, existingOrder, placeOrder, + placeCodeOrder, + codeOrderInsert, checkTimestamp, checkDuration, checkNameFree, @@ -46,13 +48,14 @@ 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.Env (NamesEnv (..)) -import StoreService.Names.Phases (Phases) +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 (..), RegistrationRefused (..), closeOverdue, getLiveOrders, getRegistrationByOrderHash, isLabelRegistering) -import StoreService.Names.Turns (Turns) +import StoreService.Names.Store (LiveOrder (..), NameRegistration (..), NewRegistration (..), PrepaidCode (..), RegistrationRefused (..), closeOverdue, createCodeRegistration, getLiveOrders, getPrepaidCode, getRegistrationByOrderHash, isLabelRegistering) +import StoreService.Names.Turns (Turns, withCodeTurn) data OrdersEnv = OrdersEnv { oeStore :: DBStore, @@ -82,6 +85,7 @@ data OrderRefusal | ORNameTaken | ORNameCheckUnavailable | ORCatalogChanged Int + | ORCode CodeRefusal deriving (Eq, Show) newtype OrderRefused = OrderRefused OrderRefusal @@ -153,8 +157,8 @@ overdueOrdersMet db OrderRequest {orOwner, orFields = OrderFields {ofLabelHash, loOverdue && nrOwner == orOwner && nrLabelHash == ofLabelHash -- | In one transaction, the overdue orders the request meets are closed, then the order is inserted. --- Refused, changing nothing, when it meets an order it cannot close, or the insert meets one. -placeOrder :: OrdersEnv -> OrderRequest -> (DB.Connection -> UTCTime -> IO (Either RegistrationRefused ())) -> IO (Either OrderRefusal [ClosedOrder]) +-- Refused, changing nothing, when it meets an order it cannot close, or the insert refuses. +placeOrder :: OrdersEnv -> OrderRequest -> (DB.Connection -> UTCTime -> IO (Either OrderRefusal ())) -> IO (Either OrderRefusal [ClosedOrder]) placeOrder OrdersEnv {oeStore, oeNow} req insert = do now <- oeNow first (\(OrderRefused refusal) -> refusal) <$> E.try (withTransaction oeStore $ \db -> transaction db now) @@ -163,13 +167,32 @@ placeOrder OrdersEnv {oeStore, oeNow} req insert = do overdueOrdersMet db req now >>= \case Just overdue -> do closed <- mapM (close db now) overdue - insert db now >>= either (const $ E.throwIO $ OrderRefused OROrderExists) (const $ pure closed) + insert db now >>= either (E.throwIO . OrderRefused) (const $ pure closed) Nothing -> E.throwIO $ OrderRefused OROrderExists close db now r = closeOverdue db r now >>= \case Just v -> pure ClosedOrder {coRegistration = r, coVersion = v} Nothing -> E.throwIO $ OrderRefused OROrderExists +-- | In the code's turn, the code as it reads there must pay for the name; the order's insert then reserves it. +placeCodeOrder :: OrdersEnv -> OrderRequest -> RegistrationId -> PrepaidCode -> IO (Either OrderRefusal [ClosedOrder]) +placeCodeOrder env@OrdersEnv {oeStore, oeTurns, oeNow} req@OrderRequest {orOwner, orFields = fields@OrderFields {ofLength}} rid PrepaidCode {pcCodeHash, pcYears} = + withCodeTurn oeTurns pcCodeHash $ do + now <- oeNow + withTransaction oeStore (`getPrepaidCode` pcCodeHash) >>= \case + Nothing -> pure $ Left $ ORCode CRInvalid + Just code + | Just refusal <- codeRefusal now rid ofLength code -> pure $ Left $ ORCode refusal + | otherwise -> placeOrder env req $ codeOrderInsert NewRegistration {nrgId = rid, nrgOwner = orOwner, nrgOrder = fields, nrgYears = pcYears} code + +-- | The code was checked in its turn, so only a writer outside this process can make its reservation fail. +codeOrderInsert :: NewRegistration -> PrepaidCode -> DB.Connection -> UTCTime -> IO (Either OrderRefusal ()) +codeOrderInsert new@NewRegistration {nrgId, nrgOrder = OrderFields {ofLength}} code@PrepaidCode {pcCodeHash} db now = + createCodeRegistration db new code now >>= \case + Right () -> pure $ Right () + Left RRLiveOrder -> pure $ Left OROrderExists + Left RRCodeNotReservable -> Left . ORCode <$> reserveRefusal db now pcCodeHash nrgId ofLength + checkTimestamp :: UTCTime -> Word64 -> Either OrderRefusal () checkTimestamp now timestamp = unless (abs (toInteger timestamp - unixSeconds now) <= signedRequestSeconds) $ Left ORBadRequest diff --git a/apps/simplex-store-service/src/StoreService/Service.hs b/apps/simplex-store-service/src/StoreService/Service.hs index c50e57938e..4156858cd4 100644 --- a/apps/simplex-store-service/src/StoreService/Service.hs +++ b/apps/simplex-store-service/src/StoreService/Service.hs @@ -30,6 +30,7 @@ import StoreService.Names.Sender (runSender) import StoreService.Names.Turns (Turns, newTurns) import StoreService.Options import StoreService.Poller (newPollerEnv, newReadHints, runPoller) +import StoreService.Providers (Provider) import StoreService.Providers.BTCPay (btcpayProvider) import StoreService.Providers.Stripe (stripeProvider) import StoreService.Store @@ -165,19 +166,19 @@ storeService opts@StoreServiceOpts {serviceConfigFile} cfg env = do str <- maybe (pure []) (fmap (: []) . stripeProvider) (stripe sc) let providers = btc <> str hints <- newReadHints - namesEnv <- forM (names sc) (startNames cc turns) + namesEnv <- forM (names sc) (startNames cc turns ws providers) webEnv <- newWebEnv chatStore sc ws hints providers namesEnv exportWebapp (listener sc) (stripe sc) pollerEnv <- newPollerEnv chatStore ws (nePhases <$> namesEnv) hints providers (poll sc) pure $ [runWebListener webEnv, runPoller pollerEnv] <> maybe [] (\ne -> [runSender (neSender ne), runRecordEdits (neRecords ne)]) namesEnv -startNames :: ChatController -> Turns -> NamesConfig -> IO NamesEnv -startNames cc@ChatController {chatStore} turns nc@NamesConfig {nTLD, nChain = ChainConfig {cChainId}} = +startNames :: ChatController -> Turns -> Waiters -> [Provider] -> NamesConfig -> IO NamesEnv +startNames cc@ChatController {chatStore} turns waiters providers nc@NamesConfig {nTLD, nChain = ChainConfig {cChainId}} = readTVarIO (currentUser cc) >>= \case Nothing -> putStrLn "No current user" >> exitFailure Just User {userId} -> do logInfo $ "names: on, TLD " <> safeDecodeUtf8 (strEncode nTLD) <> ", chain " <> tshow cChainId - newNamesEnv cc userId nc chatStore turns + newNamesEnv cc userId nc chatStore turns waiters providers seedServiceCatalog :: DBStore -> IO () seedServiceCatalog st = do diff --git a/apps/simplex-store-service/src/StoreService/Web/Names.hs b/apps/simplex-store-service/src/StoreService/Web/Names.hs index 99eba6a6ba..5af0e41715 100644 --- a/apps/simplex-store-service/src/StoreService/Web/Names.hs +++ b/apps/simplex-store-service/src/StoreService/Web/Names.hs @@ -8,8 +8,10 @@ import Data.Text (Text) 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, limited, only, previewLimit, recordsLimit, searchLimit) import StoreService.Web.Names.Codes (codeCheckHandler) +import StoreService.Web.Names.Orders (codeOrderHandler) import StoreService.Web.Names.Records (recordsHandler) import StoreService.Web.Names.Search (previewHandler, searchHandler) @@ -20,8 +22,9 @@ data Route = Route } namesRoutes :: NamesEnv -> [Text] -> Maybe Route -namesRoutes NamesEnv {neConfig, neStore, neContracts, neProfiles, neRecords} = \case +namesRoutes env@NamesEnv {neConfig, neStore, neContracts, neProfiles, neRecords, neWaiters, neProviders} = \case ["api", "name", "records"] -> Just Route {rMethod = "POST", rLimit = recordsLimit, rHandler = recordsHandler neRecords} + ["api", "name", "register"] -> Just Route {rMethod = "POST", rLimit = codeLimit, rHandler = codeOrderHandler (ordersEnv env) neProviders neWaiters} ["api", "code", "check"] -> Just Route {rMethod = "POST", rLimit = codeLimit, rHandler = codeCheckHandler neStore} ["api", "link", "preview"] -> Just Route {rMethod = "POST", rLimit = previewLimit, rHandler = previewHandler neProfiles} -- below every fixed /api/name/ route, which it would otherwise 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 f46fa503d2..05cadd6bd2 100644 --- a/apps/simplex-store-service/src/StoreService/Web/Names/Orders.hs +++ b/apps/simplex-store-service/src/StoreService/Web/Names/Orders.hs @@ -2,37 +2,41 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} -module StoreService.Web.Names.Orders (nameInvoiceHandler, nameInvoiceView, orderRefusalResponse, registrationChangedResponse) where +module StoreService.Web.Names.Orders (nameInvoiceHandler, codeOrderHandler, nameInvoiceView, orderRefusalResponse, registrationChangedResponse) where import Control.Concurrent.STM (atomically) import qualified Control.Exception as E import Control.Monad (forM_, unless) import Data.Aeson ((.=)) -import Data.Maybe (isJust) import qualified Data.Aeson as J import qualified Data.Aeson.KeyMap as KM +import Data.Bifunctor (first) +import Data.Maybe (isJust) import Data.Text (Text) import Data.Time.Clock (addUTCTime) import Data.Word (Word32) import Network.HTTP.Types (status200, status409, status503) -import Network.Wai (Response, ResponseReceived) +import Network.Wai (Request, Response, ResponseReceived) +import Simplex.Chat.Badges.Code (NameCode (..), parseNameCode) import Simplex.Chat.PaymentService.Types (CurrencyAmount (..), InvoiceId (..), InvoiceStatus (..), ServicePaymentMethod) import Simplex.Messaging.Agent.Store.Common (withTransaction) import Simplex.Messaging.Util (tshow) import StoreService.Catalog (catalogCurrency) import StoreService.Config (NamesConfig (..), ServiceConfig) import StoreService.Log (logError, logInfo, logWarn) +import StoreService.Names.Codes (CodeRefusal (..), readPrepaidCode) import StoreService.Names.Orders -import StoreService.Names.Phases (RegistrationId) +import StoreService.Names.Phases (RegistrationId (..)) import StoreService.Names.Signatures (OrderFields (..)) -import StoreService.Names.Store (NameRegistration (..), NewRegistration (..), OrderTerms (..), PaidOrder (..), RegistrationPayment (..), createPaidRegistration, getRegistration, newRegistrationId, orderHash, textMethod) +import StoreService.Names.Store (NameRegistration (..), NewRegistration (..), OrderTerms (..), PaidOrder (..), PrepaidCode (..), RegistrationPayment (..), createPaidRegistration, getRegistration, newRegistrationId, orderHash, textMethod) import StoreService.Names.Turns (withLabelTurn) import StoreService.Names.View (registrationView) 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, invoicePairs, invoiceWindow, jsonError, jsonResponse, notFound, providerFor, providerNamed, providerUnavailable) +import StoreService.Web.Http (Respond, badRequest, confirmationsFor, internalError, invalidName, invoicePairs, invoiceWindow, jsonError, jsonResponse, nameBodyBytes, notFound, providerFor, providerNamed, providerUnavailable, readBoundedBody) +import StoreService.Web.Names.Codes (codeRefusalResponse) data InvoiceOrder = InvoiceOrder { ioRequest :: OrderRequest, @@ -103,7 +107,7 @@ nameInvoiceHandler env@OrdersEnv {oeStore, oeTurns, oeNow} cfg providers waiters let invoice = NewNameInvoice {nniInvoiceId = invId, nniProvider = pProvider provider, nniAmount = amount, nniCurrency = catalogCurrency, nniDestination = piDestination, nniExpiresAt = addUTCTime (invoiceWindow cfg ioMethod) now, nniCreatedAt = now} registration = NewRegistration {nrgId = rid, nrgOwner = orOwner, nrgOrder = orFields, nrgYears = nYears $ oeConfig env} paid = PaidOrder {poMethod = ioMethod, poPrice = fromIntegral ioPrice, poInvoiceId = invId, poProviderRef = piProviderRef} - placeOrder env req (\db at -> insertNameInvoice db invoice >> createPaidRegistration db registration paid at) + placeOrder env req (\db at -> insertNameInvoice db invoice >> first (const OROrderExists) <$> createPaidRegistration db registration paid at) `E.catch` strandedBy provider piProviderRef >>= \case Left refusal -> do @@ -111,7 +115,7 @@ nameInvoiceHandler env@OrdersEnv {oeStore, oeTurns, oeNow} cfg providers waiters cancelAtProvider provider piProviderRef refuse refusal Right closed -> do - closedOrders closed + announceClosed env providers waiters closed row_ <- getInvoice oeStore invId registration_ <- withTransaction oeStore (`getRegistration` rid) case (row_, registration_) of @@ -125,22 +129,75 @@ nameInvoiceHandler env@OrdersEnv {oeStore, oeTurns, oeNow} cfg providers waiters cancelAtProvider provider ref E.throwIO e isAsync e = isJust (E.fromException e :: Maybe E.SomeAsyncException) - cancelAtProvider Provider {pCancelInvoice} ref = - pCancelInvoice ref >>= \case - Left (ProviderError e) -> logWarn ("names: cancelling invoice " <> ref <> " at the provider failed: " <> e) - Right () -> pure () - -- The provider's cancel follows the commit, best effort, as the poller's sweep would send it. - closedOrders closed = do - atomically $ forM_ closed $ \ClosedOrder {coRegistration = NameRegistration {nrId, nrPayment}, coVersion} -> do - forM_ (paidInvoice nrPayment) $ \invId -> publish waiters invId ISExpired - publishRegistration (Just $ oePhases env) (nrId, coVersion) - forM_ closed $ \ClosedOrder {coRegistration = NameRegistration {nrPayment}} -> - forM_ (paidInvoice nrPayment) $ \invId -> - getInvoice oeStore invId >>= mapM_ (\InvoiceRow {irProvider, irProviderRef} -> forM_ (providerNamed providers irProvider) $ \p -> unless (expiresItself irProvider) $ cancelAtProvider p irProviderRef) + +-- | POST /api/name/register, an order paid with a prepaid code, in the contract's order of checks. +codeOrderHandler :: OrdersEnv -> [Provider] -> Waiters -> Request -> Respond -> IO ResponseReceived +codeOrderHandler env@OrdersEnv {oeStore, oeConfig, oeContracts, oeTurns, oeNow} providers waiters req respond = + readBoundedBody nameBodyBytes req >>= \case + Just body | Just (J.Object o) <- J.decode body -> either refuse withCode (parseCodeOrder o) + _ -> refuse ORBadRequest + where + refuse refusal = do + logInfo ("POST /api/name/register refused: " <> tshow refusal) + respond $ orderRefusalResponse refusal + withCode (order, codeText) = + issuedCode codeText >>= \case + Nothing -> refuse $ ORCode CRInvalid + Just code -> checkOrderSigner order >>= either refuse (const $ signed order code) + issuedCode t = case parseNameCode t of + Just (NCPrepaid code) -> readPrepaidCode oeStore code + _ -> pure Nothing + signed order@OrderRequest {orOwner, orFields} code@PrepaidCode {pcCodeHash} = withLabelTurn oeTurns (ofLabelHash orFields) $ do + now <- oeNow + withTransaction oeStore (\db -> existingOrder db order (orderHash orOwner orFields (OTCode pcCodeHash)) now) >>= \case + EOResent NameRegistration {nrId} -> answer nrId + EOMeets -> refuse OROrderExists + EONew _ -> newOrder now order code + newOrder now order@OrderRequest {orFields = OrderFields {ofLabelHash, ofDuration}, orTimestamp} code@PrepaidCode {pcYears} = do + let checks = + [ pure $ checkTimestamp now orTimestamp, + pure $ checkDuration oeConfig now pcYears ofDuration, + checkNameFree oeContracts oeStore ofLabelHash + ] + firstRefusal checks >>= \case + Just refusal -> refuse refusal + Nothing -> do + rid <- newRegistrationId + placeCodeOrder env order rid code >>= \case + Left refusal -> refuse refusal + Right closed -> announceClosed env providers waiters closed >> answer rid + answer (RegistrationId rid) = respond $ jsonResponse status200 $ J.object ["registrationId" .= rid] + +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 + +-- | 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. +announceClosed :: OrdersEnv -> [Provider] -> Waiters -> [ClosedOrder] -> IO () +announceClosed OrdersEnv {oeStore, oePhases} providers waiters closed = do + atomically $ forM_ closed $ \ClosedOrder {coRegistration = NameRegistration {nrId, nrPayment}, coVersion} -> do + forM_ (paidInvoice nrPayment) $ \invId -> publish waiters invId ISExpired + publishRegistration (Just oePhases) (nrId, coVersion) + forM_ closed $ \ClosedOrder {coRegistration = NameRegistration {nrPayment}} -> + forM_ (paidInvoice nrPayment) $ \invId -> + getInvoice oeStore invId >>= mapM_ (\InvoiceRow {irProvider, irProviderRef} -> forM_ (providerNamed providers irProvider) $ \p -> unless (expiresItself irProvider) $ cancelAtProvider p irProviderRef) + where paidInvoice = \case RPInvoice _ invId -> Just invId RPCode _ -> Nothing +cancelAtProvider :: Provider -> Text -> IO () +cancelAtProvider Provider {pCancelInvoice} ref = + pCancelInvoice ref >>= \case + Left (ProviderError e) -> logWarn ("names: cancelling invoice " <> ref <> " at the provider failed: " <> e) + Right () -> pure () + invText :: InvoiceId -> Text invText (InvoiceId t) = t @@ -171,3 +228,4 @@ orderRefusalResponse = \case ORNameTaken -> jsonError status409 "name_taken" ORNameCheckUnavailable -> jsonError status503 "name_check_unavailable" ORCatalogChanged price -> jsonResponse status409 $ J.object ["error" .= ("catalog_changed" :: Text), "price" .= price] + ORCode refusal -> codeRefusalResponse refusal diff --git a/tests/Bots/StoreService/GroupIntegrationTests.hs b/tests/Bots/StoreService/GroupIntegrationTests.hs index 708cb52402..753cec1625 100644 --- a/tests/Bots/StoreService/GroupIntegrationTests.hs +++ b/tests/Bots/StoreService/GroupIntegrationTests.hs @@ -150,6 +150,8 @@ testNamesBoot ps = do statusCode . responseStatus <$> httpLbs unknown mgr `shouldReturn` 404 records <- request "/api/name/records" answer records {method = "POST", requestBody = RequestBodyLBS "{}"} `shouldReturn` refused "bad_request" + register <- request "/api/name/register" + answer register {method = "POST", requestBody = RequestBodyLBS "{}"} `shouldReturn` refused "bad_request" search <- request $ "/api/name/" <> T.unpack aliceHex <> "?length=5" answer search `shouldReturn` refused "invalid_name" poll t >>= (`shouldSatisfy` isNothing) diff --git a/tests/Bots/StoreService/NamesOrdersTests.hs b/tests/Bots/StoreService/NamesOrdersTests.hs index 9efac23221..a502b8c587 100644 --- a/tests/Bots/StoreService/NamesOrdersTests.hs +++ b/tests/Bots/StoreService/NamesOrdersTests.hs @@ -27,7 +27,7 @@ import qualified Data.ByteString.Char8 as BC import qualified Data.ByteString.Lazy.Char8 as LB import Data.IORef (IORef, atomicModifyIORef', modifyIORef', newIORef, readIORef, writeIORef) import Data.List (sort) -import Data.Maybe (fromJust, isJust, isNothing) +import Data.Maybe (fromJust, fromMaybe, isJust, isNothing) import Data.Text (Text) import qualified Data.Text as T import Data.Time.Clock (NominalDiffTime, UTCTime, addUTCTime, getCurrentTime) @@ -36,6 +36,8 @@ import Data.Word (Word64) import Network.HTTP.Client (defaultManagerSettings, newManager, responseBody) import Network.HTTP.Types (hContentType) import qualified Network.Wai.Handler.Warp as Warp +import Simplex.Chat.Badges.Code (NameCode (..), formatNameCode, namePrepaidCodeHash, randomNamePrepaidCode) +import Simplex.Chat.Badges.Types (BadgeCodePaymentStatus (..)) import Simplex.Chat.PaymentService.Types (CardProvider (..), CryptoCurrency (..), CurrencyAmount (..), InvoiceId (..), InvoiceStatus (..), PaymentProvider (..), ServicePaymentDestination (..), ServicePaymentMethod (..)) import Simplex.Messaging.Agent.Store.Common (DBStore, withConnection, withTransaction) import qualified Simplex.Messaging.Agent.Store.DB as DB @@ -50,7 +52,9 @@ import StoreService.Config (ChainConfig (..), NamesConfig (..), ServiceConfig (. import StoreService.Names.Abi (addressWord, hex, uint256) import StoreService.Names.Chain (newChainClient) import StoreService.Names.Contracts (newContracts) +import StoreService.Names.Codes (CodeRefusal (..)) import StoreService.Names.Orders (OrdersEnv (..)) +import qualified StoreService.Names.Orders as Orders import StoreService.Names.Phases (RegistrationId (..), awaitChange, newPhases) import StoreService.Names.Signatures (OrderFields (..), orderMessage, personalDigest) import StoreService.Names.Store @@ -61,7 +65,11 @@ import StoreService.Poller (cleanupInterval, cleanupReadsPerPass, cleanupUnpaid, import StoreService.Providers.BTCPay (btcpayProvider) import StoreService.Providers (Funded (..), OrderDraft (..), PaymentSignal (..), Provider (..), ProviderError (..), ProviderInvoice (..)) import StoreService.Store.Invoices (InvoicePayment (..), InvoiceProduct (..), InvoiceRow (..), OverdueInvoice (..), ProviderRefConflict (..), getInvoice, getInvoiceByProviderRef, overdueInvoices, unpaidRefs) -import StoreService.Waiters (newWaiters) +import StoreService.Waiters (Waiters, newWaiters) +import StoreService.Web.Http (codeLimit) +import StoreService.Web.Names (Route (..), namesApp) +import StoreService.Web.Names.Codes (codeCheckHandler) +import StoreService.Web.Names.Orders (codeOrderHandler) import StoreService.Web.Server (WebEnv (..), newWebEnv, webApp, webSettings) import System.Directory (createDirectoryIfMissing) import System.Timeout (timeout) @@ -90,6 +98,20 @@ namesOrdersTests = describe "StoreService names: orders" $ do it "refuses sealed missing or over 11095 characters and a body over 16384 bytes, accepting the longest order" testSizes it "refuses malformed fields, an unknown kind, and an order outside 6-63 letters" testFormats it "accepts orders for one name from two wallets" testTwoWallets + describe "code orders" $ do + it "places a code order as a queued live registration holding its code, answering only its id" testCodeOrder + it "answers an exact resend with its id in any phase, the code spent or not, before any chain read" testCodeResend + it "refuses a resend differing in any one field, the code included, with a bare order_exists" testCodeOneFieldDiffers + it "refuses a bad signature, or another signer's, after the code check" testCodeBadSignature + it "refuses a stale timestamp on a new code order" testCodeStaleTimestamp + it "refuses a code order meeting an open invoice for the name with order_exists" testCodeMeetsInvoice + it "closes an overdue paid order of the same wallet and name, cancelling its invoice after" testCodeClosesOverdue + it "refuses each code that cannot pay with its tag, the state before the cover" testCodeRefusals + it "checks the duration for the code's years" testCodeYears + it "refuses sealed over 11095 characters, a body over 16384 bytes and malformed fields, accepting the longest order" testCodeSizes + it "lets one of two concurrent orders spending one code for two names win, the other answered code_reserved" testConcurrentCodeOrders + it "answers the code's refusal when its reservation fails in the insert, writing nothing" testCodeNotReservable + it "counts code orders and code checks against one code limit" testCodeLimitShared describe "closed orders" $ do it "accepts a new order of the same wallet and name after a cancel" testOrderAfterCancel it "closes an overdue order of the same wallet and name before the poller marks it, cancelling its invoice after" testOverdueClosed @@ -136,7 +158,10 @@ seconds = floor . utcTimeToPOSIXSeconds -- | What the page sends: 2 paid years and the free days until the term starts. durationAt :: UTCTime -> Word64 -durationAt now = 2 * yearSeconds + fromIntegral (max 0 (toInteger (seconds termStart) - toInteger (seconds now))) +durationAt = yearsDuration 2 + +yearsDuration :: Word64 -> UTCTime -> Word64 +yearsDuration years now = years * yearSeconds + fromIntegral (max 0 (toInteger (seconds termStart) - toInteger (seconds now))) -- the webapp's wallet, BIP-39 entropy 6f2d1c9a4b7e3f80d15a2c6e9b04f7a3, accounts 0 and 1 as viem derives them keyA, keyB :: Secp256k1PrivateKey @@ -265,10 +290,18 @@ withOrdersVia via action = withServiceStore $ \cStore -> withFakeEthNode $ \cNod hints <- newReadHints built <- newWebEnv cStore cfg waiters hints [crypto, card] Nothing let cWeb = built {weOrders = Just cOrders} + app req respond = fromMaybe (webApp cWeb req respond) (namesApp (weHttp cWeb) (codeRoutes cOrders [crypto, card] waiters) req respond) mgr <- newManager defaultManagerSettings - Warp.testWithApplicationSettings (webSettings (listener cfg)) (pure (webApp cWeb)) $ \port -> + Warp.testWithApplicationSettings (webSettings (listener cfg)) (pure app) $ \port -> action Ctx {cStore, cNode, cOrders, cWeb, cClient = (mgr, "http://127.0.0.1:" <> show port), cStub, cClock, cRandom, cIps} +-- | The routes as namesRoutes registers them, since a NamesEnv needs a running chat controller. +codeRoutes :: OrdersEnv -> [Provider] -> Waiters -> [Text] -> Maybe Route +codeRoutes orders providers waiters = \case + ["api", "name", "register"] -> Just Route {rMethod = "POST", rLimit = codeLimit, rHandler = codeOrderHandler orders providers waiters} + ["api", "code", "check"] -> Just Route {rMethod = "POST", rLimit = codeLimit, rHandler = codeCheckHandler (oeStore orders)} + _ -> Nothing + -- | alicebakery and dynamis available, at the launch prices for 2 years. answerAvailable :: FakeEthNode -> IO () answerAvailable node = do @@ -594,6 +627,243 @@ testTwoWallets = withOrders $ \ctx -> do a `shouldNotBe` b mapM (fmap nrLive . invoiceRegistration ctx) [a, b] `shouldReturn` [True, True] +-- code orders + +-- | A prepaid code as the operator issues it, with its text as the page sends it. +issueCode :: Ctx -> Int -> Int -> (NewPrepaidCode -> NewPrepaidCode) -> IO (Text, PrepaidCode) +issueCode Ctx {cStore, cRandom} len years change = do + code <- randomNamePrepaidCode cRandom len + let new = change NewPrepaidCode {npcCodeHash = namePrepaidCodeHash code, npcMinLength = len, npcYears = years, npcPaymentStatus = CPSPaid, npcExpiresAt = Nothing} + stored <- withTransaction cStore $ \db -> + insertPrepaidCode db new orderTime >>= \case + Right codeId -> fromJust <$> getPrepaidCodeById db codeId + Left e -> error $ "code not issued: " <> show e + pure (formatNameCode $ NCPrepaid code, stored) + +unissuedCode :: Ctx -> Int -> IO Text +unissuedCode Ctx {cRandom} len = formatNameCode . NCPrepaid <$> randomNamePrepaidCode cRandom len + +readCode :: Ctx -> PrepaidCode -> IO PrepaidCode +readCode Ctx {cStore} PrepaidCode {pcId} = withTransaction cStore $ \db -> fromJust <$> getPrepaidCodeById db pcId + +-- | The body of /api/name/register: the order's fields and the code, without a kind, method or price. +signedCodeBody :: Ctx -> Text -> Order -> IO J.Object +signedCodeBody ctx code o = KM.insert "code" (J.String code) . KM.delete "kind" . KM.delete "method" . KM.delete "price" <$> signedBody (cRandom ctx) o + +postRegister :: Ctx -> J.Object -> IO (Int, Maybe J.Object) +postRegister ctx = post ctx "/api/name/register" . J.encode + +register :: Ctx -> Text -> Order -> IO (Int, Maybe J.Object) +register ctx code o = signedCodeBody ctx code o >>= postRegister ctx + +-- | A code order's registration id, failing the test unless the order was accepted with that alone. +registered :: Ctx -> Text -> Order -> IO RegistrationId +registered ctx code o = + register ctx code o >>= \case + (200, Just v) | [("registrationId", J.String rid)] <- KM.toList v -> pure $ RegistrationId rid + other -> error $ "code order refused: " <> show other + +registrationAnswer :: RegistrationId -> (Int, Maybe J.Object) +registrationAnswer (RegistrationId rid) = (200, Just $ KM.fromList [("registrationId", J.String rid)]) + +registrationById :: Ctx -> RegistrationId -> IO NameRegistration +registrationById Ctx {cStore} rid = withTransaction cStore $ \db -> fromJust <$> getRegistration db rid + +testCodeOrder :: IO () +testCodeOrder = withOrders $ \ctx -> do + (code, issued@PrepaidCode {pcId, pcCodeHash}) <- issueCode ctx 8 2 id + rid <- registered ctx code aliceOrder + r <- registrationById ctx rid + (nrPhase r, nrLive r, nrVersion r, nrYears r, nrPrice r, nrPayment r) `shouldBe` (PQueued, True, 1, 2, 0, RPCode pcId) + (nrOwner r, nrDuration r, nrCommitment r, nrSealed r) `shouldBe` (ownerA, durationAt orderTime, oCommitment aliceOrder, oSealed aliceOrder) + nrOrderHash r `shouldBe` orderHash ownerA (fieldsOf aliceOrder) (OTCode pcCodeHash) + held <- readCode ctx issued + (pcReservedBy held, pcReservedAt held, pcSpentAt held) `shouldBe` (Just rid, Just orderTime, Nothing) + stubCalls (cStub ctx) `shouldReturn` [] + +testCodeResend :: IO () +testCodeResend = withOrders $ \ctx -> do + (code, PrepaidCode {pcId}) <- issueCode ctx 8 2 id + body <- signedCodeBody ctx code aliceOrder + rid <- registered ctx code aliceOrder + advance ctx 60 + register ctx code aliceOrder {oTimestamp = seconds orderTime + 60} `shouldReturn` registrationAnswer rid + r <- registrationById ctx rid + now <- readIORef (cClock ctx) + withTransaction (cStore ctx) $ \db -> do + updateRegistration db r {nrPhase = PRegistered} now `shouldReturn` Written 2 + spendPrepaidCode db pcId rid now `shouldReturn` True + advance ctx 3600 + setFault (cNode ctx) "eth_call" HttpFailure + postRegister ctx body `shouldReturn` registrationAnswer rid + register ctx code aliceOrder {oTimestamp = seconds orderTime + 3660} `shouldReturn` registrationAnswer rid + length <$> registrationsOf ctx ownerA `shouldReturn` 1 + +testCodeOneFieldDiffers :: IO () +testCodeOneFieldDiffers = withOrders $ \ctx -> do + (code, _) <- issueCode ctx 7 2 id + (other, otherCode) <- issueCode ctx 8 2 id + void $ registered ctx code aliceOrder + let variants = + [ (code, aliceOrder {oLabel = "dynamis"}), + (code, aliceOrder {oCommitment = commitmentOf 2}), + (code, aliceOrder {oSealed = "sealed-alicebakery-2"}), + (code, aliceOrder {oDuration = oDuration aliceOrder + 1}), + (other, aliceOrder) + ] + forM_ variants $ \(c, o) -> register ctx c o `shouldReturn` refusedWith 409 "order_exists" + -- the same fields as a paid order are another order + placeOrder ctx aliceOrder `shouldReturn` refusedWith 409 "order_exists" + pcReservedBy <$> readCode ctx otherCode `shouldReturn` Nothing + length <$> registrationsOf ctx ownerA `shouldReturn` 1 + +testCodeBadSignature :: IO () +testCodeBadSignature = withOrders $ \ctx -> do + (code, issued) <- issueCode ctx 8 2 id + register ctx code aliceOrder {oKey = keyB} `shouldReturn` refusedWith 400 "bad_request" + good <- signedCodeBody ctx code aliceOrder + let highS = "0x" <> T.replicate 32 "11" <> "ff" <> T.replicate 31 "11" <> "1b" + forM_ [highS, ""] $ \bad -> postRegister ctx (withSignature bad good) `shouldReturn` refusedWith 400 "bad_request" + postRegister ctx (KM.delete "signature" good) `shouldReturn` refusedWith 400 "bad_request" + unknown <- unissuedCode ctx 8 + register ctx unknown aliceOrder {oKey = keyB} `shouldReturn` refusedWith 400 "code_invalid" + pcReservedBy <$> readCode ctx issued `shouldReturn` Nothing + length <$> registrationsOf ctx ownerA `shouldReturn` 0 + +testCodeStaleTimestamp :: IO () +testCodeStaleTimestamp = withOrders $ \ctx -> do + (code, _) <- issueCode ctx 8 2 id + let at offset = aliceOrder {oTimestamp = fromIntegral (toInteger (seconds orderTime) + offset)} + forM_ [-601, 601] $ \offset -> register ctx code (at offset) `shouldReturn` refusedWith 400 "bad_request" + register ctx code aliceOrder {oTimestamp = maxBound} `shouldReturn` refusedWith 400 "bad_request" + void $ registered ctx code (at (-600)) + +testCodeMeetsInvoice :: IO () +testCodeMeetsInvoice = withOrders $ \ctx -> do + (code, issued) <- issueCode ctx 8 2 id + void $ placed ctx aliceOrder + register ctx code aliceOrder `shouldReturn` refusedWith 409 "order_exists" + register ctx code aliceOrder {oCommitment = commitmentOf 2} `shouldReturn` refusedWith 409 "order_exists" + -- another wallet sending the open order's commitment + register ctx code aliceOrder {oOwner = ownerBText, oKey = keyB} `shouldReturn` refusedWith 409 "order_exists" + pcReservedBy <$> readCode ctx issued `shouldReturn` Nothing + length <$> registrationsOf ctx ownerA `shouldReturn` 1 + length <$> registrationsOf ctx ownerB `shouldReturn` 0 + +testCodeClosesOverdue :: IO () +testCodeClosesOverdue = withOrders $ \ctx -> do + (code, _) <- issueCode ctx 8 2 id + (short, _) <- issueCode ctx 12 2 id + (oldInv, _) <- placed ctx aliceOrder {oMethod = "card"} + -- past the card invoice's 60 minutes, before any sweep + advance ctx (61 * 60) + now <- readIORef (cClock ctx) + let next = aliceOrder {oCommitment = commitmentOf 2, oTimestamp = seconds now, oDuration = durationAt now} + register ctx short next `shouldReturn` refusedWith 409 "code_not_covering" + nrLive <$> invoiceRegistration ctx oldInv `shouldReturn` True + rid <- registered ctx code next + Just oldRow <- getInvoice (cStore ctx) oldInv + irStatus oldRow `shouldBe` ISExpired + old <- invoiceRegistration ctx oldInv + (nrPhase old, nrLive old, nrVersion old) `shouldBe` (PUnpaid, False, 2) + (nrPhase &&& nrLive) <$> registrationById ctx rid `shouldReturn` (PQueued, True) + calls <- stubCalls (cStub ctx) + [c | c@StubCancel {} <- calls] `shouldBe` [StubCancel (irProviderRef oldRow)] + +testCodeRefusals :: IO () +testCodeRefusals = withOrders $ \ctx@Ctx {cStore} -> do + unknown <- unissuedCode ctx 8 + let typo = T.init unknown <> (if T.last unknown == '0' then "1" else "0") + ownerCode = "SN-DWPHS-6JBFR-ZR1MA-T5HQ9-P17QM-F5GM5" + forM_ [unknown, typo, ownerCode, "not a code"] $ \c -> register ctx c aliceOrder `shouldReturn` refusedWith 400 "code_invalid" + (revoked, revokedCode) <- issueCode ctx 8 2 id + withTransaction cStore $ \db -> void $ revokePrepaidCode db (pcCodeHash revokedCode) orderTime + register ctx revoked aliceOrder `shouldReturn` refusedWith 400 "code_invalid" + (reserved, reservedCode) <- issueCode ctx 8 2 id + placeCode cStore "holder" ownerB (order "holderone" 1) reservedCode `shouldReturn` Right () + register ctx reserved aliceOrder `shouldReturn` refusedWith 409 "code_reserved" + (used, usedCode) <- issueCode ctx 8 2 id + placeCode cStore "spender" ownerB (order "spendertwo" 2) usedCode `shouldReturn` Right () + withTransaction cStore (\db -> spendPrepaidCode db (pcId usedCode) (RegistrationId "spender") t0) `shouldReturn` True + register ctx used aliceOrder `shouldReturn` refusedWith 409 "code_used" + (expired, _) <- issueCode ctx 8 2 $ \c -> c {npcExpiresAt = Just orderTime} + register ctx expired aliceOrder `shouldReturn` refusedWith 409 "code_expired" + (unpaid, _) <- issueCode ctx 8 2 $ \c -> c {npcPaymentStatus = CPSUnpaid} + register ctx unpaid aliceOrder `shouldReturn` refusedWith 409 "payment_pending" + (long, _) <- issueCode ctx 12 2 id + register ctx long aliceOrder `shouldReturn` refusedWith 409 "code_not_covering" + (longUnpaid, _) <- issueCode ctx 12 2 $ \c -> c {npcPaymentStatus = CPSUnpaid} + register ctx longUnpaid aliceOrder `shouldReturn` refusedWith 409 "payment_pending" + length <$> registrationsOf ctx ownerA `shouldReturn` 0 + +testCodeYears :: IO () +testCodeYears = withOrders $ \ctx -> do + (code, _) <- issueCode ctx 8 5 id + register ctx code aliceOrder `shouldReturn` refusedWith 400 "bad_request" + rid <- registered ctx code aliceOrder {oDuration = yearsDuration 5 orderTime} + (nrYears &&& nrDuration) <$> registrationById ctx rid `shouldReturn` (5, yearsDuration 5 orderTime) + +testCodeSizes :: IO () +testCodeSizes = withOrders $ \ctx -> do + (code, _) <- issueCode ctx 8 2 id + register ctx code aliceOrder {oSealed = T.replicate 11096 "a"} `shouldReturn` refusedWith 400 "bad_request" + padded <- KM.insert "padding" (J.String $ T.replicate 16384 "a") <$> signedCodeBody ctx code aliceOrder + postRegister ctx padded `shouldReturn` refusedWith 400 "bad_request" + good <- signedCodeBody ctx code aliceOrder + let with k v = KM.insert k v good + forM_ + [ KM.delete "sealed" good, + KM.delete "code" good, + with "code" (J.Number 8), + with "labelHash" (J.String $ T.toUpper $ hex $ (\(LabelHash h) -> h) alice), + with "owner" (J.String $ T.toLower ownerAText), + with "timestamp" "1792574100" + ] + $ \body -> postRegister ctx body `shouldReturn` refusedWith 400 "bad_request" + forM_ ["[]", "{"] $ \body -> post ctx "/api/name/register" body `shouldReturn` (400, errorOnly "bad_request") + -- the formats and the length come before the code + forM_ [5, 64] $ \len -> postRegister ctx (KM.insert "code" "not a code" $ with "length" (J.Number len)) `shouldReturn` refusedWith 400 "invalid_name" + longest <- signedCodeBody ctx code aliceOrder {oSealed = T.replicate 11095 "a"} + LB.length (J.encode longest) `shouldSatisfy` (< 16384) + fst <$> postRegister ctx longest `shouldReturn` 200 + +testConcurrentCodeOrders :: IO () +testConcurrentCodeOrders = withOrders $ \ctx -> do + (code, issued) <- issueCode ctx 7 2 id + (a, b) <- concurrently (register ctx code aliceOrder) (register ctx code aliceOrder {oLabel = "dynamis", oCommitment = commitmentOf 2}) + sort [fst a, fst b] `shouldBe` [200, 409] + filter ((== 409) . fst) [a, b] `shouldBe` [refusedWith 409 "code_reserved"] + [(_, winner)] <- pure $ filter ((== 200) . fst) [a, b] + pcReservedBy <$> readCode ctx issued `shouldReturn` Just (RegistrationId $ textOf "registrationId" winner) + length <$> registrationsOf ctx ownerA `shouldReturn` 1 + +-- | A writer outside this process, which takes no turn here, reserves or revokes the code between the check and the insert. +testCodeNotReservable :: IO () +testCodeNotReservable = withOrders $ \ctx@Ctx {cStore} -> do + (_, reservedLate) <- issueCode ctx 8 2 id + placeCode cStore "outsider" ownerB (order "holderone" 1) reservedLate `shouldReturn` Right () + (_, revokedLate) <- issueCode ctx 8 2 id + withTransaction cStore $ \db -> void $ revokePrepaidCode db (pcCodeHash revokedLate) orderTime + req <- fromJust . Orders.parseOrderRequest <$> signedBody (cRandom ctx) aliceOrder + let new = NewRegistration {nrgId = RegistrationId "late", nrgOwner = ownerA, nrgOrder = fieldsOf aliceOrder, nrgYears = 2} + forM_ [(reservedLate, CRReserved), (revokedLate, CRInvalid)] $ \(stale, refusal) -> do + placedOrder <- Orders.placeOrder (cOrders ctx) req (Orders.codeOrderInsert new stale) + either Just (const Nothing) placedOrder `shouldBe` Just (Orders.ORCode refusal) + length <$> registrationsOf ctx ownerA `shouldReturn` 0 + +-- | One client's code checks and code orders share its 10 a minute; another client is not limited by them. +testCodeLimitShared :: IO () +testCodeLimitShared = withOrders $ \ctx@Ctx {cClient} -> do + (code, _) <- issueCode ctx 8 2 id + body <- J.encode <$> signedCodeBody ctx code aliceOrder + let from path b = statusOf <$> webRequestBody cClient "POST" path [(hContentType, "application/json"), ("X-Forwarded-For", "203.0.113.7")] b + codeCheck = from "/api/code/check" (J.encode $ J.object ["code" .= code]) + codeOrder = from "/api/name/register" body + sequence (concat $ replicate 5 [codeCheck, codeOrder]) `shouldReturn` replicate 10 200 + codeCheck `shouldReturn` 429 + codeOrder `shouldReturn` 429 + fst <$> register ctx code aliceOrder `shouldReturn` 200 + testOrderAfterCancel :: IO () testOrderAfterCancel = withOrders $ \ctx -> do (invId@(InvoiceId invText), _) <- placed ctx aliceOrder From 0311e412ceaedf7c7d55d7ce5002143258817a4c Mon Sep 17 00:00:00 2001 From: shum Date: Thu, 22 Oct 2026 04:09:11 +0000 Subject: [PATCH 4/7] store: test code orders against the name check --- tests/Bots/StoreService/NamesOrdersTests.hs | 24 +++++++++++++++++++++ 1 file changed, 24 insertions(+) diff --git a/tests/Bots/StoreService/NamesOrdersTests.hs b/tests/Bots/StoreService/NamesOrdersTests.hs index a502b8c587..c563c65b5b 100644 --- a/tests/Bots/StoreService/NamesOrdersTests.hs +++ b/tests/Bots/StoreService/NamesOrdersTests.hs @@ -108,6 +108,7 @@ namesOrdersTests = describe "StoreService names: orders" $ do it "closes an overdue paid order of the same wallet and name, cancelling its invoice after" testCodeClosesOverdue it "refuses each code that cannot pay with its tag, the state before the cover" testCodeRefusals it "checks the duration for the code's years" testCodeYears + it "answers name_taken and name_check_unavailable before the code's state and cover, leaving the code unreserved" testCodeNameChecks it "refuses sealed over 11095 characters, a body over 16384 bytes and malformed fields, accepting the longest order" testCodeSizes it "lets one of two concurrent orders spending one code for two names win, the other answered code_reserved" testConcurrentCodeOrders it "answers the code's refusal when its reservation fails in the insert, writing nothing" testCodeNotReservable @@ -803,6 +804,29 @@ testCodeYears = withOrders $ \ctx -> do rid <- registered ctx code aliceOrder {oDuration = yearsDuration 5 orderTime} (nrYears &&& nrDuration) <$> registrationById ctx rid `shouldReturn` (5, yearsDuration 5 orderTime) +testCodeNameChecks :: IO () +testCodeNameChecks = withOrders $ \ctx@Ctx {cNode = node} -> do + (code, issued) <- issueCode ctx 8 2 id + (long, _) <- issueCode ctx 12 2 id + let unreserved = pcReservedBy <$> readCode ctx issued `shouldReturn` Nothing + answerCall node fakeController reservedNamesCall $ Returns $ uint256 (1 :: Int) + register ctx code aliceOrder `shouldReturn` refusedWith 409 "name_taken" + register ctx long aliceOrder `shouldReturn` refusedWith 409 "name_taken" + answerCall node fakeController reservedNamesCall $ Returns $ uint256 (0 :: Int) + answerRegistered node (cResolver $ fakeChainConfig node) + answerCall node (registrarOf node) nameExpiresCall $ Returns $ uint256 (seconds orderTime + yearSeconds) + register ctx code aliceOrder `shouldReturn` refusedWith 409 "name_taken" + register ctx long aliceOrder `shouldReturn` refusedWith 409 "name_taken" + unreserved + answerCall node (registrarOf node) nameExpiresCall $ Returns $ uint256 (0 :: Int) + setFault node "eth_call" HttpFailure + register ctx code aliceOrder `shouldReturn` refusedWith 503 "name_check_unavailable" + register ctx long aliceOrder `shouldReturn` refusedWith 503 "name_check_unavailable" + unreserved + length <$> registrationsOf ctx ownerA `shouldReturn` 0 + clearFault node "eth_call" + void $ registered ctx code aliceOrder + testCodeSizes :: IO () testCodeSizes = withOrders $ \ctx -> do (code, _) <- issueCode ctx 8 2 id From e5d19cadff54d23da8c63117e91d2458d719d67d Mon Sep 17 00:00:00 2001 From: shum Date: Thu, 22 Oct 2026 04:14:36 +0000 Subject: [PATCH 5/7] store: test the code limit through the names router --- tests/Bots/StoreService/GroupIntegrationTests.hs | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/tests/Bots/StoreService/GroupIntegrationTests.hs b/tests/Bots/StoreService/GroupIntegrationTests.hs index 753cec1625..d8e8198a35 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 and a path no route knows to 404" testNamesBoot +namesBootTests = it "boots with [names] and [chain], routing fixed /api/name paths ahead of a search, a path no route knows to 404, and code checks and orders under one limit" testNamesBoot testNamesBoot :: HasCallStack => TestParams -> IO () testNamesBoot ps = do @@ -154,6 +154,10 @@ testNamesBoot ps = do answer register {method = "POST", requestBody = RequestBodyLBS "{}"} `shouldReturn` refused "bad_request" search <- request $ "/api/name/" <> T.unpack aliceHex <> "?length=5" answer search `shouldReturn` refused "invalid_name" + -- 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) + forM_ ["/api/code/check", "/api/name/register"] $ \path -> (path,) <$> codeRequest path `shouldReturn` (path, 429) poll t >>= (`shouldSatisfy` isNothing) namesCodesChatTests :: SpecWith TestParams From d466ac2a75acbb5ff621222d2c98dd516f24ffea Mon Sep 17 00:00:00 2001 From: shum Date: Thu, 22 Oct 2026 04:16:37 +0000 Subject: [PATCH 6/7] store: test that code orders take the code's turn --- tests/Bots/StoreService/NamesOrdersTests.hs | 18 ++++++++++++++---- 1 file changed, 14 insertions(+), 4 deletions(-) diff --git a/tests/Bots/StoreService/NamesOrdersTests.hs b/tests/Bots/StoreService/NamesOrdersTests.hs index c563c65b5b..11b4b8e2f1 100644 --- a/tests/Bots/StoreService/NamesOrdersTests.hs +++ b/tests/Bots/StoreService/NamesOrdersTests.hs @@ -58,7 +58,7 @@ import qualified StoreService.Names.Orders as Orders import StoreService.Names.Phases (RegistrationId (..), awaitChange, newPhases) import StoreService.Names.Signatures (OrderFields (..), orderMessage, personalDigest) import StoreService.Names.Store -import StoreService.Names.Turns (newTurns) +import StoreService.Names.Turns (newTurns, withCodeTurn) import StoreService.Names.View (ViewReads (..), readViewChain, viewJSON) import StoreService.Orders (cancelOpenInvoice, expireOverdue, settleOrder) import StoreService.Poller (cleanupInterval, cleanupReadsPerPass, cleanupUnpaid, drainHints, newPollerEnv, newReadHints, queueReadHint, runOnePass, unpaidRetention) @@ -110,7 +110,7 @@ namesOrdersTests = describe "StoreService names: orders" $ do it "checks the duration for the code's years" testCodeYears it "answers name_taken and name_check_unavailable before the code's state and cover, leaving the code unreserved" testCodeNameChecks it "refuses sealed over 11095 characters, a body over 16384 bytes and malformed fields, accepting the longest order" testCodeSizes - it "lets one of two concurrent orders spending one code for two names win, the other answered code_reserved" testConcurrentCodeOrders + it "runs code orders in the code's turn, one of two spending one code for two names winning, the other answered code_reserved" testConcurrentCodeOrders it "answers the code's refusal when its reservation fails in the insert, writing nothing" testCodeNotReservable it "counts code orders and code checks against one code limit" testCodeLimitShared describe "closed orders" $ do @@ -851,10 +851,20 @@ testCodeSizes = withOrders $ \ctx -> do LB.length (J.encode longest) `shouldSatisfy` (< 16384) fst <$> postRegister ctx longest `shouldReturn` 200 +-- | Both orders wait while the test holds the code's turn, so neither checks or reserves the code outside it. testConcurrentCodeOrders :: IO () testConcurrentCodeOrders = withOrders $ \ctx -> do - (code, issued) <- issueCode ctx 7 2 id - (a, b) <- concurrently (register ctx code aliceOrder) (register ctx code aliceOrder {oLabel = "dynamis", oCommitment = commitmentOf 2}) + (code, issued@PrepaidCode {pcCodeHash}) <- issueCode ctx 7 2 id + entered <- newEmptyMVar + release <- newEmptyMVar + holder <- async $ withCodeTurn (oeTurns $ cOrders ctx) pcCodeHash $ putMVar entered () >> takeMVar release + takeMVar entered + orders <- async $ concurrently (register ctx code aliceOrder) (register ctx code aliceOrder {oLabel = "dynamis", oCommitment = commitmentOf 2}) + timeout 300000 (wait orders) >>= (`shouldSatisfy` isNothing) + pcReservedBy <$> readCode ctx issued `shouldReturn` Nothing + putMVar release () + wait holder + (a, b) <- wait orders sort [fst a, fst b] `shouldBe` [200, 409] filter ((== 409) . fst) [a, b] `shouldBe` [refusedWith 409 "code_reserved"] [(_, winner)] <- pure $ filter ((== 200) . fst) [a, b] From 2704a72d6bd6019ce0f5c2a5935fa2dda908d1f3 Mon Sep 17 00:00:00 2001 From: shum Date: Thu, 22 Oct 2026 04:22:16 +0000 Subject: [PATCH 7/7] store: answer name orders after the turn --- .../src/StoreService/Web/Names/Orders.hs | 47 +++++++++++-------- tests/Bots/StoreService/NamesOrdersTests.hs | 36 +++++++++++++- 2 files changed, 62 insertions(+), 21 deletions(-) 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 05cadd6bd2..588ca9dec5 100644 --- a/apps/simplex-store-service/src/StoreService/Web/Names/Orders.hs +++ b/apps/simplex-store-service/src/StoreService/Web/Names/Orders.hs @@ -55,10 +55,19 @@ parseInvoiceOrder o = do pure InvoiceOrder {ioRequest, ioMethod, ioPrice} order <$ checkLength 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 ()} + +answerNow :: Response -> Answer +answerNow aResponse = Answer {aResponse, aAfter = pure ()} + +sendAnswer :: Respond -> Answer -> IO ResponseReceived +sendAnswer respond Answer {aResponse, aAfter} = aAfter >> respond aResponse + -- | POST /api/invoice for a name, its body already read and its kind checked. nameInvoiceHandler :: OrdersEnv -> ServiceConfig -> [Provider] -> Waiters -> J.Object -> Respond -> IO ResponseReceived nameInvoiceHandler env@OrdersEnv {oeStore, oeTurns, oeNow} cfg providers waiters body respond = - case parseInvoiceOrder body of + sendAnswer respond =<< case parseInvoiceOrder body of Left refusal -> refuse refusal Right order@InvoiceOrder {ioRequest = req@OrderRequest {orOwner, orFields}, ioMethod, ioPrice} -> checkOrderSigner req >>= \case @@ -73,11 +82,11 @@ nameInvoiceHandler env@OrdersEnv {oeStore, oeTurns, oeNow} cfg providers waiters where refuse refusal = do logInfo ("POST /api/invoice (name) refused: " <> tshow refusal) - respond $ orderRefusalResponse refusal + pure $ answerNow $ orderRefusalResponse refusal answerResend r@NameRegistration {nrPayment} = case nrPayment of - RPInvoice _ invId -> getInvoice oeStore invId >>= maybe (refuse OROrderExists) (\row -> respondView row r) + RPInvoice _ invId -> getInvoice oeStore invId >>= maybe (refuse OROrderExists) (fmap answerNow . viewOf r) RPCode _ -> refuse OROrderExists - respondView row r = respond . jsonResponse status200 =<< nameInvoiceView env (confirmationsFor cfg) row r + viewOf r row = jsonResponse status200 <$> nameInvoiceView env (confirmationsFor cfg) row r newOrder order@InvoiceOrder {ioRequest = OrderRequest {orFields = OrderFields {ofLabelHash, ofLength, ofDuration}, orTimestamp}, ioMethod, ioPrice} = do now <- oeNow let years = nYears $ oeConfig env @@ -92,7 +101,7 @@ nameInvoiceHandler env@OrdersEnv {oeStore, oeTurns, oeNow} cfg providers waiters Nothing -> case providerFor providers ioMethod of Nothing -> do logInfo ("POST /api/invoice (name) refused: no provider configured for " <> tshow ioMethod) - respond providerUnavailable + pure $ answerNow providerUnavailable Just provider -> createAtProvider order provider createAtProvider InvoiceOrder {ioRequest = req@OrderRequest {orOwner, orFields}, ioMethod, ioPrice} provider = do invId <- newInvoiceId @@ -101,7 +110,7 @@ nameInvoiceHandler env@OrdersEnv {oeStore, oeTurns, oeNow} cfg providers waiters pCreateInvoice provider ioMethod OrderDraft {odAmount = amount, odCurrency = catalogCurrency} >>= \case Left (ProviderError e) -> do logError ("POST /api/invoice (name) failed: provider refused to create an invoice: " <> e) - respond providerUnavailable + pure $ answerNow providerUnavailable Right ProviderInvoice {piProviderRef, piDestination} -> do rid <- newRegistrationId let invoice = NewNameInvoice {nniInvoiceId = invId, nniProvider = pProvider provider, nniAmount = amount, nniCurrency = catalogCurrency, nniDestination = piDestination, nniExpiresAt = addUTCTime (invoiceWindow cfg ioMethod) now, nniCreatedAt = now} @@ -112,15 +121,14 @@ nameInvoiceHandler env@OrdersEnv {oeStore, oeTurns, oeNow} cfg providers waiters >>= \case Left refusal -> do logWarn ("POST /api/invoice (name): the order lost to another, so invoice " <> piProviderRef <> " is cancelled at the provider") - cancelAtProvider provider piProviderRef - refuse refusal + (\a -> a {aAfter = cancelAtProvider provider piProviderRef}) <$> refuse refusal Right closed -> do - announceClosed env providers waiters closed row_ <- getInvoice oeStore invId registration_ <- withTransaction oeStore (`getRegistration` rid) - case (row_, registration_) of - (Just row, Just r) -> respondView row r - _ -> logError ("POST /api/invoice (name): order " <> invText invId <> " is not readable after its commit") >> respond internalError + response <- case (row_, registration_) of + (Just row, Just r) -> viewOf r row + _ -> internalError <$ logError ("POST /api/invoice (name): order " <> invText invId <> " is not readable after its commit") + pure Answer {aResponse = response, aAfter = announceClosed env providers waiters closed} -- An invoice created at the provider for an order that was not written would stay payable with nothing watching it. strandedBy :: Provider -> Text -> E.SomeException -> IO a strandedBy provider ref e = do @@ -133,13 +141,14 @@ nameInvoiceHandler env@OrdersEnv {oeStore, oeTurns, oeNow} cfg providers waiters -- | POST /api/name/register, an order paid with a prepaid code, in the contract's order of checks. codeOrderHandler :: OrdersEnv -> [Provider] -> Waiters -> Request -> Respond -> IO ResponseReceived codeOrderHandler env@OrdersEnv {oeStore, oeConfig, oeContracts, oeTurns, oeNow} providers waiters req respond = - readBoundedBody nameBodyBytes req >>= \case - Just body | Just (J.Object o) <- J.decode body -> either refuse withCode (parseCodeOrder o) - _ -> refuse ORBadRequest + readBoundedBody nameBodyBytes req >>= ordered >>= sendAnswer respond where + ordered = \case + Just body | Just (J.Object o) <- J.decode body -> either refuse withCode (parseCodeOrder o) + _ -> refuse ORBadRequest refuse refusal = do logInfo ("POST /api/name/register refused: " <> tshow refusal) - respond $ orderRefusalResponse refusal + pure $ answerNow $ orderRefusalResponse refusal withCode (order, codeText) = issuedCode codeText >>= \case Nothing -> refuse $ ORCode CRInvalid @@ -150,7 +159,7 @@ codeOrderHandler env@OrdersEnv {oeStore, oeConfig, oeContracts, oeTurns, oeNow} signed order@OrderRequest {orOwner, orFields} code@PrepaidCode {pcCodeHash} = withLabelTurn oeTurns (ofLabelHash orFields) $ do now <- oeNow withTransaction oeStore (\db -> existingOrder db order (orderHash orOwner orFields (OTCode pcCodeHash)) now) >>= \case - EOResent NameRegistration {nrId} -> answer nrId + EOResent NameRegistration {nrId} -> pure $ answerNow $ registrationAnswer nrId EOMeets -> refuse OROrderExists EONew _ -> newOrder now order code newOrder now order@OrderRequest {orFields = OrderFields {ofLabelHash, ofDuration}, orTimestamp} code@PrepaidCode {pcYears} = do @@ -165,8 +174,8 @@ codeOrderHandler env@OrdersEnv {oeStore, oeConfig, oeContracts, oeTurns, oeNow} rid <- newRegistrationId placeCodeOrder env order rid code >>= \case Left refusal -> refuse refusal - Right closed -> announceClosed env providers waiters closed >> answer rid - answer (RegistrationId rid) = respond $ jsonResponse status200 $ J.object ["registrationId" .= rid] + Right closed -> pure Answer {aResponse = registrationAnswer rid, aAfter = announceClosed env providers waiters closed} + registrationAnswer (RegistrationId rid) = jsonResponse status200 $ J.object ["registrationId" .= rid] parseCodeOrder :: J.Object -> Either OrderRefusal (OrderRequest, Text) parseCodeOrder o = do diff --git a/tests/Bots/StoreService/NamesOrdersTests.hs b/tests/Bots/StoreService/NamesOrdersTests.hs index 11b4b8e2f1..364347660c 100644 --- a/tests/Bots/StoreService/NamesOrdersTests.hs +++ b/tests/Bots/StoreService/NamesOrdersTests.hs @@ -35,6 +35,7 @@ import Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds) import Data.Word (Word64) import Network.HTTP.Client (defaultManagerSettings, newManager, responseBody) import Network.HTTP.Types (hContentType) +import Network.Wai (Application, requestHeaders) import qualified Network.Wai.Handler.Warp as Warp import Simplex.Chat.Badges.Code (NameCode (..), formatNameCode, namePrepaidCodeHash, randomNamePrepaidCode) import Simplex.Chat.Badges.Types (BadgeCodePaymentStatus (..)) @@ -98,6 +99,7 @@ namesOrdersTests = describe "StoreService names: orders" $ do it "refuses sealed missing or over 11095 characters and a body over 16384 bytes, accepting the longest order" testSizes it "refuses malformed fields, an unknown kind, and an order outside 6-63 letters" testFormats it "accepts orders for one name from two wallets" testTwoWallets + it "answers after the name's turn, so a slow reader of one answer holds no other order for the name, paid or by code" testSlowReaderHoldsNoTurn describe "code orders" $ do it "places a code order as a queued live registration holding its code, answering only its id" testCodeOrder it "answers an exact resend with its id in any phase, the code spent or not, before any chain read" testCodeResend @@ -291,11 +293,13 @@ withOrdersVia via action = withServiceStore $ \cStore -> withFakeEthNode $ \cNod hints <- newReadHints built <- newWebEnv cStore cfg waiters hints [crypto, card] Nothing let cWeb = built {weOrders = Just cOrders} - app req respond = fromMaybe (webApp cWeb req respond) (namesApp (weHttp cWeb) (codeRoutes cOrders [crypto, card] waiters) req respond) mgr <- newManager defaultManagerSettings - Warp.testWithApplicationSettings (webSettings (listener cfg)) (pure app) $ \port -> + Warp.testWithApplicationSettings (webSettings (listener cfg)) (pure $ ordersApp cWeb cOrders) $ \port -> action Ctx {cStore, cNode, cOrders, cWeb, cClient = (mgr, "http://127.0.0.1:" <> show port), cStub, cClock, cRandom, cIps} +ordersApp :: WebEnv -> OrdersEnv -> Application +ordersApp web orders req respond = fromMaybe (webApp web req respond) (namesApp (weHttp web) (codeRoutes orders (weProviders web) (weWaiters web)) req respond) + -- | The routes as namesRoutes registers them, since a NamesEnv needs a running chat controller. codeRoutes :: OrdersEnv -> [Provider] -> Waiters -> [Text] -> Maybe Route codeRoutes orders providers waiters = \case @@ -898,6 +902,34 @@ testCodeLimitShared = withOrders $ \ctx@Ctx {cClient} -> do codeOrder `shouldReturn` 429 fst <$> register ctx code aliceOrder `shouldReturn` 200 +-- | A response held before it is written, as for a client that reads it slowly, must not hold the name's turn. +testSlowReaderHoldsNoTurn :: IO () +testSlowReaderHoldsNoTurn = withOrders $ \ctx@Ctx {cWeb, cOrders} -> do + (codeA, _) <- issueCode ctx 7 2 id + (codeB, _) <- issueCode ctx 7 2 id + writing <- newEmptyMVar + release <- newEmptyMVar + let app = ordersApp cWeb cOrders + slow req respond + | isJust (lookup slowReader $ requestHeaders req) = app req $ \r -> putMVar writing () >> takeMVar release >> respond r + | otherwise = app req respond + mgr <- newManager defaultManagerSettings + Warp.testWithApplication (pure slow) $ \port -> do + let c = ctx {cClient = (mgr, "http://127.0.0.1:" <> show port)} + slowPost path body = statusOf <$> webRequestBody (cClient c) "POST" path [(hContentType, "application/json"), (slowReader, "1")] (J.encode body) + whileHeld first second = do + held <- async first + takeMVar writing + timeout 2000000 second >>= (`shouldSatisfy` maybe False ((== 200) . fst)) + putMVar release () + wait held `shouldReturn` 200 + byB o = o {oOwner = ownerBText, oKey = keyB, oCommitment = commitmentOf 2} + whileHeld (signedBody (cRandom c) aliceOrder >>= slowPost "/api/invoice") (placeOrder c $ byB aliceOrder) + let dynamis = aliceOrder {oLabel = "dynamis", oCommitment = commitmentOf 3} + whileHeld (signedCodeBody c codeA dynamis >>= slowPost "/api/name/register") (register c codeB (byB dynamis) {oCommitment = commitmentOf 4}) + where + slowReader = "x-slow-reader" + testOrderAfterCancel :: IO () testOrderAfterCancel = withOrders $ \ctx -> do (invId@(InvoiceId invText), _) <- placed ctx aliceOrder