From ddd600e1c671cbc1c3f61bbd585eac27ec464db1 Mon Sep 17 00:00:00 2001 From: shum Date: Thu, 29 Oct 2026 10:25:59 +0000 Subject: [PATCH] store: refuse paid name orders when codes_only --- .../src/StoreService/Names/Orders.hs | 1 + .../src/StoreService/Web/Names/Orders.hs | 13 ++++--- .../StoreService/GroupIntegrationTests.hs | 36 +++++++++++++++++-- tests/Bots/StoreService/NamesOrdersTests.hs | 30 ++++++++++++++-- tests/Bots/StoreService/NamesSpendTests.hs | 17 ++++++++- tests/Bots/StoreService/NamesWorkerTests.hs | 32 ++++++++++++++--- 6 files changed, 113 insertions(+), 16 deletions(-) diff --git a/apps/simplex-store-service/src/StoreService/Names/Orders.hs b/apps/simplex-store-service/src/StoreService/Names/Orders.hs index a584d70035..7d16633ebe 100644 --- a/apps/simplex-store-service/src/StoreService/Names/Orders.hs +++ b/apps/simplex-store-service/src/StoreService/Names/Orders.hs @@ -109,6 +109,7 @@ data OrderRefusal | ORBalanceChanged (Maybe Balance) | -- | the current terms and the name's community entry, as the answer carries them ORTermsChanged J.Value J.Value + | ORCodesOnly deriving (Eq, Show) newtype OrderRefused = OrderRefused OrderRefusal 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 a6701da829..3b73258c3b 100644 --- a/apps/simplex-store-service/src/StoreService/Web/Names/Orders.hs +++ b/apps/simplex-store-service/src/StoreService/Web/Names/Orders.hs @@ -28,7 +28,7 @@ import Data.Maybe (isJust, maybeToList) import Data.Text (Text) import Data.Time.Clock (UTCTime, addUTCTime) import Data.Word (Word32, Word64) -import Network.HTTP.Types (status200, status409, status503) +import Network.HTTP.Types (status200, status403, status409, status503) import Network.Wai (Request, Response, ResponseReceived) import Simplex.Chat.Badges.Code (NameCode (..), parseNameCode) import Simplex.Chat.PaymentService.Types (CurrencyAmount (..), InvoiceId (..), InvoiceStatus (..), ServicePaymentMethod (..)) @@ -83,8 +83,9 @@ 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 = - sendAnswer respond =<< case parseInvoiceOrder body of +nameInvoiceHandler env@OrdersEnv {oeStore, oeTurns, oeNow} cfg providers waiters body respond + | nCodesOnly (oeConfig env) = sendAnswer respond =<< refuse ORCodesOnly + | otherwise = sendAnswer respond =<< case parseInvoiceOrder body of Left refusal -> refuse refusal Right order@InvoiceOrder {ioRequest = req@OrderRequest {orOwner, orFields}, ioMethod, ioPrice} -> checkOrderSigner req >>= \case @@ -234,8 +235,9 @@ parseCodeOrder o = do -- | POST /api/registration/:id/spend, another name paid from this order's balance, in the contract's order of checks, -- under the new name's turn and then the balance's. spendHandler :: OrdersEnv -> ServiceConfig -> [Provider] -> Waiters -> Text -> Request -> Respond -> IO ResponseReceived -spendHandler env@OrdersEnv {oeStore, oeConfig, oeContracts, oeTurns, oeNow} cfg providers waiters ridText req respond = - readBoundedBody nameBodyBytes req >>= requested >>= sendAnswer respond +spendHandler env@OrdersEnv {oeStore, oeConfig, oeContracts, oeTurns, oeNow} cfg providers waiters ridText req respond + | nCodesOnly oeConfig = sendAnswer respond =<< refuse ORCodesOnly + | otherwise = readBoundedBody nameBodyBytes req >>= requested >>= sendAnswer respond where source = RegistrationId ridText what = "POST /api/registration/:id/spend" @@ -350,3 +352,4 @@ orderRefusalResponse = \case ORPriceTooHigh price -> jsonResponse status409 $ J.object ["error" .= ("price_too_high" :: Text), "price" .= price] ORBalanceChanged balance -> jsonResponse status409 $ J.object ["error" .= ("balance_changed" :: Text), "balance" .= (balanceJSON <$> balance)] ORTermsChanged terms community -> jsonResponse status409 $ J.object ["error" .= ("terms_changed" :: Text), "terms" .= terms, "community" .= community] + ORCodesOnly -> jsonError status403 "codes_only" diff --git a/tests/Bots/StoreService/GroupIntegrationTests.hs b/tests/Bots/StoreService/GroupIntegrationTests.hs index 9d1b87b35c..c7c52a796c 100644 --- a/tests/Bots/StoreService/GroupIntegrationTests.hs +++ b/tests/Bots/StoreService/GroupIntegrationTests.hs @@ -40,6 +40,8 @@ import Control.Concurrent.STM (TQueue, atomically, newTQueueIO, orElse, readTMVa import Control.Exception (IOException, bracket, catch, finally, throwIO, try) import Control.Monad (forM_, guard, mfilter, replicateM_, unless, void, when) import qualified Data.Aeson as J +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as LB import Data.Either (isLeft, isRight) import Data.Int (Int64) import Data.List (isInfixOf) @@ -145,6 +147,7 @@ namesBootTests :: SpecWith TestParams namesBootTests = do it "warns naming the indexes of trusted dev_keys, and says nothing without them" testDevKeysWarned it "refuses dev_keys unless the node's own chain id is 31337" testDevKeysNodeChain + it "boots codes-only, refusing paid name orders 403 codes_only and answering code orders and code checks, the badges shell as built" testNamesBootCodesOnly it "boots with [names] and [chain], routing fixed /api/name paths ahead of a search, find ahead of registrations, registrations to GET, another name, a reveal, a spend and a retry to POST, a path no route knows and a taken order's code to 404, code checks and orders under one limit, and another name and retries under another" testNamesBoot testDevKeysWarned :: HasCallStack => TestParams -> IO () @@ -240,6 +243,32 @@ testNamesBoot ps = do forM_ ["/api/code/check", "/api/name/register"] $ \path -> (path,) <$> codeRequest path `shouldReturn` (path, 429) poll t >>= (`shouldSatisfy` isNothing) +testNamesBootCodesOnly :: HasCallStack => TestParams -> IO () +testNamesBootCodesOnly ps = do + svc@GroupSvc {gsStaticDir} <- prepareGroupService ps + let shell = "" + B.writeFile (gsStaticDir "index.html") shell + (t, cc, _, port) <- startGroupService svc {gsIniSections = "" : codesOnlyNames <> chainSection} Nothing + flip finally (stopGroupService t cc) $ do + pollUntilTrue (listening port) + mgr <- newManager defaultManagerSettings + let posted path body = do + req <- parseRequest $ "http://127.0.0.1:" <> show port <> path + r <- httpLbs req {method = "POST", requestBody = RequestBodyLBS body} mgr + pure (statusCode $ responseStatus r, J.decode $ responseBody r :: Maybe J.Value) + answered tag status = (status, Just $ J.object ["error" J..= (tag :: Text)]) + posted "/api/invoice" "{\"kind\":\"name\"}" `shouldReturn` answered "codes_only" 403 + posted "/api/registration/t2Jk8RmQ4vXw9NcP3yLb6g/spend" "{}" `shouldReturn` answered "codes_only" 403 + posted "/api/name/register" "{}" `shouldReturn` answered "bad_request" 400 + posted "/api/code/check" "{}" `shouldReturn` answered "bad_request" 400 + badgesShell <- parseRequest ("http://127.0.0.1:" <> show port <> "/") >>= (`httpLbs` mgr) + (statusCode $ responseStatus badgesShell, responseBody badgesShell) `shouldBe` (200, LB.fromStrict shell) + poll t >>= (`shouldSatisfy` isNothing) + +-- | [names] with codes_only on, as an investors' launch runs. +codesOnlyNames :: [Text] +codesOnlyNames = namesSection <> ["codes_only = on"] + namesWorkerBootTests :: SpecWith TestParams namesWorkerBootTests = it "starts the workers with the service, sending the commit of an order queued after the start" testWorkerBoot @@ -268,8 +297,9 @@ namesCodesChatTests = describe "StoreService names: prepaid codes" $ do it "revokes a prepaid code in the code's turn, after a reservation holding it" testRevokeTakesCodeTurn testGroupNameCodes :: HasCallStack => TestParams -> IO () -testGroupNameCodes ps = - withGroupOwner ps $ \_ cc _ alice -> do +testGroupNameCodes ps = do + svc <- prepareGroupService ps + runWithOwner svc {gsIniSections = "" : codesOnlyNames <> chainSection} $ \cc _ _ alice -> do one <- prepaidIn . T.stripPrefix "Code: " =<< replyTo cc alice "/issue name 8 years 5" namePrepaidCodeLength one `shouldBe` 8 prepaidTerms cc one `shouldReturn` Just (8, 5, CPSFree) @@ -282,7 +312,7 @@ testGroupNameCodes ps = testOperatorNameCodes :: HasCallStack => TestParams -> IO () testOperatorNameCodes ps = do svc <- prepareGroupService ps - (t, cc, _, port) <- startGroupService svc {gsIniSections = "" : namesSection <> chainSection} Nothing + (t, cc, _, port) <- startGroupService svc {gsIniSections = "" : codesOnlyNames <> chainSection} Nothing flip finally (stopGroupService t cc) $ do pollUntilTrue (listening port) forM_ ["name", "name 5", "name 64", "name 07", "name 7 years 1", "name 7 years 11", "name 7 gratis"] $ \args -> diff --git a/tests/Bots/StoreService/NamesOrdersTests.hs b/tests/Bots/StoreService/NamesOrdersTests.hs index abb21c9a78..fec2b7497d 100644 --- a/tests/Bots/StoreService/NamesOrdersTests.hs +++ b/tests/Bots/StoreService/NamesOrdersTests.hs @@ -12,6 +12,7 @@ module Bots.StoreService.NamesOrdersTests withOrdersCancelling, withSettings, configured, + codesOnly, aliceOrder, commitmentOf, fieldsOf, @@ -187,6 +188,9 @@ namesOrdersTests = describe "StoreService names: orders" $ do it "cleans up unpaid orders after 30 days, reading the provider first" testCleanup it "reads at most a pass's share of the provider in a cleanup, carrying the rest to the next pass" testCleanupCapped it "answers 503 for a name invoice while names are off, cancelling nothing" testNamesOff + describe "codes only" $ do + it "answers a name invoice 403 codes_only before reading the order, reaching no provider and writing nothing" testInvoiceCodesOnly + it "sells a badge as before" testBadgeCodesOnly describe "invoice side" $ do it "finds an invoice by provider ref in either table, refusing a ref both hold" testProviderRefs it "reads and sweeps name invoices with the badge ones" testPollerQueries @@ -377,9 +381,13 @@ withOrdersOn cOpenStore via action = cOpenStore >>= \cStore -> withFakeEthNode $ -- | The context's store, chain, providers and clock with its names settings changed, as after a restart. configured :: (NamesConfig -> NamesConfig) -> Ctx -> Ctx -configured change ctx@Ctx {cOrders, cWeb} = ctx {cOrders = orders, cWeb = cWeb {weOrders = Just orders}} +configured change ctx@Ctx {cOrders, cWeb} = ctx {cOrders = orders, cWeb = cWeb {weConfig = (weConfig cWeb) {names = Just namesCfg}, weOrders = Just orders}} where - orders = cOrders {oeConfig = change (oeConfig cOrders)} + namesCfg = change (oeConfig cOrders) + orders = cOrders {oeConfig = namesCfg} + +codesOnly :: NamesConfig -> NamesConfig +codesOnly cfg = cfg {nCodesOnly = True} -- | Another server of the orders routes over the context with its names settings changed. withSettings :: (NamesConfig -> NamesConfig) -> Ctx -> (Ctx -> IO a) -> IO a @@ -1366,6 +1374,24 @@ testNamesOff = withOrders $ \ctx -> do [c | c@StubCancel {} <- calls] `shouldBe` [] (irStatus <$>) <$> getInvoice (cStore ctx) invId `shouldReturn` Just ISOpen +testInvoiceCodesOnly :: IO () +testInvoiceCodesOnly = withOrders $ \open -> withSettings codesOnly open $ \ctx -> do + placeOrder ctx aliceOrder `shouldReturn` refusedWith 403 "codes_only" + postOrder ctx (KM.fromList [("kind", "name")]) `shouldReturn` refusedWith 403 "codes_only" + stubCalls (cStub ctx) `shouldReturn` [] + registrationsOf ctx ownerA `shouldReturn` [] + -- nothing the refusals left meets the same order placed with codes_only off + void $ placed open aliceOrder + +testBadgeCodesOnly :: IO () +testBadgeCodesOnly = withOrders $ \open -> withSettings codesOnly open $ \ctx@Ctx {cStore} -> do + seedCheckoutCatalog cStore + (status, view) <- post ctx "/api/invoice" (createBody supporterPriceId Nothing "btc" (codeHashText sampleCode)) + (status, field "badgeType" =<< view) `shouldBe` (200, Just "supporter") + stubCalls (cStub ctx) >>= \case + [StubCreate method OrderDraft {odReference}] -> (method, T.isPrefixOf "badge:" odReference) `shouldBe` (btc, True) + other -> expectationFailure ("provider calls: " <> show other) + -- | The provider's cancel settles the invoice with the signal before it answers. withOrdersCancelling :: PaymentSignal -> (Ctx -> IO a) -> IO a withOrdersCancelling signal action = withOrders $ \ctx -> do diff --git a/tests/Bots/StoreService/NamesSpendTests.hs b/tests/Bots/StoreService/NamesSpendTests.hs index b71bad3cd8..62906191f3 100644 --- a/tests/Bots/StoreService/NamesSpendTests.hs +++ b/tests/Bots/StoreService/NamesSpendTests.hs @@ -10,7 +10,7 @@ import Bots.StoreService.FakeBTCPay (FakeBTCPay (..), setInvoiceState, setRates, import Bots.StoreService.FakeEthNode import Bots.StoreService.NamesContractsTests (reservedNamesCall) import Bots.StoreService.ConfigTests (termsVersion) -import Bots.StoreService.NamesOrdersTests (Ctx (..), Order (..), advance, aliceOrder, bakers, bumpedTerms, commitmentOf, communityTerms, configured, field, fieldsOf, invoiceRegistration, keyA, keyB, listName, malformedTerms, olderTerms, orderTime, ownerAText, placeOrder, placed, post, refusedWith, registrationById, registrationOf, registrationsOf, settleNow, termsChanged, withOrdersOn, yearsDuration) +import Bots.StoreService.NamesOrdersTests (Ctx (..), Order (..), advance, aliceOrder, bakers, bumpedTerms, codesOnly, commitmentOf, communityTerms, configured, field, fieldsOf, invoiceRegistration, keyA, keyB, listName, malformedTerms, olderTerms, orderTime, ownerAText, placeOrder, placed, post, refusedWith, registrationById, registrationOf, registrationsOf, settleNow, termsChanged, withOrdersOn, yearsDuration) import Bots.StoreService.NamesOwnerTests (findBody, postFind) import Bots.StoreService.NamesStoreTests (at, order, ownerA, placePaid, reg, t0, write) import Bots.StoreService.WebTests (StubCall (..), capturingStderr, StubState (..), jsonObject, rcv, sampleProviderInvoice, statusOf, stubCalls, webGet, webRequestBody, withServiceStores) @@ -84,6 +84,7 @@ namesSpendTests = describe "StoreService names: spend" $ do it "refuses a card difference below the card minimum after the price check, accepting it by crypto and at the minimum" testCardMinimum it "refuses sealed missing or over 11095 characters and a body over 16384 bytes, accepting the longest" testSpendSizes it "counts spends against the create limit" testSpendLimit + it "answers 403 codes_only to a covered spend, a difference, a malformed body and an unknown order, spending nothing and reaching no provider" testSpendCodesOnly describe "terms" $ do it "answers terms_changed for an old version or the wrong variant, listed or not, and stores the community terms, covered and by difference" testSpendTermsChanged it "answers an exact resend after the version changed, covered and by difference" testSpendResendAfterBump @@ -105,6 +106,20 @@ namesSpendChatTests = describe "StoreService names: spend end to end" $ it "spends a taken order's balance on a dearer name through BTCPay and the poller, credits a late payment, and refunds the rest" testSpendEndToEnd +testSpendCodesOnly :: IO () +testSpendCodesOnly = withSpend $ \open -> do + source <- sourceOf open "s" 10000 + serveSpend (configured codesOnly open) $ \ctx -> do + spend ctx source (covered 10000) `shouldReturn` refusedWith 403 "codes_only" + spend ctx source (dynamis 10000 $ Just "btc") `shouldReturn` refusedWith 403 "codes_only" + postSpend ctx source KM.empty `shouldReturn` refusedWith 403 "codes_only" + postSpend ctx (RegistrationId "unknown") KM.empty `shouldReturn` refusedWith 403 "codes_only" + amountOf ctx source `shouldReturn` Just 10000 + paidFrom ctx source `shouldReturn` [] + stubCalls (cStub ctx) `shouldReturn` [] + -- nothing the refusals left meets the same spend with codes_only off + fst <$> spend open source (covered 10000) `shouldReturn` 200 + -- fixtures -- | Over a new database; the hook runs as each provider invoice is created. diff --git a/tests/Bots/StoreService/NamesWorkerTests.hs b/tests/Bots/StoreService/NamesWorkerTests.hs index fe4748f279..f4b4789059 100644 --- a/tests/Bots/StoreService/NamesWorkerTests.hs +++ b/tests/Bots/StoreService/NamesWorkerTests.hs @@ -12,7 +12,7 @@ import Bots.StoreService.NamesOrdersTests import Bots.StoreService.NamesOwnerTests (answerExpiry, answerFree, answerOwner, answerUnowned, byB, codeIn, committedPhase, dynamisOrder, failedPhase, labelBytes, ownerOfSelector, paidIn, rewrite, sentRegister, stored) import Bots.StoreService.NamesPhasesTests (held, prompt, registrationPath, woken) import Bots.StoreService.NamesStoreTests (btc, insertInvoiceRow, ownerA, paidOrder, reveal) -import Bots.StoreService.WebTests (capturingStderr, jsonObject, statusOf, webGet, webRequestBody) +import Bots.StoreService.WebTests (capturingStderr, jsonObject, statusOf, stubCalls, webGet, webRequestBody) import Control.Applicative ((<|>)) import Control.Arrow ((&&&)) import Control.Concurrent (threadDelay) @@ -32,7 +32,7 @@ import qualified Data.Text as T import Data.Time.Clock (NominalDiffTime, UTCTime, addUTCTime) import Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds) import Data.Word (Word64) -import Network.HTTP.Client (defaultManagerSettings, newManager) +import Network.HTTP.Client (defaultManagerSettings, newManager, responseBody) import qualified Network.Wai.Handler.Warp as Warp import Simplex.Chat.PaymentService.Types (InvoiceId (..), InvoiceStatus (..)) import Simplex.Messaging.Agent.Store.Common (withTransaction) @@ -41,6 +41,7 @@ import Simplex.Messaging.Crypto (keccak256) import Simplex.Messaging.Crypto.Secp256k1 (Secp256k1PrivateKey, signRecoverable) import Simplex.Messaging.SimplexName (labelHash) import Simplex.Messaging.Util (tshow) +import StoreService.Config (NamesConfig) import StoreService.Names.Abi (abiBytes, abiTuple, addressWord, AbiValue (..), hex, selector, uint256) import StoreService.Names.Chain (Block (..), ChainClient, Receipt (..), TxHash (..), TxRequest (..), blockAt, decodeSignedTx, newChainClient) import StoreService.Names.Orders (Landing (..), OrdersEnv (..), confirmLanded) @@ -72,6 +73,7 @@ workerTests :: Spec workerTests = describe "StoreService names: worker" $ do describe "commit" $ do it "commits, waits for the reveal and revealAfter, and registers a code order, spending its code and publishing each change" testCommitWaitRegister + it "registers a code order with codes_only on, from the code check to the registered view, refusing a paid order" testCodesOnlyRegister it "waits for a pending commit without sending another, following its fee-bumped replacement" testPendingCommit it "goes to committed when the commit reverts UnexpiredCommitmentExists, in its dry run or mined, with the commitment's times" testUnexpiredCommitment it "sends a commit mined out of gas again" testCommitOutOfGas @@ -134,7 +136,12 @@ data W = W -- | The worker over the orders' store and fake node, with the registration poll and Try again as namesRoutes registers them. withWorker :: (W -> IO a) -> IO a -withWorker action = withOrders $ \ctx@Ctx {cNode, cOrders, cWeb} -> do +withWorker = withWorkerAs id + +-- | With the names settings changed, as the service reads them at startup. +withWorkerAs :: (NamesConfig -> NamesConfig) -> (W -> IO a) -> IO a +withWorkerAs settings action = withOrders $ \open -> do + let ctx@Ctx {cNode, cOrders, cWeb} = configured settings open answerCall cNode fakeController minCommitmentAgeCall $ Returns $ uint256 minAge answerCall cNode fakeController maxCommitmentAgeCall $ Returns $ uint256 maxAge answerUnowned ctx "alicebakery" @@ -284,8 +291,23 @@ nowOf Ctx {cClock} = readIORef cClock -- tests testCommitWaitRegister :: IO () -testCommitWaitRegister = withWorker $ \w@W {wCtx = ctx} -> do - (r, code) <- codeIn ctx 8 aliceOrder id +testCommitWaitRegister = withWorker $ \w@W {wCtx = ctx} -> codeIn ctx 8 aliceOrder id >>= commitWaitRegister w + +testCodesOnlyRegister :: IO () +testCodesOnlyRegister = withWorkerAs codesOnly $ \w@W {wCtx = ctx@Ctx {cClient}} -> do + (text, code) <- issueCode ctx 8 2 id + (status, coverage) <- post ctx "/api/code/check" (J.encode $ J.object ["code" J..= text]) + (status, field "state" =<< coverage) `shouldBe` (200, Just "unused") + placeOrder ctx aliceOrder `shouldReturn` refusedWith 403 "codes_only" + r <- registrationById ctx =<< registered ctx text aliceOrder + commitWaitRegister w (r, code) + (status', view) <- (statusOf &&& J.decode . responseBody) <$> webGet cClient (registrationPath $ nrId r) + (status', field "phase" =<< view) `shouldBe` (200, Just "registered") + stubCalls (cStub ctx) `shouldReturn` [] + +-- | A queued code order, committed, revealed and registered. +commitWaitRegister :: W -> (NameRegistration, PrepaidCode) -> IO () +commitWaitRegister w@W {wCtx = ctx} (r, code) = do answerExpiry ctx "alicebakery" expiry answerCommitment w r 0 void $ published w r $ steps w r >>= awaiting