store: merge prepaid code orders

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

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}

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

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

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

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/<word> route, which it would otherwise match

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,
@@ -51,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
@@ -69,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
@@ -88,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
@@ -97,26 +110,25 @@ 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}
               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
               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
-              closedOrders 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
@@ -125,22 +137,76 @@ 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 >>= 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)
+      pure $ answerNow $ 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} -> 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
+      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 -> 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
+  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 +237,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

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

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
@@ -150,8 +150,14 @@ 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"
+    -- 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

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)
@@ -35,7 +35,10 @@ 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 (..))
 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,18 +53,24 @@ 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
-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)
 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 +99,22 @@ 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
+    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 "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 "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
     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 +161,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
@@ -266,9 +294,19 @@ withOrdersVia via action = withServiceStore $ \cStore -> withFakeEthNode $ \cNod
     built <- newWebEnv cStore cfg waiters hints [crypto, card] Nothing
     let cWeb = built {weOrders = Just cOrders}
     mgr <- newManager defaultManagerSettings
-    Warp.testWithApplicationSettings (webSettings (listener cfg)) (pure (webApp cWeb)) $ \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
+  ["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 +632,304 @@ 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)
+
+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
+  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
+
+-- | 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@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]
+  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
+
+-- | 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