store: issue and revoke 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

@@ -14,22 +14,28 @@ module StoreService.Names.Codes
     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)
-import Simplex.Chat.Badges.Code (NamePrepaidCode, namePrepaidCodeHash)
+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 (PrepaidCode (..), getPrepaidCode, getPrepaidCodeById, releasePrepaidCode, reservePrepaidCode, spendPrepaidCode)
+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)
@@ -120,3 +126,27 @@ 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

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"
 
@@ -512,7 +597,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"]
@@ -1124,8 +1209,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

@@ -26,10 +26,12 @@ 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)
@@ -57,6 +59,9 @@ namesCodesTests = describe "StoreService names: prepaid codes" $ do
     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"
@@ -320,3 +325,23 @@ testReleaseSpend = withOrders $ \turns st -> do
   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/Test.hs

@@ -134,6 +134,7 @@ main = do
             storeServiceTests
             describe "managed group" badgeGroupIntegrationTests
           describe "StoreService names: boot" namesBootTests
+          namesCodesChatTests
           namesProfilesChatTests
           describe "Remote session" remoteTests
 #if !defined(dbPostgres)