diff --git a/apps/simplex-store-service/src/StoreService/Config.hs b/apps/simplex-store-service/src/StoreService/Config.hs index 2ec4919175..c996d2d948 100644 --- a/apps/simplex-store-service/src/StoreService/Config.hs +++ b/apps/simplex-store-service/src/StoreService/Config.hs @@ -17,6 +17,7 @@ module StoreService.Config ServiceConfig (..), defaultExpiryMinutes, defaultSessionMinutes, + minNameYears, readServiceConfig, unknownKeys, ) diff --git a/apps/simplex-store-service/src/StoreService/Group.hs b/apps/simplex-store-service/src/StoreService/Group.hs index 2732bed2f5..2713932875 100644 --- a/apps/simplex-store-service/src/StoreService/Group.hs +++ b/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) diff --git a/apps/simplex-store-service/src/StoreService/Group/Command.hs b/apps/simplex-store-service/src/StoreService/Group/Command.hs index 460450e44e..f7f9f7a047 100644 --- a/apps/simplex-store-service/src/StoreService/Group/Command.hs +++ b/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 [years ]", 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 -> " [months ] [uses ]" - CTBulk -> " [months ] count " + CTIssue -> " [months ] [uses ], or name [years ]" + CTBulk -> " [months ] count , or name [years ] count " CTRevoke -> "" cmdMinRole :: CmdTag -> GroupMemberRole diff --git a/apps/simplex-store-service/src/StoreService/Names/Codes.hs b/apps/simplex-store-service/src/StoreService/Names/Codes.hs index 9239473e69..ac424c55bf 100644 --- a/apps/simplex-store-service/src/StoreService/Names/Codes.hs +++ b/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." diff --git a/apps/simplex-store-service/src/StoreService/Service.hs b/apps/simplex-store-service/src/StoreService/Service.hs index 764f369cd9..48851b9612 100644 --- a/apps/simplex-store-service/src/StoreService/Service.hs +++ b/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 " + 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 show minNameLength <> "-" <> show maxNameLength <> "> [years " <> show minNameYears <> "-" <> show maxNameYears + <> "] [paid|unpaid|free], or //revoke " + 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 diff --git a/tests/Bots/StoreService/BotTests.hs b/tests/Bots/StoreService/BotTests.hs index 590aebeb33..ce999df3cf 100644 --- a/tests/Bots/StoreService/BotTests.hs +++ b/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 " +badgeCmdUsage = "Usage: //issue supporter|legend|investor [months 1-255] [paid|unpaid|free], //issue name [years 2-10] [paid|unpaid|free], or //revoke " diff --git a/tests/Bots/StoreService/GroupIntegrationTests.hs b/tests/Bots/StoreService/GroupIntegrationTests.hs index 0f31f1deb0..54b6f967d4 100644 --- a/tests/Bots/StoreService/GroupIntegrationTests.hs +++ b/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 [months ] [uses ], or name [years ]" + 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 [months ] [uses ]" + waitStoredItem cc "Usage: /issue [months ] [uses ], or name [years ]" 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 " [months ] [uses ]"), - CBCCommand "bulk" "Generate many single-use codes" (Just " [months ] count "), + [ CBCCommand "issue" "Generate a badge or name code" (Just " [months ] [uses ], or name [years ]"), + CBCCommand "bulk" "Generate many single-use codes" (Just " [months ] count , or name [years ] count "), CBCCommand "revoke" "Revoke a code" (Just "") ] diff --git a/tests/Bots/StoreService/GroupTests.hs b/tests/Bots/StoreService/GroupTests.hs index 12e3487513..8919beb86b 100644 --- a/tests/Bots/StoreService/GroupTests.hs +++ b/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 [months ] [uses ]" - bulkUsage = ReplyText "Usage: /bulk [months ] count " + issueUsage = ReplyText "Usage: /issue [months ] [uses ], or name [years ]" + bulkUsage = ReplyText "Usage: /bulk [months ] count , or name [years ] count " revokeUsage = ReplyText "Usage: /revoke " 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) diff --git a/tests/Bots/StoreService/NamesCodesTests.hs b/tests/Bots/StoreService/NamesCodesTests.hs index 00c1e58a9a..f84de7a083 100644 --- a/tests/Bots/StoreService/NamesCodesTests.hs +++ b/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 [months ] [uses ], or name [years ]" + bulkUsage = ReplyText "Usage: /bulk [months ] count , or name [years ] count " + 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) diff --git a/tests/Test.hs b/tests/Test.hs index c7cd5462f8..6fa5f0b234 100644 --- a/tests/Test.hs +++ b/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)