store: merge prepaid name codes

apps/simplex-store-service/src/StoreService/Config.hs

@@ -17,6 +17,7 @@ module StoreService.Config
     ServiceConfig (..),
     defaultExpiryMinutes,
     defaultSessionMinutes,
+    minNameYears,
     readServiceConfig,
     unknownKeys,
   )

apps/simplex-store-service/src/StoreService/Group.hs

@@ -28,6 +28,7 @@ import StoreService.Codes (issueFailedText, issueOneCode, revokeBadgeCode, singl
 import StoreService.Config (GroupConfig (..))
 import StoreService.Group.Command (CmdAction (..), GroupCmd (..), groupCmdAction, groupCommands)
 import StoreService.Log (logError, logInfo, logWarn)
+import StoreService.Names.Codes (issueNameCode)
 import StoreService.Store (CodeTracker (..), ManagedGroup (..), RevokeResult (..), clearCodeGroupItems, getCodeTracker, getEditableTrackers, getManagedGroup, insertManagedGroup, markOwnerBootstrapped, setCodeGroupItem)
 import StoreService.Store.Invoices (truncateToSecond)
 import Control.Concurrent.STM (TQueue, atomically, flushTQueue, readTQueue, readTVarIO, writeTQueue)
@@ -46,7 +47,7 @@ import qualified Data.Text as T
 import Data.Time.Clock (NominalDiffTime, UTCTime, addUTCTime, diffUTCTime, getCurrentTime, nominalDay)
 import Data.Time.Format (defaultTimeLocale, formatTime)
 import GHC.Stack (HasCallStack, withFrozenCallStack)
-import Simplex.Chat.Badges.Code (BadgeCode, formatBadgeCode, parseBadgeCode)
+import Simplex.Chat.Badges.Code (BadgeCode, NameCode (..), formatBadgeCode, formatNameCode, parseBadgeCode)
 import Simplex.Chat.Badges.Types (BadgeCodePaymentStatus (..))
 import Simplex.Chat.Bot.Store (withDB')
 import Simplex.Chat.Controller
@@ -266,19 +267,21 @@ runGroupCmd cc groupId = \case
             now <- truncateToSecond <$> getCurrentTime
             sendGroupText cc groupId ("tracker, code " <> tshow badgeCodeId <> " is lost") (initialTrackerBody code uses)
               >>= mapM_ (\iid -> withDB' "setCodeGroupItem" cc $ \db -> setCodeGroupItem db badgeCodeId iid now)
-  GCBulk bt months count -> do
-    codes <- replicateM count (issueOneCode cc bt months CPSFree singleUse)
-    let (errs, ok) = partitionEithers codes
-        issued = map (formatBadgeCode . fst) ok
-    reply . T.intercalate "\n" $ case errs of
-      [] -> issued
-      _ : _ -> issued <> ["Issued " <> tshow (length issued) <> " of " <> tshow count <> " codes. The remaining codes could not be issued."]
+  GCBulk bt months count -> issueMany count (fmap (formatBadgeCode . fst) <$> issueOneCode cc bt months CPSFree singleUse)
+  GCIssueName len years ->
+    issueNameCode cc len years CPSFree >>= reply . either (const issueFailedText) (("Code: " <>) . formatNameCode . NCPrepaid)
+  GCBulkName len years count -> issueMany count (fmap (formatNameCode . NCPrepaid) <$> issueNameCode cc len years CPSFree)
   -- Naming the code tells concurrent revokes apart; the command already made it public.
   GCRevoke code -> do
     outcome <- either id id <$> revokeWithTracker cc code
     reply (formatBadgeCode code <> ": " <> outcome)
   where
     reply = void . sendGroupText cc groupId "reply, any codes in it are lost"
+    issueMany count issueOne = do
+      (errs, issued) <- partitionEithers <$> replicateM count issueOne
+      reply . T.intercalate "\n" $ case errs of
+        [] -> issued
+        _ : _ -> issued <> ["Issued " <> tshow (length issued) <> " of " <> tshow count <> " codes. The remaining codes could not be issued."]
 
 -- The label says what is lost when the send fails, since the log line is its only trace.
 sendGroupText :: HasCallStack => ChatController -> GroupId -> Text -> Text -> IO (Maybe ChatItemId)

apps/simplex-store-service/src/StoreService/Group/Command.hs

@@ -9,9 +9,11 @@ module StoreService.Group.Command
     groupCommands,
     codeP,
     badgeTypeP,
+    nameCodeP,
     textTokenP,
     maxMonths,
     maxUses,
+    maxNameYears,
   )
 where
 
@@ -26,20 +28,24 @@ import Data.Text (Text)
 import qualified Data.Text as T
 import Data.Text.Encoding (encodeUtf8)
 import Simplex.Chat.Badges (BadgeType (..))
-import Simplex.Chat.Badges.Code (BadgeCode, parseBadgeCode)
+import Simplex.Chat.Badges.Code (BadgeCode, maxNameLength, minNameLength, parseBadgeCode)
 import Simplex.Chat.Types.Preferences (ChatBotCommand (..))
 import Simplex.Chat.Types.Shared (GroupMemberRole (..))
 import Simplex.Messaging.Encoding.String (TextEncoding (..))
 import Simplex.Messaging.Util (safeDecodeUtf8)
+import StoreService.Config (minNameYears)
 
-maxBulk, maxUses, maxMonths :: Int
+maxBulk, maxUses, maxMonths, maxNameYears :: Int
 maxBulk = 100
 maxUses = 1000
 maxMonths = 255
+maxNameYears = 10
 
 data GroupCmd
   = GCIssue BadgeType Int Int
   | GCBulk BadgeType Int Int
+  | GCIssueName Int Int
+  | GCBulkName Int Int Int
   | GCRevoke BadgeCode
   deriving (Eq, Show)
 
@@ -68,13 +74,30 @@ cmdActionP = A.choice (map cmdP [minBound .. maxBound])
 
 cmdArgsP :: CmdTag -> A.Parser GroupCmd
 cmdArgsP = \case
-  CTIssue -> GCIssue <$> badgeTypeP <*> monthsOpt <*> keyOpt "uses" maxUses
-  CTBulk -> GCBulk <$> badgeTypeP <*> monthsOpt <*> (A.space *> keyValue "count" maxBulk)
+  CTIssue -> uncurry GCIssueName <$> nameCodeP <|> GCIssue <$> badgeTypeP <*> monthsOpt <*> keyOpt "uses" 1 maxUses
+  CTBulk -> uncurry GCBulkName <$> nameCodeP <*> countP <|> GCBulk <$> badgeTypeP <*> monthsOpt <*> countP
   CTRevoke -> GCRevoke <$> codeP
   where
-    monthsOpt = keyOpt "months" maxMonths
-    keyOpt kw hi = fromMaybe 1 <$> optional (A.space *> keyValue kw hi)
-    keyValue kw hi = A.string kw *> A.space *> boundedInt kw hi
+    monthsOpt = keyOpt "months" 1 maxMonths
+    countP = A.space *> keyValue "count" 1 maxBulk
+
+-- | The default is the lowest value.
+keyOpt :: ByteString -> Int -> Int -> A.Parser Int
+keyOpt kw lo hi = fromMaybe lo <$> optional (A.space *> keyValue kw lo hi)
+
+keyValue :: ByteString -> Int -> Int -> A.Parser Int
+keyValue kw lo hi = A.string kw *> A.space *> boundedInt kw lo hi
+
+-- | "name <length> [years <Y>]", the length and years of a prepaid name code.
+nameCodeP :: A.Parser (Int, Int)
+nameCodeP = "name " *> ((,) <$> nameLengthP <*> keyOpt "years" minNameYears maxNameYears)
+
+-- | A code's text carries the length as typed, so a leading zero is refused.
+nameLengthP :: A.Parser Int
+nameLengthP =
+  A.peekChar' >>= \case
+    '0' -> fail "leading zero in the name length"
+    _ -> boundedInt "length" minNameLength maxNameLength
 
 groupCommands :: [ChatBotCommand]
 groupCommands = map command [minBound .. maxBound]
@@ -85,10 +108,10 @@ codeP :: A.Parser BadgeCode
 codeP = A.takeWhile1 (not . isSpace) >>= maybe (fail "not a badge code") pure . parseBadgeCode . safeDecodeUtf8
 
 -- attoparsec's decimal wraps silently at Int, so the bound is checked on the wider Integer.
-boundedInt :: ByteString -> Int -> A.Parser Int
-boundedInt kw hi = do
+boundedInt :: ByteString -> Int -> Int -> A.Parser Int
+boundedInt kw lo hi = do
   n <- A.decimal :: A.Parser Integer
-  if n >= 1 && n <= fromIntegral hi
+  if n >= fromIntegral lo && n <= fromIntegral hi
     then pure (fromInteger n)
     else fail (B.unpack kw <> " out of range")
 
@@ -116,15 +139,15 @@ cmdName = \case
 
 cmdLabel :: CmdTag -> Text
 cmdLabel = \case
-  CTIssue -> "Generate a badge code"
+  CTIssue -> "Generate a badge or name code"
   CTBulk -> "Generate many single-use codes"
   CTRevoke -> "Revoke a code"
 
 -- | The parameters are quoted in the usage reply and advertised to the group, so the two cannot drift apart.
 cmdParams :: CmdTag -> Text
 cmdParams = \case
-  CTIssue -> "<type> [months <M>] [uses <N>]"
-  CTBulk -> "<type> [months <M>] count <B>"
+  CTIssue -> "<type> [months <M>] [uses <N>], or name <length> [years <Y>]"
+  CTBulk -> "<type> [months <M>] count <B>, or name <length> [years <Y>] count <B>"
   CTRevoke -> "<code>"
 
 cmdMinRole :: CmdTag -> GroupMemberRole

apps/simplex-store-service/src/StoreService/Names/Codes.hs

@@ -0,0 +1,152 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TupleSections #-}
+
+module StoreService.Names.Codes
+  ( CodeState (..),
+    codeState,
+    codeStateText,
+    CodeRefusal (..),
+    codeRefusal,
+    codeRefusalTag,
+    readPrepaidCode,
+    reserveCode,
+    releaseCode,
+    spendCode,
+    issueNameCode,
+    revokeNameCode,
+  )
+where
+
+import Control.Applicative ((<|>))
+import Data.ByteString (ByteString)
+import Data.Functor ((<&>))
+import Data.Int (Int64)
+import Data.Maybe (fromMaybe, isJust)
+import Data.Text (Text)
+import Data.Time.Clock (UTCTime, getCurrentTime)
+import Simplex.Chat.Badges.Code (NamePrepaidCode, namePrepaidCodeHash, randomNamePrepaidCode)
+import Simplex.Chat.Badges.Types (BadgeCodePaymentStatus (..))
+import Simplex.Chat.Bot.Store (withDB')
+import Simplex.Chat.Controller (ChatController (..))
+import Simplex.Messaging.Agent.Store.Common (DBStore, withTransaction)
+import qualified Simplex.Messaging.Agent.Store.DB as DB
+import StoreService.Names.Phases (RegistrationId)
+import StoreService.Names.Store (CodeHashTaken (..), NewPrepaidCode (..), PrepaidCode (..), getPrepaidCode, getPrepaidCodeById, insertPrepaidCode, releasePrepaidCode, reservePrepaidCode, revokePrepaidCode, spendPrepaidCode)
+import StoreService.Names.Turns (Turns, withCodeTurn)
+import StoreService.Store (RevokeResult (..))
+
+data CodeState = CSUnused | CSReserved | CSUsed | CSRevoked | CSExpired | CSUnpaid
+  deriving (Eq, Show, Enum, Bounded)
+
+-- | A code revoked while its order held it can still be spent by that order, so a spent code reads as used.
+codeState :: UTCTime -> PrepaidCode -> CodeState
+codeState now PrepaidCode {pcReservedBy, pcSpentAt, pcRevokedAt, pcPaymentStatus, pcExpiresAt}
+  | isJust pcSpentAt = CSUsed
+  | isJust pcRevokedAt = CSRevoked
+  | isJust pcReservedBy = CSReserved
+  | CPSUnpaid <- pcPaymentStatus = CSUnpaid
+  | maybe False (<= now) pcExpiresAt = CSExpired
+  | otherwise = CSUnused
+
+codeStateText :: CodeState -> Text
+codeStateText = \case
+  CSUnused -> "unused"
+  CSReserved -> "reserved"
+  CSUsed -> "used"
+  CSRevoked -> "revoked"
+  CSExpired -> "expired"
+  CSUnpaid -> "unpaid"
+
+data CodeRefusal = CRInvalid | CRUsed | CRReserved | CRExpired | CRPaymentPending | CRNotCovering
+  deriving (Eq, Show)
+
+codeRefusalTag :: CodeRefusal -> Text
+codeRefusalTag = \case
+  CRInvalid -> "code_invalid"
+  CRUsed -> "code_used"
+  CRReserved -> "code_reserved"
+  CRExpired -> "code_expired"
+  CRPaymentPending -> "payment_pending"
+  CRNotCovering -> "code_not_covering"
+
+-- | Why the code cannot pay for the registration's name of this length. A code the registration
+-- already holds stays good for it, even if revoked or expired since.
+codeRefusal :: UTCTime -> RegistrationId -> Int -> PrepaidCode -> Maybe CodeRefusal
+codeRefusal now rid len code@PrepaidCode {pcReservedBy, pcMinLength}
+  | pcReservedBy == Just rid = covering
+  | otherwise = stateRefusal (codeState now code) <|> covering
+  where
+    covering
+      | len < pcMinLength = Just CRNotCovering
+      | otherwise = Nothing
+
+stateRefusal :: CodeState -> Maybe CodeRefusal
+stateRefusal = \case
+  CSUnused -> Nothing
+  CSReserved -> Just CRReserved
+  CSUsed -> Just CRUsed
+  CSRevoked -> Just CRInvalid
+  CSExpired -> Just CRExpired
+  CSUnpaid -> Just CRPaymentPending
+
+readPrepaidCode :: DBStore -> NamePrepaidCode -> IO (Maybe PrepaidCode)
+readPrepaidCode st code = withTransaction st (`getPrepaidCode` namePrepaidCodeHash code)
+
+-- | In the code's turn and one transaction, the code is checked and reserved for the registration, then
+-- the write runs. A write that refuses gives the code back.
+reserveCode :: Turns -> DBStore -> UTCTime -> ByteString -> RegistrationId -> Int -> (DB.Connection -> IO (Either e a)) -> IO (Either CodeRefusal (Either e a))
+reserveCode turns st now codeHash rid len write =
+  withCodeTurn turns codeHash $ withTransaction st $ \db ->
+    getPrepaidCode db codeHash >>= \case
+      Nothing -> pure $ Left CRInvalid
+      Just code@PrepaidCode {pcId, pcReservedBy}
+        | Just refusal <- codeRefusal now rid len code -> pure $ Left refusal
+        | pcReservedBy == Just rid -> Right <$> write db
+        | otherwise ->
+            reservePrepaidCode db pcId rid now >>= \case
+              -- Only a change outside the code's turn, such as an operator's revoke, can refuse it here.
+              False -> Left . maybe CRInvalid (fromMaybe CRReserved . codeRefusal now rid len) <$> getPrepaidCode db codeHash
+              True ->
+                write db >>= \case
+                  refused@(Left _) -> Right refused <$ releasePrepaidCode db pcId rid
+                  written -> pure $ Right written
+
+-- | The write runs first, and the code is released only if it succeeds. False when the registration did not hold the code.
+releaseCode :: Turns -> DBStore -> Int64 -> RegistrationId -> (DB.Connection -> IO (Either e a)) -> IO (Either e (a, Bool))
+releaseCode turns st codeId rid = afterWrite turns st codeId (\db -> releasePrepaidCode db codeId rid)
+
+-- | The write runs first, and the code is spent only if it succeeds. False when the registration did not hold the code.
+spendCode :: Turns -> DBStore -> UTCTime -> Int64 -> RegistrationId -> (DB.Connection -> IO (Either e a)) -> IO (Either e (a, Bool))
+spendCode turns st now codeId rid = afterWrite turns st codeId (\db -> spendPrepaidCode db codeId rid now)
+
+afterWrite :: Turns -> DBStore -> Int64 -> (DB.Connection -> IO Bool) -> (DB.Connection -> IO (Either e a)) -> IO (Either e (a, Bool))
+afterWrite turns st codeId change write = do
+  codeHash_ <- withTransaction st $ \db -> fmap pcCodeHash <$> getPrepaidCodeById db codeId
+  let run = withTransaction st $ \db -> write db >>= traverse (\a -> (a,) <$> change db)
+  maybe run (\codeHash -> withCodeTurn turns codeHash run) codeHash_
+
+-- | The code table keeps only the hash, so the caller must deliver the code. The length and years are checked by the command's parser.
+issueNameCode :: ChatController -> Int -> Int -> BadgeCodePaymentStatus -> IO (Either String NamePrepaidCode)
+issueNameCode cc len years paymentStatus = do
+  code <- randomNamePrepaidCode (random cc) len
+  now <- getCurrentTime
+  let new = NewPrepaidCode {npcCodeHash = namePrepaidCodeHash code, npcMinLength = len, npcYears = years, npcPaymentStatus = paymentStatus, npcExpiresAt = Nothing}
+  withDB' "issueNameCode" cc (\db -> insertPrepaidCode db new now) <&> \case
+    Right (Right _) -> Right code
+    Right (Left CodeHashTaken) -> Left "prepaid code hash taken"
+    Left e -> Left e
+
+-- | Left is a refusal or a failure; both sides are the text to show the operator.
+revokeNameCode :: ChatController -> NamePrepaidCode -> IO (Either Text Text)
+revokeNameCode cc code = do
+  now <- getCurrentTime
+  let codeHash = namePrepaidCodeHash code
+  withDB' "revokeNameCode" cc (\db -> (,) <$> revokePrepaidCode db codeHash now <*> getPrepaidCode db codeHash) <&> \case
+    Right (Revoked _, Just PrepaidCode {pcReservedBy = Just _}) -> Right "Revoked. The order holding it keeps it."
+    Right (Revoked _, _) -> Right "Revoked."
+    Right (AlreadyRevoked _, _) -> Right "Already revoked."
+    Right (AlreadyRedeemed, _) -> Left "Already used. It cannot be revoked."
+    Right (NoSuchCode, _) -> Left "No such code."
+    Left _ -> Left "The code could not be revoked."

apps/simplex-store-service/src/StoreService/Service.hs

@@ -20,9 +20,10 @@ where
 
 import StoreService.Catalog (defaultCatalog)
 import StoreService.Codes (issueFailedText, issueOneCode, singleUse)
-import StoreService.Config (BadgeIssuerKey (..), ChainConfig (..), NamesConfig (..), ServiceConfig (..), readServiceConfig)
+import StoreService.Config (BadgeIssuerKey (..), ChainConfig (..), NamesConfig (..), ServiceConfig (..), minNameYears, readServiceConfig)
 import StoreService.Group (GroupEvent, ensureManagedGroup, groupEvent, hasTracker, refreshTracker, revokeWithTracker, runGroupLane)
-import StoreService.Group.Command (badgeTypeP, codeP, maxMonths, textTokenP)
+import StoreService.Group.Command (badgeTypeP, codeP, maxMonths, maxNameYears, nameCodeP, textTokenP)
+import StoreService.Names.Codes (issueNameCode, revokeNameCode)
 import StoreService.Names.Env (NamesEnv, newNamesEnv)
 import StoreService.Options
 import StoreService.Poller (newPollerEnv, newReadHints, runPoller)
@@ -42,8 +43,9 @@ import qualified Data.Aeson as J
 import qualified Data.Aeson.KeyMap as KM
 import qualified Data.Attoparsec.ByteString.Char8 as A
 import Data.ByteString.Char8 (ByteString)
+import Data.Char (isSpace)
 import Data.Either (fromRight)
-import Data.Functor (($>), (<&>))
+import Data.Functor (($>))
 import qualified Data.Map.Strict as M
 import Data.Maybe (fromMaybe, isJust, maybeToList)
 import qualified Data.Text as T
@@ -212,18 +214,44 @@ badgeCmdHook cc = \case
 runBadgeCmd :: ChatController -> ByteString -> IO (Either ChatError ChatResponse)
 runBadgeCmd cc cmd
   | Right issueOpts <- A.parseOnly issueCmdP cmd =
-      issueBadgeCode cc issueOpts >>= \case
-        Right code -> pure $ Right CRCustomChatResponse {user_ = Nothing, response = "Code: " <> formatBadgeCode code}
-        Left _ -> pure $ chatCmdError (T.unpack issueFailedText)
-  | Right code <- A.parseOnly revokeCmdP cmd =
-      revokeWithTracker cc code <&> \case
-        Right response -> Right CRCustomChatResponse {user_ = Nothing, response}
-        Left e -> chatCmdError (T.unpack e)
-  | otherwise = pure $ chatCmdError $ "Usage: //issue supporter|legend|investor [months 1-" <> show maxMonths <> "] [paid|unpaid|free], or //revoke <code>"
+      issuedReply formatBadgeCode <$> issueBadgeCode cc issueOpts
+  | Right (len, years, paymentStatus) <- A.parseOnly issueNameCmdP cmd =
+      issuedReply (formatNameCode . NCPrepaid) <$> issueNameCode cc len years paymentStatus
+  | Right code <- A.parseOnly revokeCmdP cmd = revokedReply <$> revokeWithTracker cc code
+  | Right code <- A.parseOnly revokeNameCmdP cmd = revokedReply <$> revokeNameCode cc code
+  | otherwise =
+      pure $ chatCmdError $
+        "Usage: //issue supporter|legend|investor [months 1-" <> show maxMonths <> "] [paid|unpaid|free], //issue name <length "
+          <> show minNameLength <> "-" <> show maxNameLength <> "> [years " <> show minNameYears <> "-" <> show maxNameYears
+          <> "] [paid|unpaid|free], or //revoke <code>"
+  where
+    issuedReply :: (c -> T.Text) -> Either String c -> Either ChatError ChatResponse
+    issuedReply format = \case
+      Right code -> Right CRCustomChatResponse {user_ = Nothing, response = "Code: " <> format code}
+      Left _ -> chatCmdError (T.unpack issueFailedText)
+    revokedReply = \case
+      Right response -> Right CRCustomChatResponse {user_ = Nothing, response}
+      Left e -> chatCmdError (T.unpack e)
 
 revokeCmdP :: A.Parser BadgeCode
 revokeCmdP = "revoke " *> codeP <* (A.skipSpace *> A.endOfInput)
 
+revokeNameCmdP :: A.Parser NamePrepaidCode
+revokeNameCmdP = "revoke " *> prepaidCodeP <* (A.skipSpace *> A.endOfInput)
+  where
+    prepaidCodeP =
+      parseNameCode . safeDecodeUtf8 <$> A.takeWhile1 (not . isSpace) >>= \case
+        Just (NCPrepaid code) -> pure code
+        _ -> fail "not a prepaid name code"
+
+issueNameCmdP :: A.Parser (Int, Int, BadgeCodePaymentStatus)
+issueNameCmdP = do
+  (len, years) <- "issue " *> nameCodeP
+  paymentStatus <- fromMaybe CPSFree <$> optional (A.space *> textTokenP)
+  A.skipSpace
+  A.endOfInput
+  pure (len, years, paymentStatus)
+
 issueCmdP :: A.Parser IssueCodeOpts
 issueCmdP =
   "issue " *> do

apps/simplex-store-service/src/StoreService/Web/Names.hs

@@ -1,12 +1,15 @@
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
 
 module StoreService.Web.Names (Route (..), namesRoutes, namesApp) where
 
 import Data.Text (Text)
 import Network.HTTP.Types (Method)
 import Network.Wai (Request, ResponseReceived, pathInfo)
-import StoreService.Names.Env (NamesEnv)
-import StoreService.Web.Http (HttpEnv, Limit, Respond, limited, only)
+import StoreService.Names.Env (NamesEnv (..))
+import StoreService.Web.Http (HttpEnv, Limit, Respond, codeLimit, limited, only)
+import StoreService.Web.Names.Codes (codeCheckHandler)
 
 data Route = Route
   { rMethod :: Method,
@@ -15,7 +18,9 @@ data Route = Route
   }
 
 namesRoutes :: NamesEnv -> [Text] -> Maybe Route
-namesRoutes _ _ = Nothing
+namesRoutes NamesEnv {neStore} = \case
+  ["api", "code", "check"] -> Just Route {rMethod = "POST", rLimit = codeLimit, rHandler = codeCheckHandler neStore}
+  _ -> Nothing
 
 -- | Nothing for a path no route knows. The limit is taken only once the route and the method match.
 namesApp :: HttpEnv -> ([Text] -> Maybe Route) -> Request -> Respond -> Maybe (IO ResponseReceived)

apps/simplex-store-service/src/StoreService/Web/Names/Codes.hs

@@ -0,0 +1,47 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module StoreService.Web.Names.Codes (codeCheckHandler, codeRefusalResponse) where
+
+import Data.Aeson ((.=))
+import qualified Data.Aeson as J
+import qualified Data.Aeson.KeyMap as KM
+import qualified Data.ByteString.Lazy as LB
+import Data.Text (Text)
+import Data.Time.Clock (UTCTime, getCurrentTime)
+import Network.HTTP.Types (status200, status400, status409)
+import Network.Wai (Request, Response, ResponseReceived)
+import Simplex.Chat.Badges.Code (NameCode (..), parseNameCode)
+import Simplex.Messaging.Agent.Store.Common (DBStore)
+import StoreService.Names.Codes (CodeRefusal (..), codeRefusalTag, codeState, codeStateText, readPrepaidCode)
+import StoreService.Names.Store (PrepaidCode (..))
+import StoreService.Web.Http (Respond, badRequest, jsonError, jsonResponse, maxBodyBytes, readBoundedBody)
+
+-- | It names no registration, even for a reserved code: holding a code proves nothing about an order.
+codeCheckHandler :: DBStore -> Request -> Respond -> IO ResponseReceived
+codeCheckHandler st req respond =
+  readBoundedBody maxBodyBytes req >>= \case
+    Just body | Just text <- codeField body -> case parseNameCode text of
+      Just (NCPrepaid code) -> do
+        now <- getCurrentTime
+        readPrepaidCode st code >>= respond . maybe (codeRefusalResponse CRInvalid) (codeAnswer now)
+      _ -> respond $ codeRefusalResponse CRInvalid
+    _ -> respond badRequest
+
+codeField :: LB.ByteString -> Maybe Text
+codeField body = case J.decode body of
+  Just (J.Object o) | Just (J.String t) <- KM.lookup "code" o -> Just t
+  _ -> Nothing
+
+codeAnswer :: UTCTime -> PrepaidCode -> Response
+codeAnswer now code@PrepaidCode {pcMinLength, pcYears} =
+  jsonResponse status200 $ J.object ["minLength" .= pcMinLength, "years" .= pcYears, "state" .= codeStateText (codeState now code)]
+
+-- | Not 404 for an unknown code, which the page reads as not_found whatever the body.
+codeRefusalResponse :: CodeRefusal -> Response
+codeRefusalResponse refusal = jsonError status (codeRefusalTag refusal)
+  where
+    status = case refusal of
+      CRInvalid -> status400
+      _ -> status409

simplex-chat.cabal

@@ -444,6 +444,7 @@ executable simplex-store-service
       StoreService.Log
       StoreService.Names.Abi
       StoreService.Names.Chain
+      StoreService.Names.Codes
       StoreService.Names.Env
       StoreService.Names.Label
       StoreService.Names.Links
@@ -467,6 +468,7 @@ executable simplex-store-service
       StoreService.Waiters
       StoreService.Web.Http
       StoreService.Web.Names
+      StoreService.Web.Names.Codes
       StoreService.Web.Server
       Paths_simplex_chat
   ghc-options: -O2 -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-missing-kind-signatures -Wno-missing-deriving-strategies -Wno-monomorphism-restriction -Wno-prepositive-qualified-module -Wno-unused-packages -Wno-implicit-prelude -Wno-missing-safe-haskell-mode -Wno-missing-export-lists -Wno-partial-fields -Wcompat -Werror=incomplete-record-updates -Werror=incomplete-patterns -Werror=missing-methods -Werror=incomplete-uni-patterns -Werror=tabs -Wredundant-constraints -Wincomplete-record-updates -Wunused-type-patterns -Werror=name-shadowing -threaded -rtsopts
@@ -753,6 +755,7 @@ test-suite simplex-chat-test
       Bots.StoreService.GroupTests
       Bots.StoreService.NameRegistrationTests
       Bots.StoreService.NamesChainTests
+      Bots.StoreService.NamesCodesTests
       Bots.StoreService.NamesLabelTests
       Bots.StoreService.NamesLinksTests
       Bots.StoreService.NamesProfilesTests
@@ -782,6 +785,7 @@ test-suite simplex-chat-test
       StoreService.Log
       StoreService.Names.Abi
       StoreService.Names.Chain
+      StoreService.Names.Codes
       StoreService.Names.Env
       StoreService.Names.Label
       StoreService.Names.Links
@@ -805,6 +809,7 @@ test-suite simplex-chat-test
       StoreService.Waiters
       StoreService.Web.Http
       StoreService.Web.Names
+      StoreService.Web.Names.Codes
       StoreService.Web.Server
       Paths_simplex_chat
   if flag(client_postgres)

tests/Bots/StoreService/BotTests.hs

@@ -1590,4 +1590,4 @@ testRevokeRejectsTrailingInput ps =
 
 -- The text is spelled out rather than taken from the service, so a change there fails here.
 badgeCmdUsage :: Text
-badgeCmdUsage = "Usage: //issue supporter|legend|investor [months 1-255] [paid|unpaid|free], or //revoke <code>"
+badgeCmdUsage = "Usage: //issue supporter|legend|investor [months 1-255] [paid|unpaid|free], //issue name <length 6-63> [years 2-10] [paid|unpaid|free], or //revoke <code>"

tests/Bots/StoreService/GroupIntegrationTests.hs

@@ -5,18 +5,22 @@
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
 
 -- Members' messages reach a console over separate connections in no fixed order, so gating is asserted from the bot's store.
-module Bots.StoreService.GroupIntegrationTests (badgeGroupIntegrationTests, namesBootTests) where
+module Bots.StoreService.GroupIntegrationTests (badgeGroupIntegrationTests, namesBootTests, namesCodesChatTests) where
 
 import StoreService.Config (BadgeIssuerKey (..), GroupConfig (..))
 import StoreService.Group (GroupAction (..), GroupEvent (..), codeInTracker, ensureManagedGroup)
 import StoreService.Group.Command (maxUses)
+import StoreService.Names.Phases (RegistrationId (..))
+import StoreService.Names.Store (PrepaidCode (..), getPrepaidCode, spendPrepaidCode)
 import StoreService.Options (StoreServiceOpts (..))
 import StoreService.Service (ServiceState (..), storeService, newServiceState)
 import StoreService.Store (ManagedGroup (..), getManagedGroup)
-import Bots.StoreService.BotTests (badgeBotName, badgeProfile, badgeTypeOf, credentialOf, entryOf, issueCode, issueRaw, mkStoreServiceOpts, newPurchaseKeys, redeemWithQueue, requestObject, revokeRaw, serviceDbPrefix, shouldAnswerError, statementOf, stopStoreService, testIssuerKeyIdx)
+import Bots.StoreService.BotTests (badgeBotName, badgeCmdUsage, badgeProfile, badgeTypeOf, credentialOf, entryOf, issueCode, issueRaw, mkStoreServiceOpts, newPurchaseKeys, redeemWithQueue, requestObject, revokeRaw, serviceDbPrefix, shouldAnswerError, statementOf, stopStoreService, testIssuerKeyIdx)
 import Bots.StoreService.ConfigTests (chainSection, namesSection)
+import Bots.StoreService.NamesStoreTests (order, ownerA, placeCode)
 import ChatClient
 import ChatTests.DBUtils
 import ChatTests.Utils
@@ -25,6 +29,7 @@ import Control.Concurrent.Async (Async, async, cancel, poll, waitCatchSTM)
 import Control.Concurrent.STM (TQueue, atomically, newTQueueIO, orElse, readTMVar, readTQueue, readTVarIO, tryReadTMVar, writeTQueue)
 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 Data.Either (isRight)
 import Data.Int (Int64)
 import Data.List (isInfixOf)
@@ -37,14 +42,15 @@ import qualified Data.Text as T
 import Data.Text.Encoding (encodeUtf8)
 import Data.Time.Calendar (fromGregorian)
 import Data.Time.Clock (NominalDiffTime, UTCTime (..), addUTCTime, getCurrentTime)
-import Network.HTTP.Client (defaultManagerSettings, httpLbs, newManager, parseRequest, responseStatus)
+import Network.HTTP.Client (RequestBody (..), defaultManagerSettings, httpLbs, method, newManager, parseRequest, requestBody, responseBody, responseStatus)
 import Network.HTTP.Types.Status (statusCode)
 import Network.Socket (Family (..), SockAddr (..), SocketType (..), close, connect, defaultProtocol, socket, tupleToHostAddress)
 import Network.Wai.Handler.Warp (openFreePort)
 import Simplex.Chat.Badges (BadgeType (..))
-import Simplex.Chat.Badges.Code (formatBadgeCode, parseBadgeCode, randomBadgeCode)
+import Simplex.Chat.Badges.Code (NameCode (..), NamePrepaidCode, formatBadgeCode, formatNameCode, namePrepaidCodeHash, namePrepaidCodeLength, parseBadgeCode, parseNameCode, randomBadgeCode, randomNamePrepaidCode)
+import Simplex.Chat.Badges.Types (BadgeCodePaymentStatus (..))
 import Simplex.Chat.StoreService
-import Simplex.Chat.Controller (ChatCommand (APIDeleteChatItem), ChatConfig (..), ChatController (..), ChatResponse (CRChatItemsDeleted))
+import Simplex.Chat.Controller (ChatCommand (APIDeleteChatItem), ChatConfig (..), ChatController (..), ChatResponse (CRChatItemsDeleted, CRCustomChatResponse))
 import Simplex.Chat.Core (sendChatCmd, sendChatCmdStr)
 import Simplex.Chat.Messages (ChatRef (ChatRef), ChatType (CTGroup))
 import Simplex.Chat.Messages.CIContent (CIDeleteMode (CIDMInternal))
@@ -55,6 +61,7 @@ import Simplex.Messaging.Agent (disposeAgentClient)
 import Simplex.Messaging.Agent.Protocol (AConnShortLink (..), ConnShortLink (..), ContactConnType (..))
 import Simplex.Messaging.Agent.Store.Common (withTransaction)
 import qualified Simplex.Messaging.Agent.Store.DB as DB
+import qualified Simplex.Messaging.Crypto as C
 import Simplex.Messaging.Crypto.BBS (bbsKeyGen)
 import Simplex.Messaging.Encoding.String (strDecode)
 import Simplex.Messaging.Util (tshow)
@@ -136,6 +143,84 @@ testNamesBoot ps = do
     statusCode . responseStatus <$> httpLbs req mgr `shouldReturn` 404
     poll t >>= (`shouldSatisfy` isNothing)
 
+namesCodesChatTests :: SpecWith TestParams
+namesCodesChatTests = describe "StoreService names: prepaid codes" $ do
+  it "issues prepaid codes on /issue name and /bulk name, answering the usage to years below 2" testGroupNameCodes
+  it "issues prepaid codes on //issue name, checks them through the names router and revokes them on //revoke" testOperatorNameCodes
+
+testGroupNameCodes :: HasCallStack => TestParams -> IO ()
+testGroupNameCodes ps =
+  withGroupOwner ps $ \_ 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)
+    bulk <- mapM (prepaidIn . Just) . T.lines =<< replyTo cc alice "/bulk name 6 count 3"
+    length bulk `shouldBe` 3
+    forM_ bulk $ \code -> (namePrepaidCodeLength code,) <$> prepaidTerms cc code `shouldReturn` (6, Just (6, 2, CPSFree))
+    replyTo cc alice "/issue name 8 years 1" `shouldReturn` "Usage: /issue <type> [months <M>] [uses <N>], or name <length> [years <Y>]"
+    countRows cc "sx_badge_service_name_prepaid_codes" `shouldReturn` 4
+
+testOperatorNameCodes :: HasCallStack => TestParams -> IO ()
+testOperatorNameCodes ps = do
+  svc <- prepareGroupService ps
+  (t, cc, _, port) <- startGroupService svc {gsIniSections = "" : namesSection <> 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 ->
+      (args,) <$> issueRaw cc args `shouldReturn` (args, Left badgeCmdUsage)
+    countRows cc "sx_badge_service_name_prepaid_codes" `shouldReturn` 0
+    paid <- issueNameRaw cc "name 7 years 3 paid"
+    unpaid <- issueNameRaw cc "name 6 unpaid"
+    prepaidTerms cc paid `shouldReturn` Just (7, 3, CPSPaid)
+    prepaidTerms cc unpaid `shouldReturn` Just (6, 2, CPSUnpaid)
+    let check code = checkPrepaid port (formatNameCode (NCPrepaid code))
+        coverage :: Int -> Int -> Text -> (Int, Maybe J.Value)
+        coverage minLength years state = (200, Just $ J.object ["minLength" J..= minLength, "years" J..= years, "state" J..= state])
+        revoke = revokeRaw cc . formatNameCode . NCPrepaid
+    check paid `shouldReturn` coverage 7 3 "unused"
+    check unpaid `shouldReturn` coverage 6 2 "unpaid"
+    revokeRaw cc (formatNameCode (NCPrepaid paid) <> " junk") `shouldReturn` Left badgeCmdUsage
+    revoke paid `shouldReturn` Right "Revoked."
+    revoke paid `shouldReturn` Right "Already revoked."
+    check paid `shouldReturn` coverage 7 3 "revoked"
+    unknown <- C.newRandom >>= (`randomNamePrepaidCode` 7)
+    revoke unknown `shouldReturn` Left "No such code."
+    held <- issueNameRaw cc "name 8"
+    spent <- issueNameRaw cc "name 8"
+    let st = chatStore cc
+        rowOf code = fromMaybe (error "no prepaid code row") <$> withTransaction st (`getPrepaidCode` namePrepaidCodeHash code)
+    rowOf held >>= placeCode st "r1" ownerA (order "alicebakery" 1) >>= (`shouldBe` Right ())
+    rowOf spent >>= placeCode st "r2" ownerA (order "bobsbakery" 2) >>= (`shouldBe` Right ())
+    spentAt <- getCurrentTime
+    PrepaidCode {pcId = spentId} <- rowOf spent
+    withTransaction st (\db -> spendPrepaidCode db spentId (RegistrationId "r2") spentAt) `shouldReturn` True
+    revoke held `shouldReturn` Right "Revoked. The order holding it keeps it."
+    revoke spent `shouldReturn` Left "Already used. It cannot be revoked."
+    check spent `shouldReturn` coverage 8 2 "used"
+
+issueNameRaw :: HasCallStack => ChatController -> String -> IO NamePrepaidCode
+issueNameRaw cc args =
+  sendChatCmdStr cc ("//issue " <> args) >>= \case
+    Right (CRCustomChatResponse _ response) -> prepaidIn (T.stripPrefix "Code: " response)
+    r -> error $ "issue failed: " <> show (() <$ r)
+
+prepaidIn :: HasCallStack => Maybe Text -> IO NamePrepaidCode
+prepaidIn t = case parseNameCode =<< t of
+  Just (NCPrepaid code) -> pure code
+  _ -> error $ "no prepaid name code in: " <> show t
+
+prepaidTerms :: ChatController -> NamePrepaidCode -> IO (Maybe (Int, Int, BadgeCodePaymentStatus))
+prepaidTerms cc code =
+  fmap (\PrepaidCode {pcMinLength, pcYears, pcPaymentStatus} -> (pcMinLength, pcYears, pcPaymentStatus))
+    <$> withTransaction (chatStore cc) (`getPrepaidCode` namePrepaidCodeHash code)
+
+checkPrepaid :: Int -> Text -> IO (Int, Maybe J.Value)
+checkPrepaid port code = do
+  mgr <- newManager defaultManagerSettings
+  req <- parseRequest $ "http://127.0.0.1:" <> show port <> "/api/code/check"
+  r <- httpLbs req {method = "POST", requestBody = RequestBodyLBS (J.encode (J.object ["code" J..= code]))} mgr
+  pure (statusCode (responseStatus r), J.decode (responseBody r))
+
 groupName :: String
 groupName = "testbadges"
 
@@ -513,7 +598,7 @@ testRoleGatedIssue ps = do
         waitStoredItem cc "/issue legend"
         ownerIssuesNext cc alice 2
         sendGroupCmd alice "/issue supporter uses 0"
-        waitStoredItem cc "Usage: /issue <type> [months <M>] [uses <N>]"
+        waitStoredItem cc "Usage: /issue <type> [months <M>] [uses <N>], or name <length> [years <Y>]"
         codeCount cc `shouldReturn` 2
         drainUntil alice [usageReply, newMember "bob", newMember "cath"]
         drainUntil bob [usageReply, preMember "alice", newMember "cath"]
@@ -1130,8 +1215,8 @@ singleRow sql = \case
 -- The list is spelled out rather than taken from the service, so a change there fails here.
 expectedCommands :: [ChatBotCommand]
 expectedCommands =
-  [ CBCCommand "issue" "Generate a badge code" (Just "<type> [months <M>] [uses <N>]"),
-    CBCCommand "bulk" "Generate many single-use codes" (Just "<type> [months <M>] count <B>"),
+  [ CBCCommand "issue" "Generate a badge or name code" (Just "<type> [months <M>] [uses <N>], or name <length> [years <Y>]"),
+    CBCCommand "bulk" "Generate many single-use codes" (Just "<type> [months <M>] count <B>, or name <length> [years <Y>] count <B>"),
     CBCCommand "revoke" "Revoke a code" (Just "<code>")
   ]
 

tests/Bots/StoreService/GroupTests.hs

@@ -22,8 +22,8 @@ import Test.Hspec
 badgeGroupTests :: Spec
 badgeGroupTests = describe "badge group" $ do
   let p = groupCmdAction GROwner
-      issueUsage = ReplyText "Usage: /issue <type> [months <M>] [uses <N>]"
-      bulkUsage = ReplyText "Usage: /bulk <type> [months <M>] count <B>"
+      issueUsage = ReplyText "Usage: /issue <type> [months <M>] [uses <N>], or name <length> [years <Y>]"
+      bulkUsage = ReplyText "Usage: /bulk <type> [months <M>] count <B>, or name <length> [years <Y>] count <B>"
       revokeUsage = ReplyText "Usage: /revoke <code>"
   it "issue defaults" $ p "/issue supporter" `shouldBe` RunCmd (GCIssue BTSupporter 1 1)
   it "issue with months and uses" $ p "/issue legend months 6 uses 50" `shouldBe` RunCmd (GCIssue BTLegend 6 50)

tests/Bots/StoreService/NamesCodesTests.hs

@@ -0,0 +1,347 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TupleSections #-}
+
+module Bots.StoreService.NamesCodesTests (namesCodesTests) where
+
+import Bots.StoreService.NamesStoreTests (order, ownerA, ownerB, placeCode, placePaid, usable)
+import Bots.StoreService.WebTests (withServiceStore)
+import Control.Arrow ((&&&))
+import Control.Concurrent (threadDelay)
+import Control.Concurrent.Async (concurrently)
+import Control.Monad (forM_, replicateM_)
+import qualified Data.Aeson as J
+import qualified Data.Aeson.KeyMap as KM
+import qualified Data.ByteString.Char8 as BC
+import qualified Data.ByteString.Lazy.Char8 as LB
+import Data.IORef (newIORef, readIORef, writeIORef)
+import Data.Maybe (fromJust, fromMaybe)
+import Data.Text (Text)
+import Data.Time.Calendar (fromGregorian)
+import Data.Time.Clock (UTCTime (..), addUTCTime, getCurrentTime)
+import Network.HTTP.Client (Manager, Response, RequestBody (..), defaultManagerSettings, httpLbs, method, newManager, parseRequest, requestBody, responseBody, responseHeaders, responseStatus)
+import Network.HTTP.Types (hContentType)
+import Network.HTTP.Types.Status (statusCode)
+import qualified Network.Wai.Handler.Warp as Warp
+import Simplex.Chat.Badges.Code (NameCode (..), NamePrepaidCode, formatNameCode, namePrepaidCodeHash, parseNameCode, randomNamePrepaidCode)
+import Simplex.Chat.Badges.Types (BadgeCodePaymentStatus (..))
+import Simplex.Chat.Types.Shared (GroupMemberRole (..))
+import Simplex.Messaging.Agent.Store.Common (DBStore, withTransaction)
+import qualified Simplex.Messaging.Agent.Store.DB as DB
+import qualified Simplex.Messaging.Crypto as C
+import StoreService.Config (ListenerConfig (..))
+import StoreService.Group.Command (CmdAction (..), GroupCmd (..), groupCmdAction)
+import StoreService.Names.Codes
+import StoreService.Names.Phases (RegistrationId (..))
+import StoreService.Names.Store (NewPrepaidCode (..), PrepaidCode (..), getPrepaidCode, insertPrepaidCode, revokePrepaidCode, spendPrepaidCode)
+import StoreService.Names.Turns (Turns, newTurns)
+import StoreService.Store (RevokeResult (..))
+import StoreService.Web.Http (codeLimit, newHttpEnv, notFound)
+import StoreService.Web.Names (Route (..), namesApp)
+import StoreService.Web.Names.Codes (codeCheckHandler)
+import Test.Hspec
+
+namesCodesTests :: Spec
+namesCodesTests = describe "StoreService names: prepaid codes" $ do
+  describe "state" $
+    it "reads each state from the code's row, a spent code as used even if revoked while held" testCodeStates
+  describe "check" $ do
+    it "answers each state with what the code covers, and changes no code" testCheckStates
+    it "folds a code typed in lower case with spaces to the issued one" testCheckFolded
+    it "answers code_invalid to an unknown, mistyped, zero-padded, owner or badge code" testCheckInvalid
+    it "answers bad_request to a body that is not an object with a code text, and 405 to GET" testCheckBadBody
+    it "takes a code token for every check, whatever its outcome" testCheckLimit
+  describe "reservations" $ do
+    it "reserves an unused code in the transaction of the registration's write" testReserve
+    it "refuses each unusable code with its tag, before the write runs" testReserveRefusals
+    it "keeps a code its registration holds even if revoked or expired since, still checking the length" testReserveHeld
+    it "gives the code back when the write refuses" testReserveWriteRefused
+    it "lets one of two concurrent reservations of a code win, the other answered code_reserved" testConcurrentReserve
+    it "releases and spends a code only after the write, and only for its holder" testReleaseSpend
+  describe "group commands" $ do
+    it "parses /issue name and /bulk name with the length, years and count" testGroupNameCommands
+    it "answers the usage to a length outside 6-63 or with a leading zero, and to years outside 2-10" testGroupNameCommandsRefused
+
+r1, r2 :: RegistrationId
+r1 = RegistrationId "r1"
+r2 = RegistrationId "r2"
+
+tNow :: UTCTime
+tNow = UTCTime (fromGregorian 2026 10 21) 3600
+
+baseCode :: PrepaidCode
+baseCode =
+  PrepaidCode
+    { pcId = 1,
+      pcCodeHash = "",
+      pcMinLength = 8,
+      pcYears = 2,
+      pcPaymentStatus = CPSPaid,
+      pcReservedBy = Nothing,
+      pcReservedAt = Nothing,
+      pcSpentAt = Nothing,
+      pcRevokedAt = Nothing,
+      pcExpiresAt = Nothing,
+      pcCreatedAt = tNow
+    }
+
+testCodeStates :: IO ()
+testCodeStates = do
+  let stateOf = codeState tNow
+      held = baseCode {pcReservedBy = Just r1, pcReservedAt = Just tNow}
+      revoked = Just tNow
+  map codeStateText [minBound .. maxBound] `shouldBe` ["unused", "reserved", "used", "revoked", "expired", "unpaid"]
+  stateOf baseCode `shouldBe` CSUnused
+  stateOf baseCode {pcPaymentStatus = CPSFree, pcExpiresAt = Just (addUTCTime 1 tNow)} `shouldBe` CSUnused
+  stateOf held `shouldBe` CSReserved
+  stateOf held {pcSpentAt = Just tNow} `shouldBe` CSUsed
+  stateOf held {pcSpentAt = Just tNow, pcRevokedAt = revoked} `shouldBe` CSUsed
+  stateOf baseCode {pcRevokedAt = revoked} `shouldBe` CSRevoked
+  stateOf held {pcRevokedAt = revoked} `shouldBe` CSRevoked
+  stateOf baseCode {pcPaymentStatus = CPSUnpaid} `shouldBe` CSUnpaid
+  stateOf baseCode {pcPaymentStatus = CPSUnpaid, pcExpiresAt = Just tNow} `shouldBe` CSUnpaid
+  stateOf baseCode {pcExpiresAt = Just tNow} `shouldBe` CSExpired
+  stateOf held {pcExpiresAt = Just tNow} `shouldBe` CSReserved
+
+-- The route as namesRoutes registers it, since a NamesEnv needs a running chat controller.
+withCodeCheck :: (DBStore -> Client -> IO a) -> IO a
+withCodeCheck action = withServiceStore $ \st -> do
+  http <- newHttpEnv ListenerConfig {lHost = "127.0.0.1", lPort = 0, lStaticDir = "", lServeWebapp = False, lWebappExportDir = Nothing, lTrustForwardedFor = False, lNamesStaticDir = Nothing, lNamesExportDir = Nothing, lNamesHosts = []}
+  let routes = \case
+        ["api", "code", "check"] -> Just Route {rMethod = "POST", rLimit = codeLimit, rHandler = codeCheckHandler st}
+        _ -> Nothing
+      app req respond = fromMaybe (respond notFound) (namesApp http routes req respond)
+  mgr <- newManager defaultManagerSettings
+  Warp.testWithApplication (pure app) $ \port -> action st (mgr, "http://127.0.0.1:" <> show port)
+
+type Client = (Manager, String)
+
+postCheck :: Client -> LB.ByteString -> IO (Response LB.ByteString)
+postCheck (mgr, base) body = do
+  req <- parseRequest (base <> "/api/code/check")
+  httpLbs req {method = "POST", requestBody = RequestBodyLBS body} mgr
+
+checkText :: Client -> Text -> IO (Response LB.ByteString)
+checkText client code = postCheck client (J.encode (J.object ["code" J..= code]))
+
+checkCode :: Client -> NamePrepaidCode -> IO (Response LB.ByteString)
+checkCode client = checkText client . formatNameCode . NCPrepaid
+
+answerOf :: Response LB.ByteString -> (Int, Maybe J.Object)
+answerOf r = (statusCode (responseStatus r), J.decode (responseBody r))
+
+coverage :: Int -> Int -> Text -> (Int, Maybe J.Object)
+coverage minLength years state = (200, Just $ KM.fromList [("minLength", J.toJSON minLength), ("years", J.toJSON years), ("state", J.String state)])
+
+refused :: Int -> Text -> (Int, Maybe J.Object)
+refused status tag = (status, Just $ KM.fromList [("error", J.String tag)])
+
+newCode :: Int -> IO NamePrepaidCode
+newCode len = C.newRandom >>= (`randomNamePrepaidCode` len)
+
+issueAs :: DBStore -> NamePrepaidCode -> NewPrepaidCode -> IO PrepaidCode
+issueAs st code new = withTransaction st $ \db -> do
+  Right _ <- insertPrepaidCode db new {npcCodeHash = namePrepaidCodeHash code} tNow
+  fromJust <$> getPrepaidCode db (namePrepaidCodeHash code)
+
+readCode :: DBStore -> PrepaidCode -> IO (Maybe PrepaidCode)
+readCode st PrepaidCode {pcCodeHash} = withTransaction st (`getPrepaidCode` pcCodeHash)
+
+testCheckStates :: IO ()
+testCheckStates = withCodeCheck $ \st client -> do
+  now <- getCurrentTime
+  [unused, reserved, used, revoked, expired, unpaid] <- mapM newCode [8, 6, 7, 9, 12, 63]
+  unusedRow <- issueAs st unused usable {npcYears = 5, npcExpiresAt = Just (addUTCTime 3600 now)}
+  reservedRow <- issueAs st reserved usable {npcMinLength = 6}
+  usedRow <- issueAs st used usable {npcMinLength = 7}
+  revokedRow <- issueAs st revoked usable {npcMinLength = 9, npcPaymentStatus = CPSFree}
+  expiredRow <- issueAs st expired usable {npcMinLength = 12, npcExpiresAt = Just (addUTCTime (-60) now)}
+  unpaidRow <- issueAs st unpaid usable {npcMinLength = 63, npcYears = 10, npcPaymentStatus = CPSUnpaid}
+  placeCode st "r1" ownerA (order "alicebakery" 1) reservedRow `shouldReturn` Right ()
+  placeCode st "r2" ownerA (order "bobsbakery" 2) usedRow `shouldReturn` Right ()
+  withTransaction st (\db -> spendPrepaidCode db (pcId usedRow) r2 tNow) `shouldReturn` True
+  withTransaction st (\db -> revokePrepaidCode db (pcCodeHash revokedRow) tNow) `shouldReturn` Revoked (pcId revokedRow)
+  let rows = [unusedRow, reservedRow, usedRow, revokedRow, expiredRow, unpaidRow]
+  rowsBefore <- mapM (readCode st) rows
+  answerOf <$> checkCode client unused `shouldReturn` coverage 8 5 "unused"
+  answerOf <$> checkCode client reserved `shouldReturn` coverage 6 2 "reserved"
+  answerOf <$> checkCode client used `shouldReturn` coverage 7 2 "used"
+  answerOf <$> checkCode client revoked `shouldReturn` coverage 9 2 "revoked"
+  answerOf <$> checkCode client expired `shouldReturn` coverage 12 2 "expired"
+  answerOf <$> checkCode client unpaid `shouldReturn` coverage 63 10 "unpaid"
+  mapM (readCode st) rows `shouldReturn` rowsBefore
+
+-- The webapp's and core's vector: these two spellings are one code.
+testCheckFolded :: IO ()
+testCheckFolded = withCodeCheck $ \st client -> do
+  Just (NCPrepaid code) <- pure $ parseNameCode "SN7-BJTBP-29596-R3HJ8-25YM7"
+  _ <- issueAs st code usable {npcMinLength = 7}
+  answerOf <$> checkText client "sn7 bjtbp 29596 r3hj8 25ym7" `shouldReturn` coverage 7 2 "unused"
+
+testCheckInvalid :: IO ()
+testCheckInvalid = withCodeCheck $ \st client -> do
+  Just (NCPrepaid issued) <- pure $ parseNameCode "SN7-BJTBP-29596-R3HJ8-25YM7"
+  _ <- issueAs st issued usable {npcMinLength = 7}
+  unknown <- newCode 8
+  let invalid = refused 400 "code_invalid"
+  answerOf <$> checkCode client unknown `shouldReturn` invalid
+  forM_
+    [ "SN7-BJTBP-29596-R3HJ8-25YM8",
+      "SN07-BJTBP-29596-R3HJ8-25YM7",
+      "SN-DWPHS-6JBFR-ZR1MA-T5HQ9-P17QM-F5GM5",
+      "SB-00000-00000-00000-00000",
+      "alicebakery",
+      ""
+    ]
+    $ \text -> (text,) . answerOf <$> checkText client text `shouldReturn` (text, invalid)
+
+testCheckBadBody :: IO ()
+testCheckBadBody = withCodeCheck $ \_ client@(mgr, base) -> do
+  let badRequest = refused 400 "bad_request"
+  forM_ ["", "not json", "[\"SN7-BJTBP-29596-R3HJ8-25YM7\"]", "{}", "{\"code\": 7}", "{\"code\": null}"] $ \body ->
+    (body,) . answerOf <$> postCheck client body `shouldReturn` (body, badRequest)
+  let overCap = "{\"code\": \"SN7-BJTBP-29596-R3HJ8-25YM7\", \"pad\": \"" <> LB.replicate 8192 'x' <> "\"}"
+  answerOf <$> postCheck client overCap `shouldReturn` badRequest
+  req <- parseRequest (base <> "/api/code/check")
+  r <- httpLbs req mgr
+  statusCode (responseStatus r) `shouldBe` 405
+  lookup "Allow" (responseHeaders r) `shouldBe` Just "POST"
+  lookup hContentType (responseHeaders r) `shouldBe` Just "application/json"
+
+testCheckLimit :: IO ()
+testCheckLimit = withCodeCheck $ \st client -> do
+  issued <- newCode 8
+  _ <- issueAs st issued usable
+  unknown <- newCode 8
+  replicateM_ 5 $ checkCode client issued >>= (`shouldBe` 200) . fst . answerOf
+  replicateM_ 4 $ checkCode client unknown >>= (`shouldBe` 400) . fst . answerOf
+  postCheck client "{}" >>= (`shouldBe` 400) . fst . answerOf
+  limited <- checkCode client issued
+  answerOf limited `shouldBe` refused 429 "rate_limited"
+  lookup "Retry-After" (responseHeaders limited) `shouldSatisfy` maybe False (BC.all (`elem` ['0' .. '9']))
+
+-- | Two paid orders, so a code can be reserved for either.
+withOrders :: (Turns -> DBStore -> IO a) -> IO a
+withOrders action = withServiceStore $ \st -> do
+  placePaid st "r1" ownerA (order "alicebakery" 1) tNow `shouldReturn` Right ()
+  placePaid st "r2" ownerB (order "bobsbakery" 2) tNow `shouldReturn` Right ()
+  turns <- newTurns
+  action turns st
+
+writeOk :: DB.Connection -> IO (Either Text ())
+writeOk _ = pure $ Right ()
+
+testReserve :: IO ()
+testReserve = withOrders $ \turns st -> do
+  code <- newCode 8
+  PrepaidCode {pcCodeHash} <- issueAs st code usable
+  let holderInWrite db = Right . (pcReservedBy =<<) <$> getPrepaidCode db pcCodeHash :: IO (Either Text (Maybe RegistrationId))
+  reserveCode turns st tNow pcCodeHash r1 8 holderInWrite `shouldReturn` Right (Right (Just r1))
+  reserveCode turns st tNow pcCodeHash r1 11 holderInWrite `shouldReturn` Right (Right (Just r1))
+
+testReserveRefusals :: IO ()
+testReserveRefusals = withOrders $ \turns st -> do
+  [reserved, used, revoked, expired, unpaid, unknown, short] <- mapM newCode [8, 8, 8, 8, 8, 8, 8]
+  reservedRow <- issueAs st reserved usable
+  usedRow <- issueAs st used usable
+  revokedRow <- issueAs st revoked usable
+  expiredRow <- issueAs st expired usable {npcExpiresAt = Just tNow}
+  unpaidRow <- issueAs st unpaid usable {npcPaymentStatus = CPSUnpaid}
+  shortRow <- issueAs st short usable
+  placeCode st "r5" ownerA (order "erinsbakery" 5) reservedRow `shouldReturn` Right ()
+  placeCode st "r3" ownerB (order "carolsbakery" 4) usedRow `shouldReturn` Right ()
+  withTransaction st (\db -> spendPrepaidCode db (pcId usedRow) (RegistrationId "r3") tNow) `shouldReturn` True
+  withTransaction st (\db -> revokePrepaidCode db (pcCodeHash revokedRow) tNow) `shouldReturn` Revoked (pcId revokedRow)
+  wrote <- newIORef False
+  let reserve hash len = reserveCode turns st tNow hash r1 len (\_ -> Right () <$ writeIORef wrote True :: IO (Either Text ()))
+      rows = [reservedRow, usedRow, revokedRow, expiredRow, unpaidRow, shortRow]
+  rowsBefore <- mapM (readCode st) rows
+  reserve (pcCodeHash reservedRow) 8 `shouldReturn` Left CRReserved
+  reserve (pcCodeHash usedRow) 8 `shouldReturn` Left CRUsed
+  reserve (pcCodeHash revokedRow) 8 `shouldReturn` Left CRInvalid
+  reserve (pcCodeHash expiredRow) 8 `shouldReturn` Left CRExpired
+  reserve (pcCodeHash unpaidRow) 8 `shouldReturn` Left CRPaymentPending
+  reserve (namePrepaidCodeHash unknown) 8 `shouldReturn` Left CRInvalid
+  reserve (pcCodeHash shortRow) 7 `shouldReturn` Left CRNotCovering
+  reserve (pcCodeHash revokedRow) 7 `shouldReturn` Left CRInvalid
+  readIORef wrote `shouldReturn` False
+  mapM (readCode st) rows `shouldReturn` rowsBefore
+  map codeRefusalTag [CRInvalid, CRUsed, CRReserved, CRExpired, CRPaymentPending, CRNotCovering]
+    `shouldBe` ["code_invalid", "code_used", "code_reserved", "code_expired", "payment_pending", "code_not_covering"]
+
+testReserveHeld :: IO ()
+testReserveHeld = withOrders $ \turns st -> do
+  code <- newCode 8
+  row@PrepaidCode {pcCodeHash} <- issueAs st code usable
+  placeCode st "r3" ownerB (order "carolsbakery" 3) row `shouldReturn` Right ()
+  let r3 = RegistrationId "r3"
+  withTransaction st (\db -> revokePrepaidCode db pcCodeHash tNow) `shouldReturn` Revoked (pcId row)
+  withTransaction st $ \db -> DB.execute db "UPDATE sx_badge_service_name_prepaid_codes SET expires_at = ? WHERE code_hash = ?" (tNow, DB.Binary pcCodeHash)
+  held <- readCode st row
+  reserveCode turns st tNow pcCodeHash r3 9 writeOk `shouldReturn` Right (Right ())
+  reserveCode turns st tNow pcCodeHash r3 7 writeOk `shouldReturn` Left CRNotCovering
+  reserveCode turns st tNow pcCodeHash r1 9 writeOk `shouldReturn` Left CRInvalid
+  readCode st row `shouldReturn` held
+
+testReserveWriteRefused :: IO ()
+testReserveWriteRefused = withOrders $ \turns st -> do
+  code <- newCode 8
+  row@PrepaidCode {pcCodeHash} <- issueAs st code usable
+  reserveCode turns st tNow pcCodeHash r1 8 (\_ -> pure (Left "registration_changed" :: Either Text ())) `shouldReturn` Right (Left "registration_changed")
+  (pcReservedBy =<<) <$> readCode st row `shouldReturn` Nothing
+  reserveCode turns st tNow pcCodeHash r2 8 writeOk `shouldReturn` Right (Right ())
+  (pcReservedBy =<<) <$> readCode st row `shouldReturn` Just r2
+
+testConcurrentReserve :: IO ()
+testConcurrentReserve = withOrders $ \turns st -> do
+  code <- newCode 8
+  row@PrepaidCode {pcCodeHash} <- issueAs st code usable
+  let slowWrite _ = Right () <$ threadDelay 100000 :: IO (Either Text ())
+      reserveFor rid = reserveCode turns st tNow pcCodeHash rid 8 slowWrite
+  outcomes <- concurrently (reserveFor r1) (reserveFor r2)
+  outcomes `shouldSatisfy` (`elem` [(Right (Right ()), Left CRReserved), (Left CRReserved, Right (Right ()))])
+  holder <- (pcReservedBy =<<) <$> readCode st row
+  holder `shouldBe` Just (if fst outcomes == Right (Right ()) then r1 else r2)
+
+testReleaseSpend :: IO ()
+testReleaseSpend = withOrders $ \turns st -> do
+  [spent, released] <- mapM newCode [8, 8]
+  spentRow <- issueAs st spent usable
+  releasedRow <- issueAs st released usable
+  placeCode st "r3" ownerB (order "carolsbakery" 3) spentRow `shouldReturn` Right ()
+  placeCode st "r4" ownerB (order "davesbakery" 4) releasedRow `shouldReturn` Right ()
+  let r3 = RegistrationId "r3"
+      r4 = RegistrationId "r4"
+      holderInWrite row db = Right . (pcReservedBy =<<) <$> getPrepaidCode db (pcCodeHash row) :: IO (Either Text (Maybe RegistrationId))
+      changed _ = pure (Left "registration_changed") :: IO (Either Text ())
+  spendCode turns st tNow (pcId spentRow) r3 changed `shouldReturn` Left "registration_changed"
+  (pcSpentAt =<<) <$> readCode st spentRow `shouldReturn` Nothing
+  spendCode turns st tNow (pcId spentRow) r1 writeOk `shouldReturn` Right ((), False)
+  spendCode turns st tNow (pcId spentRow) r3 writeOk `shouldReturn` Right ((), True)
+  ((pcReservedBy =<<) &&& (pcSpentAt =<<)) <$> readCode st spentRow `shouldReturn` (Just r3, Just tNow)
+  releaseCode turns st (pcId spentRow) r3 writeOk `shouldReturn` Right ((), False)
+  releaseCode turns st (pcId releasedRow) r4 changed `shouldReturn` Left "registration_changed"
+  releaseCode turns st (pcId releasedRow) r1 writeOk `shouldReturn` Right ((), False)
+  releaseCode turns st (pcId releasedRow) r4 (holderInWrite releasedRow) `shouldReturn` Right (Just r4, True)
+  (pcReservedBy =<<) <$> readCode st releasedRow `shouldReturn` Nothing
+
+testGroupNameCommands :: IO ()
+testGroupNameCommands = do
+  let p = groupCmdAction GRModerator
+  p "/issue name 8" `shouldBe` RunCmd (GCIssueName 8 2)
+  p "/issue name 6 years 5" `shouldBe` RunCmd (GCIssueName 6 5)
+  p "/issue name 63 years 10" `shouldBe` RunCmd (GCIssueName 63 10)
+  p "/bulk name 7 count 3" `shouldBe` RunCmd (GCBulkName 7 2 3)
+  p "/bulk name 12 years 3 count 100" `shouldBe` RunCmd (GCBulkName 12 3 100)
+  groupCmdAction GRMember "/issue name 8" `shouldBe` IgnoreMsg
+
+testGroupNameCommandsRefused :: IO ()
+testGroupNameCommandsRefused = do
+  let p = groupCmdAction GRModerator
+      issueUsage = ReplyText "Usage: /issue <type> [months <M>] [uses <N>], or name <length> [years <Y>]"
+      bulkUsage = ReplyText "Usage: /bulk <type> [months <M>] count <B>, or name <length> [years <Y>] count <B>"
+  forM_ ["name", "name 5", "name 64", "name 06", "name 8 years 1", "name 8 years 0", "name 8 years 11", "name 8 uses 2", "name 8 months 2", "name 8 paid", "name 8 years 18446744073709551618"] $ \args ->
+    (args, p ("/issue " <> args)) `shouldBe` (args, issueUsage)
+  forM_ ["name 8", "name 8 count 0", "name 8 count 101", "name 8 years 1 count 2", "name 5 count 2", "name 08 count 2"] $ \args ->
+    (args, p ("/bulk " <> args)) `shouldBe` (args, bulkUsage)

tests/Bots/StoreService/NamesStoreTests.hs

@@ -3,7 +3,7 @@
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 
-module Bots.StoreService.NamesStoreTests (namesStoreTests) where
+module Bots.StoreService.NamesStoreTests (namesStoreTests, ownerA, ownerB, order, placePaid, placeCode, usable) where
 
 import Bots.StoreService.WebTests (columnsOf, digestFixture, runMigrations, withServiceStore)
 import Control.Arrow ((&&&))

tests/Test.hs

@@ -11,6 +11,7 @@ import Bots.StoreService.GroupIntegrationTests
 import Bots.StoreService.GroupTests
 import Bots.StoreService.NameRegistrationTests
 import Bots.StoreService.NamesChainTests
+import Bots.StoreService.NamesCodesTests
 import Bots.StoreService.NamesLabelTests
 import Bots.StoreService.NamesLinksTests
 import Bots.StoreService.NamesProfilesTests
@@ -95,6 +96,7 @@ main = do
         badgeNameRegistrationTests
       namesConfigTests
       namesChainTests
+      namesCodesTests
       namesLabelTests
       namesLinksTests
       namesProfilesTests
@@ -132,6 +134,7 @@ main = do
             storeServiceTests
             describe "managed group" badgeGroupIntegrationTests
           describe "StoreService names: boot" namesBootTests
+          namesCodesChatTests
           namesProfilesChatTests
           describe "Remote session" remoteTests
 #if !defined(dbPostgres)