store: refuse paid name orders when codes_only

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

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"

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 = "<!doctype html><meta name=\"simplex-names-mode\" content=\"open\">"
+  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 ->

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

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.

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