diff --git a/apps/simplex-badge-service/README.md b/apps/simplex-badge-service/README.md index 00db4c1f4e..83b7ca4c40 100644 --- a/apps/simplex-badge-service/README.md +++ b/apps/simplex-badge-service/README.md @@ -255,7 +255,8 @@ and above, `/revoke ` for admins and owners. `months` is 1 to 255, `uses` `count` 1 to 100; a value outside these gets the usage reply. A member's role is checked as the service last saw it, so a command sent by a moderator just demoted or removed can still run if it reaches the service first; revoke any code the service posts for them after the change. `uses` -above 1 makes a multi-use code, tracked by a group message counting what is left of it. Every reply carrying a code is read by every member, +above 1 makes a multi-use code, tracked by a group message showing its remaining uses and the time +of the last one; when every use is redeemed, the same message says so. Every reply carrying a code is read by every member, since the group has no private lane, so a code issued there is only as private as its least trusted member. Those replies are also kept as plain text in the service's chat database, so a copy of the database @@ -265,9 +266,9 @@ carries the code, and every redemption edits it or, after a day, posts it again; current member receives it, so a member who joined after the code was issued gets the code while it still has uses left. A message replaced by a new post stays in the group with its old count. Keep disappearing messages off in the group and set no message TTL for the service's chats: a code's -message that expires is treated as deleted and never posted again, so its counter and its "fully -redeemed" notice stop. -Every member can see when a multi-use code's message was edited, which is when each use was redeemed. +message that expires is treated as deleted and never posted again, so its counter stops. +Every member can see when each use of a multi-use code was redeemed: the message shows the time of +the last one, and its edit times show the rest. `/revoke ` names the code in an ordinary group message, so every member holds it before the service reads the command, and the code stays redeemable until the service acts on it — for the whole of any downtime. Revoke a code that is not already public in the group, a refunded one above diff --git a/apps/simplex-badge-service/src/BadgeService/Codes.hs b/apps/simplex-badge-service/src/BadgeService/Codes.hs index 17ced20739..06d3517359 100644 --- a/apps/simplex-badge-service/src/BadgeService/Codes.hs +++ b/apps/simplex-badge-service/src/BadgeService/Codes.hs @@ -30,7 +30,7 @@ revokeBadgeCode cc code = do -- | The group is joined through a bearer link, so this reply names no database error. issueFailedText :: Text -issueFailedText = "issuing the code failed" +issueFailedText = "The code could not be issued." -- | The code table keeps only the hash, so the caller must deliver the code. issueOneCode :: ChatController -> BadgeType -> Int -> BadgeCodePaymentStatus -> Int -> IO (Either String (BadgeCode, Int64)) diff --git a/apps/simplex-badge-service/src/BadgeService/Group.hs b/apps/simplex-badge-service/src/BadgeService/Group.hs index 0f10f590a1..28117655ef 100644 --- a/apps/simplex-badge-service/src/BadgeService/Group.hs +++ b/apps/simplex-badge-service/src/BadgeService/Group.hs @@ -31,7 +31,7 @@ import BadgeService.Log (logError, logInfo, logWarn) import BadgeService.Store (CodeTracker (..), ManagedGroup (..), RevokeResult (..), clearCodeGroupItems, getCodeTracker, getEditableTrackers, getManagedGroup, insertManagedGroup, markOwnerBootstrapped, setCodeGroupItem) import BadgeService.Store.Invoices (truncateToSecond) import Control.Concurrent.STM (TQueue, atomically, flushTQueue, readTQueue, readTVarIO, writeTQueue) -import Control.Monad (forM_, forever, mfilter, replicateM, unless, void, when) +import Control.Monad (forM_, forever, mfilter, replicateM, unless, void) import Control.Monad.Except (runExceptT) import Data.Either (partitionEithers) import Data.Functor (($>), (<&>)) @@ -40,6 +40,7 @@ import Data.List (sortOn) import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.Map.Strict as M import Data.Maybe (fromMaybe, isJust, isNothing, listToMaybe, mapMaybe) +import qualified Data.Set as S import Data.Text (Text) import qualified Data.Text as T import Data.Time.Clock (NominalDiffTime, UTCTime, addUTCTime, diffUTCTime, getCurrentTime, nominalDay) @@ -161,10 +162,9 @@ groupLinkText (CCLink cReq sLnk_) = maybe (strEncodeTxt (simplexChatContact cReq strEncodeTxt :: StrEncoding a => a -> Text strEncodeTxt = safeDecodeUtf8 . strEncode --- GETracker carries the redeem count its claim reached. data GroupEvent = GEInGroup GroupId GroupAction - | GETracker Int64 BadgeCode Int + | GETracker Int64 BadgeCode deriving (Eq, Show) data GroupAction @@ -181,16 +181,15 @@ groupEvent = \case | isNothing scope && isNothing itemDeleted && itemLive /= Just True -> Just $ GEInGroup groupId (GACommand (memberRole' m) t) _ -> Nothing +-- A refresh reads the code's count when it runs, so the last one queued shows every claim before it. coalesceTrackerRefreshes :: [GroupEvent] -> [GroupEvent] -coalesceTrackerRefreshes evs = snd $ foldr keepOne (highestClaims, []) evs +coalesceTrackerRefreshes = snd . foldr keepLast (S.empty, []) where - -- The highest claim decides the exhaustion notice, whatever order the claims were queued in. - highestClaims = M.fromListWith max [(badgeCodeId, n) | GETracker badgeCodeId _ n <- evs] - keepOne ev (todo, kept) = case ev of - GETracker badgeCodeId code _ -> case M.lookup badgeCodeId todo of - Just n -> (M.delete badgeCodeId todo, GETracker badgeCodeId code n : kept) - Nothing -> (todo, kept) - _ -> (todo, ev : kept) + keepLast ev (seen, kept) = case ev of + GETracker badgeCodeId _ + | badgeCodeId `S.member` seen -> (seen, kept) + | otherwise -> (S.insert badgeCodeId seen, ev : kept) + _ -> (seen, ev : kept) logUncaught :: HasCallStack => IO () -> IO () logUncaught a = a `catchOwn'` withFrozenCallStack (logError . tshow) @@ -207,7 +206,7 @@ handleGroupEvent cc groupId ev = logUncaught (handle ev) RunCmd cmd -> runGroupCmd cc groupId cmd ReplyText txt -> void $ sendGroupText cc groupId "command reply" txt IgnoreMsg -> pure () - GETracker badgeCodeId code claimedCount -> updateTracker cc groupId badgeCodeId code claimedCount + GETracker badgeCodeId code -> updateTracker cc groupId badgeCodeId code promoteFirstOwner :: ChatController -> GroupInfo -> GroupMember -> IO () promoteFirstOwner cc g@GroupInfo {groupId} member = @@ -262,7 +261,7 @@ runGroupCmd cc groupId = \case issueOneCode cc bt months CPSFree uses >>= \case Left _ -> reply issueFailedText Right (code, badgeCodeId) - | not (hasTracker uses) -> reply ("code " <> formatBadgeCode code) + | not (hasTracker uses) -> reply ("Code: " <> formatBadgeCode code) | otherwise -> do now <- truncateToSecond <$> getCurrentTime sendGroupText cc groupId ("tracker, code " <> tshow badgeCodeId <> " is lost") (initialTrackerBody code uses) @@ -273,7 +272,7 @@ runGroupCmd cc groupId = \case issued = map (formatBadgeCode . fst) ok reply . T.intercalate "\n" $ case errs of [] -> issued - _ : _ -> issued <> ["issued " <> tshow (length issued) <> " of " <> tshow count <> ", the rest failed"] + _ : _ -> issued <> ["Issued " <> tshow (length issued) <> " of " <> tshow count <> " codes. The remaining codes could not be issued."] -- Naming the code tells concurrent revokes apart; the command already made it public. GCRevoke code -> do outcome <- either id id <$> revokeWithTracker cc code @@ -292,20 +291,19 @@ initialTrackerBody :: BadgeCode -> Int -> Text initialTrackerBody code total = trackerBody code total total Nothing -- The body is dated by the last redemption, not now, because reconcile rewrites it after a restart. +-- The code is green only while it can still be redeemed. trackerBody :: BadgeCode -> Int -> Int -> Maybe UTCTime -> Text -trackerBody code remaining total redeemedAt = - "!2 " <> formatBadgeCode code <> "!\n" <> maybe "" lastRedeemed redeemedAt <> tshow remaining <> "/" <> tshow total <> " remaining" +trackerBody code remaining total redeemedAt + | remaining > 0 = "!2 " <> formatBadgeCode code <> "!\n" <> tshow remaining <> " of " <> tshow total <> " uses remaining" <> lastUsed + | otherwise = formatBadgeCode code <> "\nAll " <> tshow total <> " uses redeemed" <> lastUsed where - lastRedeemed ts = "Last redeemed: " <> fmtDay ts <> " — " - -exhaustedBody :: BadgeCode -> Int -> Text -exhaustedBody code total = formatBadgeCode code <> " fully redeemed — all " <> tshow total <> " used" + lastUsed = maybe "" ((", last used " <>) . fmtTime) redeemedAt revokedBody :: BadgeCode -> Text -revokedBody code = formatBadgeCode code <> " revoked — no longer redeemable" +revokedBody code = formatBadgeCode code <> "\nRevoked, can no longer be redeemed" -fmtDay :: UTCTime -> Text -fmtDay = T.pack . formatTime defaultTimeLocale "%Y-%m-%d" +fmtTime :: UTCTime -> Text +fmtTime = T.pack . formatTime defaultTimeLocale "%Y-%m-%d %H:%M UTC" data TrackerAction = Edit | Repost deriving (Eq, Show) @@ -323,45 +321,34 @@ trackerDecision now sentAt data RepostPolicy = MayRepost | EditOnly -- A deleted or moderated tracker is not reposted, because deleting it does not revoke the code. --- With MayRepost the result is Nothing when there is nothing to write or the message is gone, so no notice follows. -setTrackerBody :: ChatController -> GroupId -> Int64 -> RepostPolicy -> (CodeTracker -> Maybe Text) -> IO (Maybe CodeTracker) +setTrackerBody :: ChatController -> GroupId -> Int64 -> RepostPolicy -> (CodeTracker -> Maybe Text) -> IO () setTrackerBody cc groupId badgeCodeId policy mkBody = withDB' "getCodeTracker" cc (`getCodeTracker` badgeCodeId) >>= \case Right (Just tracker@CodeTracker {trackerItemId, trackerSentAt}) -> - pure (mkBody tracker) $>>= \body -> do + forM_ (mkBody tracker) $ \body -> do now <- truncateToSecond <$> getCurrentTime - let handled = pure (Just tracker) - repost = + let repost = trackerItemText cc groupId trackerItemId >>= \case - Nothing -> do - logWarn $ "badge group tracker not reposted, code " <> tshow badgeCodeId <> " is no longer published" - pure Nothing + Nothing -> logWarn $ "badge group tracker not reposted, code " <> tshow badgeCodeId <> " is no longer published" -- Past the window every write reposts, so an unchanged body is not posted again. - Just current - | current == body -> handled - | otherwise -> do - sendGroupText cc groupId ("tracker repost, code " <> tshow badgeCodeId <> " keeps its old message") body - >>= mapM_ (\i -> withDB' "setCodeGroupItem" cc (\db -> setCodeGroupItem db badgeCodeId i now)) - handled + Just current -> + unless (current == body) $ + sendGroupText cc groupId ("tracker repost, code " <> tshow badgeCodeId <> " keeps its old message") body + >>= mapM_ (\i -> withDB' "setCodeGroupItem" cc (\db -> setCodeGroupItem db badgeCodeId i now)) -- The core can also refuse an edit inside the window, because it uses the message's own timestamp. uneditable = case policy of MayRepost -> repost - EditOnly -> do - logWarn $ "badge group tracker left uncorrected, code " <> tshow badgeCodeId <> " can no longer be edited" - handled + EditOnly -> logWarn $ "badge group tracker left uncorrected, code " <> tshow badgeCodeId <> " can no longer be edited" case trackerDecision now trackerSentAt of Edit -> sendChatCmd cc (APIUpdateChatItem (ChatRef CTGroup groupId Nothing) trackerItemId False (UpdatedMessage (MCText body) M.empty)) >>= \case - Right CRChatItemUpdated {} -> handled - Right CRChatItemNotChanged {} -> handled + Right CRChatItemUpdated {} -> pure () + Right CRChatItemNotChanged {} -> pure () Left (ChatError CEInvalidChatItemUpdate) -> uneditable -- Any other failure may still have applied the edit, so a repost could publish the code twice. - -- The notice still follows the claim while the tracker is published. - r -> do - logError $ "badge group tracker not updated, code " <> tshow badgeCodeId <> ": " <> tshow r - ($> tracker) <$> trackerItemText cc groupId trackerItemId + r -> logError $ "badge group tracker not updated, code " <> tshow badgeCodeId <> ": " <> tshow r Repost -> uneditable - _ -> pure Nothing + _ -> pure () -- A revoke and a redemption can arrive in either order, so a revoked tracker is left alone. counterBody :: BadgeCode -> CodeTracker -> Maybe Text @@ -374,33 +361,28 @@ hasTracker redeemLimit = redeemLimit > singleUse -- The tracker edit reaches every member, so the group lane runs it off the request path. -- Without a lane (--run-cli, or no [group]) it runs here, before the response. -refreshTracker :: ChatController -> Maybe (TQueue GroupEvent) -> Int64 -> BadgeCode -> Int -> IO () -refreshTracker cc trackerQ_ badgeCodeId code claimedCount = case trackerQ_ of - Just q -> atomically $ writeTQueue q (GETracker badgeCodeId code claimedCount) - Nothing -> logUncaught $ withManagedGroup cc $ \groupId -> updateTracker cc groupId badgeCodeId code claimedCount +refreshTracker :: ChatController -> Maybe (TQueue GroupEvent) -> Int64 -> BadgeCode -> IO () +refreshTracker cc trackerQ_ badgeCodeId code = case trackerQ_ of + Just q -> atomically $ writeTQueue q (GETracker badgeCodeId code) + Nothing -> logUncaught $ withManagedGroup cc $ \groupId -> updateTracker cc groupId badgeCodeId code --- The notice follows the claim, not the count read now, so queued refreshes post it once. -updateTracker :: ChatController -> GroupId -> Int64 -> BadgeCode -> Int -> IO () -updateTracker cc groupId badgeCodeId code claimedCount = - setTrackerBody cc groupId badgeCodeId MayRepost (counterBody code) - >>= mapM_ (\CodeTracker {redeemLimit} -> when (claimedCount == redeemLimit) $ postNotice redeemLimit) - where - postNotice redeemLimit = void $ sendGroupText cc groupId ("notice, code " <> tshow badgeCodeId) (exhaustedBody code redeemLimit) +updateTracker :: ChatController -> GroupId -> Int64 -> BadgeCode -> IO () +updateTracker cc groupId badgeCodeId code = setTrackerBody cc groupId badgeCodeId MayRepost (counterBody code) -- | Left is a refusal or a failure; both sides are the text to show whoever sent the revoke. revokeWithTracker :: ChatController -> BadgeCode -> IO (Either Text Text) revokeWithTracker cc code = revokeBadgeCode cc code >>= \case - -- The message is retired before the answer, so "revoked" never sits beside a live counter. - Right (Revoked badgeCodeId) -> Right "revoked" <$ retire badgeCodeId + -- The message is retired before the answer, so the answer never sits beside a live counter. + Right (Revoked badgeCodeId) -> Right "Revoked." <$ retire badgeCodeId -- A repeated revoke repairs a message that an earlier revoke failed to update. - Right (AlreadyRevoked badgeCodeId) -> Right "already revoked" <$ retire badgeCodeId - Right AlreadyRedeemed -> pure $ Left "code was redeemed already, so it cannot be revoked" - Right NoSuchCode -> pure $ Left "no such code" - Left _ -> pure $ Left "revoking the code failed" + Right (AlreadyRevoked badgeCodeId) -> Right "Already revoked." <$ retire badgeCodeId + Right AlreadyRedeemed -> pure $ Left "Fully redeemed. It cannot be revoked." + Right NoSuchCode -> pure $ Left "No such code." + Left _ -> pure $ Left "The code could not be revoked." where retire badgeCodeId = logUncaught $ withManagedGroup cc $ \groupId -> - void $ setTrackerBody cc groupId badgeCodeId MayRepost (const $ Just $ revokedBody code) + setTrackerBody cc groupId badgeCodeId MayRepost (const $ Just $ revokedBody code) withManagedGroup :: ChatController -> (GroupId -> IO ()) -> IO () withManagedGroup cc action = @@ -421,7 +403,7 @@ reconcileTracker :: ChatController -> GroupId -> Int64 -> ChatItemId -> IO () reconcileTracker cc groupId badgeCodeId itemId = readTrackerCode cc groupId badgeCodeId itemId >>= mapM_ reconcile where - reconcile (code, current) = void $ setTrackerBody cc groupId badgeCodeId EditOnly (correctedBody code current) + reconcile (code, current) = setTrackerBody cc groupId badgeCodeId EditOnly (correctedBody code current) -- A crash after a revoke committed can leave its tracker still counting, so a revoked code is retired here. correctedBody code current tracker@CodeTracker {revokedAt} = mfilter (/= current) $ if isJust revokedAt then Just (revokedBody code) else counterBody code tracker diff --git a/apps/simplex-badge-service/src/BadgeService/Group/Command.hs b/apps/simplex-badge-service/src/BadgeService/Group/Command.hs index ad3b1eb691..799e1a2fcf 100644 --- a/apps/simplex-badge-service/src/BadgeService/Group/Command.hs +++ b/apps/simplex-badge-service/src/BadgeService/Group/Command.hs @@ -64,7 +64,7 @@ cmdActionP = A.choice (map cmdP [minBound .. maxBound]) fullArgsP tag = A.char ' ' *> cmdArgsP tag <* A.endOfInput -- Without the space check "/issued" would get a usage reply. usageEndP = void A.space <|> A.endOfInput - usage tag = "use: /" <> cmdName tag <> " " <> cmdParams tag + usage tag = "Usage: /" <> cmdName tag <> " " <> cmdParams tag cmdArgsP :: CmdTag -> A.Parser GroupCmd cmdArgsP = \case @@ -139,4 +139,4 @@ cmdRefusal = \case CTIssue -> Nothing CTBulk -> Nothing -- The sender has just published a code that stays redeemable, so they must learn it was not revoked. - CTRevoke -> Just "only admins can revoke codes, and this code is now visible to the group - ask an admin to revoke it" + CTRevoke -> Just "Only admins can revoke codes. This code is now visible to all members." diff --git a/apps/simplex-badge-service/src/BadgeService/Service.hs b/apps/simplex-badge-service/src/BadgeService/Service.hs index 32557844dc..0e189a3489 100644 --- a/apps/simplex-badge-service/src/BadgeService/Service.hs +++ b/apps/simplex-badge-service/src/BadgeService/Service.hs @@ -203,13 +203,13 @@ 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} + 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 $ "use: //issue supporter|legend|investor [months 1-" <> show maxMonths <> "] [paid|unpaid|free], or //revoke " + | otherwise = pure $ chatCmdError $ "Usage: //issue supporter|legend|investor [months 1-" <> show maxMonths <> "] [paid|unpaid|free], or //revoke " revokeCmdP :: A.Parser BadgeCode revokeCmdP = "revoke " *> codeP <* (A.skipSpace *> A.endOfInput) @@ -355,14 +355,14 @@ redeemCode key cc trackerQ_ purchaseKey masterKey codeText = case parseBadgeCode liftIO (createCodePurchase db NewCodePurchase {badgeCodeId, purchaseKey, masterKey, badgeType} now) >>= \case Nothing -> readCode now code db >>= \case - Left resp -> pure (resp, Nothing) - Right _ -> logError "badge service: redeeming a code failed, but the code has uses left and is not revoked" $> (errorResponse BSEInternal, Nothing) - Just (purchaseId, claimedCount) -> liftIO $ do + Left resp -> pure (resp, False) + Right _ -> logError "badge service: redeeming a code failed, but the code has uses left and is not revoked" $> (errorResponse BSEInternal, False) + Just purchaseId -> liftIO $ do appendLedgerPlan db purchaseId [granted] $ Just $ issuanceAfter granted signed entries_ <- getLedgerEntries db purchaseId 0 - pure (maybe (errorResponse BSEInternal) (credentialResponse (Just $ snd signed) Nothing) entries_, Just claimedCount) - let (resp, claimedCount_) = fromRight (errorResponse BSEInternal, Nothing) r - when (hasTracker redeemLimit) $ forM_ claimedCount_ $ refreshTracker cc trackerQ_ badgeCodeId code + pure (maybe (errorResponse BSEInternal) (credentialResponse (Just $ snd signed) Nothing) entries_, True) + let (resp, claimed) = fromRight (errorResponse BSEInternal, False) r + when (claimed && hasTracker redeemLimit) $ refreshTracker cc trackerQ_ badgeCodeId code pure resp where readCode now code db = liftIO $ diff --git a/apps/simplex-badge-service/src/BadgeService/Store.hs b/apps/simplex-badge-service/src/BadgeService/Store.hs index 2f25b6c6f6..b51e47bdad 100644 --- a/apps/simplex-badge-service/src/BadgeService/Store.hs +++ b/apps/simplex-badge-service/src/BadgeService/Store.hs @@ -4,7 +4,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} module BadgeService.Store ( IssuedCode (..), @@ -38,7 +37,6 @@ module BadgeService.Store where import BadgeService.Store.Invoices (executeChanging) -import Control.Monad (forM) import qualified Data.Aeson as J import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Lazy.Char8 as LB @@ -287,25 +285,26 @@ appendLedgerPlan db purchaseId rows issuance_ = do insertedRowId db -- The claim takes one use before adding the purchase, so a concurrent revoke or redemption waits on this row and sees the new count. --- Run it in the credential's transaction. It returns the use count this claim reached. -createCodePurchase :: DB.Connection -> NewCodePurchase -> UTCTime -> IO (Maybe (Int64, Int)) +-- Run it in the credential's transaction. +createCodePurchase :: DB.Connection -> NewCodePurchase -> UTCTime -> IO (Maybe Int64) createCodePurchase db NewCodePurchase {badgeCodeId, purchaseKey, masterKey = BadgeMasterKey mk, badgeType} now = do - claimed_ <- - maybeFirstRow fromOnly $ - DB.query - db - "UPDATE sx_badge_service_badge_codes SET redeem_count = redeem_count + 1, redeemed_at = ? WHERE badge_code_id = ? AND redeem_count < redeem_limit AND revoked_at IS NULL RETURNING redeem_count" - (now, badgeCodeId) - forM claimed_ $ \claimedCount -> do - DB.execute + claimed <- + executeChanging db - [sql| - INSERT INTO sx_badge_service_badge_purchases - (purchase_key, master_key, initial_badge_type, current_badge_type, status, badge_code_id, created_at, updated_at) - VALUES (?,?,?,?,?,?,?,?) - |] - (purchaseKey, Binary mk, badgeType, badgeType, PSIssued, badgeCodeId, now, now) - (,claimedCount) <$> insertedRowId db + "UPDATE sx_badge_service_badge_codes SET redeem_count = redeem_count + 1, redeemed_at = ? WHERE badge_code_id = ? AND redeem_count < redeem_limit AND revoked_at IS NULL" + (now, badgeCodeId) + if claimed == 0 + then pure Nothing + else do + DB.execute + db + [sql| + INSERT INTO sx_badge_service_badge_purchases + (purchase_key, master_key, initial_badge_type, current_badge_type, status, badge_code_id, created_at, updated_at) + VALUES (?,?,?,?,?,?,?,?) + |] + (purchaseKey, Binary mk, badgeType, badgeType, PSIssued, badgeCodeId, now, now) + Just <$> insertedRowId db -- | Revoked and AlreadyRevoked carry the code id, so the caller can retire the code's group tracker, -- or repair one an earlier revoke left live. diff --git a/tests/Bots/BadgeService/BotTests.hs b/tests/Bots/BadgeService/BotTests.hs index 5188a8da92..2f2dade67d 100644 --- a/tests/Bots/BadgeService/BotTests.hs +++ b/tests/Bots/BadgeService/BotTests.hs @@ -222,7 +222,7 @@ revokeRaw cc args = issueCodeAs :: HasCallStack => ChatController -> BadgeType -> Int -> String -> IO BadgeCode issueCodeAs cc badgeType months status = sendChatCmdStr cc ("//issue " <> T.unpack (textEncode badgeType) <> " " <> show months <> " " <> status) >>= \case - Right (CRCustomChatResponse _ response) -> case T.stripPrefix "code " response of + Right (CRCustomChatResponse _ response) -> case T.stripPrefix "Code: " response of Just c | Just code <- parseBadgeCode c -> pure code _ -> error $ "unexpected issue response: " <> T.unpack response r -> error $ "issue failed: " <> show (() <$ r) @@ -831,7 +831,7 @@ testRevokedMultiUseHolderRenews ps = code <- issueMultiUseCode cc BTSupporter 3 2 redeemFirstBadge alice code redeemed <- ledgerRows (chatController alice) "badge_ledger" - revokeCodeAs cc code `shouldReturn` Right "revoked" + revokeCodeAs cc code `shouldReturn` Right "Revoked." redeemAsNewPurchase env code >>= (`shouldAnswerError` BSECodeInvalid) codeUses cc code `shouldReturn` Just (2, 1) -- A holder whose reply was lost retries with the same key and still gets its badge. @@ -1518,7 +1518,7 @@ testRevokeRedeemedCode ps = alice <## "supporter badge - active" alice <##. "expires " refused <- revokeCodeAs cc code - refused `shouldBe` Left "code was redeemed already, so it cannot be revoked" + refused `shouldBe` Left "Fully redeemed. It cannot be revoked." alice ##> ("/_redeem_badge_code 1 " <> codeArg code) alice <## "badge already redeemed" @@ -1528,23 +1528,23 @@ testRevokeUnknownCode ps = g <- C.newRandom code <- randomBadgeCode g unknown <- revokeCodeAs cc code - unknown `shouldBe` Left "no such code" + unknown `shouldBe` Left "No such code." testRevokedCode :: HasCallStack => TestParams -> IO () testRevokedCode ps = withBadgeService ps $ \clientCfg _ cc -> withNewTestChatCfg ps clientCfg "alice" aliceProfile $ \alice -> do paid <- issueCodeAs cc BTSupporter 1 "paid" - revokeCodeAs cc paid `shouldReturn` Right "revoked" + revokeCodeAs cc paid `shouldReturn` Right "Revoked." alice ##> ("/_redeem_badge_code 1 " <> codeArg paid) alice <## "cannot redeem badge code: badge service error: code_invalid" - revokeCodeAs cc paid `shouldReturn` Right "already revoked" + revokeCodeAs cc paid `shouldReturn` Right "Already revoked." testRevokedUnpaidCode :: HasCallStack => TestParams -> IO () testRevokedUnpaidCode ps = withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsController = cc} -> do code <- issueCodeAs cc BTSupporter 1 "unpaid" - revokeCodeAs cc code `shouldReturn` Right "revoked" + revokeCodeAs cc code `shouldReturn` Right "Revoked." redeemAsNewPurchase env code >>= (`shouldAnswerError` BSECodeInvalid) testRevokeRejectsTrailingInput :: HasCallStack => TestParams -> IO () @@ -1552,10 +1552,10 @@ testRevokeRejectsTrailingInput ps = withBadgeService ps $ \_ _ cc -> do code <- issueCodeAs cc BTSupporter 1 "paid" refused <- revokeRaw cc (formatBadgeCode code <> " junk") - -- If the refused call revoked the code anyway, this fails with "already revoked". - revokeCodeAs cc code `shouldReturn` Right "revoked" + -- If the refused call revoked the code anyway, this fails with "Already revoked.". + revokeCodeAs cc code `shouldReturn` Right "Revoked." refused `shouldBe` Left badgeCmdUsage -- The text is spelled out rather than taken from the service, so a change there fails here. badgeCmdUsage :: Text -badgeCmdUsage = "use: //issue supporter|legend|investor [months 1-255] [paid|unpaid|free], or //revoke " +badgeCmdUsage = "Usage: //issue supporter|legend|investor [months 1-255] [paid|unpaid|free], or //revoke " diff --git a/tests/Bots/BadgeService/GroupIntegrationTests.hs b/tests/Bots/BadgeService/GroupIntegrationTests.hs index afde82c359..1b80adcd13 100644 --- a/tests/Bots/BadgeService/GroupIntegrationTests.hs +++ b/tests/Bots/BadgeService/GroupIntegrationTests.hs @@ -93,9 +93,9 @@ badgeGroupIntegrationTests = do it "answers a failed /issue or //issue without naming what failed in the store" testIssueFailureIsOpaque it "lists the codes a /bulk issued before an insert failed" testBulkPartialFailureListsIssued it "answers a failed /revoke without naming what failed in the store" testRevokeFailureIsOpaque - it "tracks a multi-use code across redemptions and refuses it when used up" testMultiUseTracker - it "keeps the counter and posts no second notice for a stale refresh of a used-up code" testStaleRefreshIgnored - it "announces a second multi-use code used up on the claim that uses it up" testSecondMultiUseCodeExhausted + it "tracks a multi-use code in one message across redemptions and refuses it when used up" testMultiUseTracker + it "leaves a used-up code's tracker as it is on a stale refresh" testStaleRefreshIgnored + it "keeps each multi-use code's counter to its own claims" testCountersKeptApart it "refreshes the tracker for a redemption served with no group lane" testLanelessRedeemRefreshesTracker it "refreshes the tracker for a redemption from the service's request queue" testQueuedRequestRefreshesTracker it "refreshes the tracker inline for a queued redemption after a restart without [group]" testQueuedRequestWithoutGroupConfig @@ -105,7 +105,7 @@ badgeGroupIntegrationTests = do it "never reposts a tracker deleted on the service's side, publishing the code no further" testDeletedTrackerNotReposted it "never reposts a tracker an owner deleted for everyone" testModeratedTrackerNotReposted it "revokes a code whose tracker was deleted on the service's side without reposting it" testDeletedTrackerNotRepostedOnRevoke - it "posts no notice when a code whose tracker was deleted is used up" testDeletedTrackerNoNotice + it "publishes nothing when a code whose tracker was deleted is used up" testDeletedTrackerUsedUp it "revokes a code whose tracker an owner deleted for everyone without reposting it" testModeratedTrackerNotRepostedOnRevoke it "revokes a code on /revoke, answers a repeat as already revoked and an unknown code as no such code" testGroupRevoke it "retires the tracker message when a multi-use code is revoked" testRevokeRetiresTracker @@ -113,7 +113,7 @@ badgeGroupIntegrationTests = do it "retires a tracker left behind when the code is revoked again" testGroupRevokeRepairsTracker it "retires a tracker left behind when the service command revokes again" testServiceRevokeRepairsTracker it "posts one retired tracker however often a revoke past the window repeats" testRevokeRepeatPastWindow - it "reconciles an exhausted tracker whose refresh was lost, posting no notice" testExhaustedTrackerReconciledOnRestart + it "reconciles a used-up tracker whose refresh was lost, in place" testUsedUpTrackerReconciledOnRestart it "reconciles a tracker with uses left whose refresh was lost" testStalledTrackerReconciledOnRestart it "retires on restart a tracker whose revoke never reached it" testRevokedTrackerReconciledOnRestart it "reconciles every stalled tracker on restart, not only the first" testEveryStalledTrackerReconciled @@ -443,7 +443,7 @@ testFirstJoinerPromoted ps = do sendGroupCmd alice "/issue supporter" waitCodeOfType cc "supporter" memberRoles cc gid `shouldReturn` [("alice", "owner"), ("bob", "member")] - let codeReply = "#" <> groupName <> " " <> botName <> "> code SB-" + let codeReply = "#" <> groupName <> " " <> botName <> "> Code: SB-" drainUntil alice [codeReply] drainUntil bob [codeReply, "#" <> groupName <> ": member alice"] @@ -471,7 +471,7 @@ testRoleGatedIssue ps = do let announced name = "#" <> groupName <> ": " <> botName <> " added " <> name preMember name = "#" <> groupName <> ": member " <> name newMember name = "#" <> groupName <> ": new member " <> name <> " is connected" - usageReply = "#" <> groupName <> " " <> botName <> "> use: /issue " + usageReply = "#" <> groupName <> " " <> botName <> "> Usage: /issue " joinGroup cc bob waitMemberRole cc gid "bob" "member" -- cath joins only after alice sees bob announced, or cath's console shows a different line. @@ -485,14 +485,14 @@ testRoleGatedIssue ps = do dropTime cath [ StartsWith ("#" <> groupName <> " alice> /issue supporter"), - StartsWith ("#" <> groupName <> " " <> botName <> "> code SB-") + StartsWith ("#" <> groupName <> " " <> botName <> "> Code: SB-") ] codeCount cc `shouldReturn` 1 sendGroupCmd bob "/issue legend" waitStoredItem cc "/issue legend" ownerIssuesNext cc alice 2 sendGroupCmd alice "/issue supporter uses 0" - waitStoredItem cc "use: /issue [months ] [uses ]" + waitStoredItem cc "Usage: /issue [months ] [uses ]" codeCount cc `shouldReturn` 2 drainUntil alice [usageReply, newMember "bob", newMember "cath"] drainUntil bob [usageReply, preMember "alice", newMember "cath"] @@ -578,7 +578,7 @@ testBulkPartialFailureListsIssued ps = withGroupOwner ps $ \gsKey cc env alice -> do codeLines <- withCodeTableCapped cc 2 $ do (codeLines, summary) <- splitAt 2 . T.lines <$> replyTo cc alice "/bulk supporter count 3" - summary `shouldBe` ["issued 2 of 3, the rest failed"] + summary `shouldBe` ["Issued 2 of 3 codes. The remaining codes could not be issued."] pure codeLines codeCount cc `shouldReturn` 2 forM_ codeLines $ redeemOk gsKey cc env . extractCode @@ -587,8 +587,8 @@ testIssueFailureIsOpaque :: HasCallStack => TestParams -> IO () testIssueFailureIsOpaque ps = withGroupOwner ps $ \_ cc _ alice -> do withCodeTableHidden cc $ do - replyTo cc alice "/issue supporter" `shouldReturn` "issuing the code failed" - issueRaw cc "supporter" `shouldReturn` Left "issuing the code failed" + replyTo cc alice "/issue supporter" `shouldReturn` "The code could not be issued." + issueRaw cc "supporter" `shouldReturn` Left "The code could not be issued." void $ replyTo cc alice "/issue supporter" codeCount cc `shouldReturn` 1 @@ -597,8 +597,8 @@ testRevokeFailureIsOpaque ps = withGroupOwner ps $ \_ cc _ alice -> do code <- extractCode <$> replyTo cc alice "/issue supporter" withCodeTableHidden cc $ - replyTo cc alice (revokeCmd code) `shouldReturn` revokeReply code "revoking the code failed" - revokeInGroup cc alice code "revoked" + replyTo cc alice (revokeCmd code) `shouldReturn` revokeReply code "The code could not be revoked." + revokeInGroup cc alice code "Revoked." withCodeTableHidden :: ChatController -> IO a -> IO a withCodeTableHidden cc action = rename codeTable hidden >> (action `finally` rename hidden codeTable) @@ -632,13 +632,13 @@ testMultiUseTracker :: HasCallStack => TestParams -> IO () testMultiUseTracker ps = withGroupOwner ps $ \gsKey cc env alice -> do (trackerItemId, tracker0, code) <- issueTracked cc alice "supporter" 2 - tracker0 `shouldSatisfy` T.isInfixOf "2/2 remaining" + tracker0 `shouldSatisfy` T.isInfixOf "2 of 2 uses remaining" redeemOk gsKey cc env code - t1 <- waitItemText cc trackerItemId "1/2 remaining" - t1 `shouldSatisfy` T.isInfixOf "Last redeemed" + t1 <- waitItemText cc trackerItemId "1 of 2 uses remaining" + t1 `shouldSatisfy` T.isInfixOf "last used" redeemOk gsKey cc env code - void $ waitItemText cc trackerItemId "0/2 remaining" - waitExhausted cc `shouldReturn` exhaustedText code 2 + usedUp <- waitItemText cc trackerItemId "All 2 uses redeemed" + sentItemsWithCode cc code `shouldReturn` [usedUp] redeemViaService gsKey cc env code >>= (`shouldAnswerError` BSECodeUsed) testStaleRefreshIgnored :: HasCallStack => TestParams -> IO () @@ -647,35 +647,21 @@ testStaleRefreshIgnored ps = (trackerItemId, _, code) <- issueTracked cc alice "supporter" 2 redeemOk gsKey cc env code redeemOk gsKey cc env code - void $ waitItemText cc trackerItemId "0/2 remaining" - notice <- waitExhausted cc - replayRefresh cc env code 2 1 + usedUp <- waitItemText cc trackerItemId "All 2 uses redeemed" + replayRefresh cc env code 2 awaitLane cc env - exhaustedNotices cc `shouldReturn` [notice] - readItemText cc trackerItemId >>= (`shouldSatisfy` T.isInfixOf "0/2 remaining") - redeemedTrackerCount cc `shouldReturn` 1 + sentItemsWithCode cc code `shouldReturn` [usedUp] -testSecondMultiUseCodeExhausted :: HasCallStack => TestParams -> IO () -testSecondMultiUseCodeExhausted ps = +testCountersKeptApart :: HasCallStack => TestParams -> IO () +testCountersKeptApart ps = withGroupOwner ps $ \gsKey cc env alice -> do - -- The first code gets 3 claims, the second code's limit, so reading the wrong count would post the notice early. (firstItemId, _, firstCode) <- issueTracked cc alice "supporter" 5 replicateM_ 3 (redeemOk gsKey cc env firstCode) - void $ waitItemText cc firstItemId "2/5 remaining" - awaitLane cc env - exhaustedNotices cc `shouldReturn` [] + void $ waitItemText cc firstItemId "2 of 5 uses remaining" (secondItemId, _, secondCode) <- issueTracked cc alice "legend" 3 - -- Each claim is awaited because the lane coalesces refreshes queued together. - redeemOk gsKey cc env secondCode - void $ waitItemText cc secondItemId "2/3 remaining" - redeemOk gsKey cc env secondCode - void $ waitItemText cc secondItemId "1/3 remaining" - awaitLane cc env - exhaustedNotices cc `shouldReturn` [] - redeemOk gsKey cc env secondCode - void $ waitItemText cc secondItemId "0/3 remaining" - waitExhausted cc `shouldReturn` exhaustedText secondCode 3 - readItemText cc firstItemId >>= (`shouldSatisfy` T.isInfixOf "2/5 remaining") + replicateM_ 3 (redeemOk gsKey cc env secondCode) + void $ waitItemText cc secondItemId "All 3 uses redeemed" + readItemText cc firstItemId >>= (`shouldSatisfy` T.isInfixOf "2 of 5 uses remaining") testLanelessRedeemRefreshesTracker :: HasCallStack => TestParams -> IO () testLanelessRedeemRefreshesTracker ps = @@ -685,12 +671,10 @@ testLanelessRedeemRefreshesTracker ps = redeemOkWith gsKey cc Nothing code -- The refresh runs before the response, so the counter is already written here. t1 <- readItemText cc trackerItemId - t1 `shouldSatisfy` T.isInfixOf "1/2 remaining" - t1 `shouldSatisfy` T.isInfixOf "Last redeemed" - exhaustedNotices cc `shouldReturn` [] + t1 `shouldSatisfy` T.isInfixOf "1 of 2 uses remaining" + t1 `shouldSatisfy` T.isInfixOf "last used" redeemOkWith gsKey cc Nothing code - readItemText cc trackerItemId >>= (`shouldSatisfy` T.isInfixOf "0/2 remaining") - exhaustedNotices cc `shouldReturn` [exhaustedText code 2] + readItemText cc trackerItemId >>= (`shouldSatisfy` T.isInfixOf "All 2 uses redeemed") redeemedTrackerCount cc `shouldReturn` 1 testQueuedRequestRefreshesTracker :: HasCallStack => TestParams -> IO () @@ -698,7 +682,7 @@ testQueuedRequestRefreshesTracker ps = withGroupOwner ps $ \_ cc env alice -> do (trackerItemId, _, code) <- issueTracked cc alice "supporter" 2 queueRedemption cc env code - void $ waitItemText cc trackerItemId "1/2 remaining" + void $ waitItemText cc trackerItemId "1 of 2 uses remaining" testQueuedRequestWithoutGroupConfig :: HasCallStack => TestParams -> IO () testQueuedRequestWithoutGroupConfig ps = do @@ -707,7 +691,7 @@ testQueuedRequestWithoutGroupConfig ps = do (\(i, _, c) -> (i, c)) <$> issueTracked cc alice "supporter" 2 runGroupServiceAs svc Nothing $ \cc env _ -> do queueRedemption cc env code - void $ waitItemText cc trackerItemId "1/2 remaining" + void $ waitItemText cc trackerItemId "1 of 2 uses remaining" testTrackerRepost :: HasCallStack => TestParams -> IO () testTrackerRepost ps = @@ -716,7 +700,7 @@ testTrackerRepost ps = backdated <- backdateTracker cc 2 redeemOk gsKey cc env code (_, tracker1) <- waitTrackerRepost cc 2 itemId0 - tracker1 `shouldSatisfy` T.isInfixOf "1/2 remaining" + tracker1 `shouldSatisfy` T.isInfixOf "1 of 2 uses remaining" readItemText cc itemId0 `shouldReturn` tracker0 sentAt <- trackerSentAt cc 2 sentAt `shouldSatisfy` (> backdated) @@ -728,11 +712,10 @@ testRefusedEditReposted ps = backdateTrackerItem cc itemId0 redeemOk gsKey cc env code (itemId1, tracker1) <- waitTrackerRepost cc 2 itemId0 - tracker1 `shouldSatisfy` T.isInfixOf "1/2 remaining" + tracker1 `shouldSatisfy` T.isInfixOf "1 of 2 uses remaining" redeemOk gsKey cc env code - void $ waitItemText cc itemId1 "0/2 remaining" - waitExhausted cc `shouldReturn` exhaustedText code 2 - readItemText cc itemId0 `shouldReturn` tracker0 + usedUp <- waitItemText cc itemId1 "All 2 uses redeemed" + sentItemsWithCode cc code `shouldReturn` [tracker0, usedUp] testFailedRepostDropped :: HasCallStack => TestParams -> IO () testFailedRepostDropped ps = @@ -748,8 +731,7 @@ testFailedRepostDropped ps = setBotRole cc "owner" redeemOk gsKey cc env code (_, tracker1) <- waitTrackerRepost cc 2 itemId0 - tracker1 `shouldSatisfy` T.isInfixOf "0/2 remaining" - waitExhausted cc `shouldReturn` exhaustedText code 2 + tracker1 `shouldSatisfy` T.isInfixOf "All 2 uses redeemed" testDeletedTrackerNotReposted :: HasCallStack => TestParams -> IO () testDeletedTrackerNotReposted ps = @@ -769,14 +751,13 @@ testDeletedTrackerNotRepostedOnRevoke ps = revokeNeverReposts cc alice code [] -- Both claims fall inside the edit window, so each edit fails because the message is gone. -testDeletedTrackerNoNotice :: HasCallStack => TestParams -> IO () -testDeletedTrackerNoNotice ps = +testDeletedTrackerUsedUp :: HasCallStack => TestParams -> IO () +testDeletedTrackerUsedUp ps = withGroupOwner ps $ \gsKey cc env alice -> do (itemId0, _, code) <- issueTracked cc alice "supporter" 2 deleteItem cc itemId0 replicateM_ 2 $ redeemOk gsKey cc env code awaitLane cc env - exhaustedNotices cc `shouldReturn` [] sentItemsWithCode cc code `shouldReturn` [] testModeratedTrackerNotRepostedOnRevoke :: HasCallStack => TestParams -> IO () @@ -815,13 +796,12 @@ trackerNeverReposted key cc env code itemId0 codeItems = do redeemOk key cc env code awaitLane cc env sentItemsWithCode cc code `shouldReturn` codeItems - exhaustedNotices cc `shouldReturn` [] trackerAnchor cc 2 `shouldReturn` Just itemId0 revokeNeverReposts :: HasCallStack => ChatController -> TestCC -> Text -> [Text] -> IO () revokeNeverReposts cc member code codeItems = do - revokeInGroup cc member code "revoked" - sentItemsWithCode cc code `shouldReturn` codeItems <> [revokeReply code "revoked"] + revokeInGroup cc member code "Revoked." + sentItemsWithCode cc code `shouldReturn` codeItems <> [revokeReply code "Revoked."] revokedTrackerCount cc `shouldReturn` 0 testGroupRevoke :: HasCallStack => TestParams -> IO () @@ -829,14 +809,14 @@ testGroupRevoke ps = withGroupOwner ps $ \gsKey cc env alice -> do code <- extractCode <$> replyTo cc alice "/issue supporter" other <- extractCode <$> replyTo cc alice "/issue legend" - revokeInGroup cc alice code "revoked" + revokeInGroup cc alice code "Revoked." redeemViaService gsKey cc env code >>= (`shouldAnswerError` BSECodeInvalid) redeemOk gsKey cc env other - revokeInGroup cc alice code "already revoked" + revokeInGroup cc alice code "Already revoked." -- The reply follows the tracker step, so the revoke has already passed it here. revokedTrackerCount cc `shouldReturn` 0 unissued <- formatBadgeCode <$> randomBadgeCode (random cc) - revokeInGroup cc alice unissued "no such code" + revokeInGroup cc alice unissued "No such code." testGroupRevokeRepairsTracker :: HasCallStack => TestParams -> IO () testGroupRevokeRepairsTracker ps = @@ -846,9 +826,9 @@ testGroupRevokeRepairsTracker ps = revokeInStore cc 2 readItemText cc trackerItemId `shouldReturn` tracker0 sendGroupCmd alice (revokeCmd code) - retired <- waitItemText cc trackerItemId "revoked" + retired <- waitItemText cc trackerItemId "Revoked" retired `shouldBe` retiredText code - waitStoredItem cc (revokeReply code "already revoked") + waitStoredItem cc (revokeReply code "Already revoked.") revokedTrackerCount cc `shouldReturn` 1 testRevokeRepeatPastWindow :: HasCallStack => TestParams -> IO () @@ -857,36 +837,36 @@ testRevokeRepeatPastWindow ps = offsetCodeIds cc (itemId0, tracker0, code) <- issueTracked cc alice "supporter" 2 void $ backdateTracker cc 2 - revokeInGroup cc alice code "revoked" + revokeInGroup cc alice code "Revoked." (itemId1, retired) <- waitTrackerRepost cc 2 itemId0 retired `shouldBe` retiredText code revokedTrackerCount cc `shouldReturn` 1 void $ backdateTracker cc 2 - revokeInGroup cc alice code "already revoked" + revokeInGroup cc alice code "Already revoked." revokedTrackerCount cc `shouldReturn` 1 trackerAnchor cc 2 `shouldReturn` Just itemId1 readItemText cc itemId1 `shouldReturn` retiredText code readItemText cc itemId0 `shouldReturn` tracker0 -testExhaustedTrackerReconciledOnRestart :: HasCallStack => TestParams -> IO () -testExhaustedTrackerReconciledOnRestart ps = do +testUsedUpTrackerReconciledOnRestart :: HasCallStack => TestParams -> IO () +testUsedUpTrackerReconciledOnRestart ps = do svc@GroupSvc {gsKey} <- prepareGroupService ps - (lostItemId, notice, lostCode) <- runWithOwner svc $ \cc env _ alice -> do + (lostItemId, lostCode) <- runWithOwner svc $ \cc env _ alice -> do (doneItemId, _, doneCode) <- issueTracked cc alice "supporter" 2 redeemOk gsKey cc env doneCode redeemOk gsKey cc env doneCode - notice <- waitExhausted cc + void $ waitItemText cc doneItemId "All 2 uses redeemed" (lostItemId, lost0, lostCode) <- issueTracked cc alice "legend" 3 replicateM_ 3 (redeemLosingRefresh gsKey cc lostCode) readItemText cc lostItemId `shouldReturn` lost0 trackerAnchor cc 2 `shouldReturn` Just doneItemId dateRedemption cc 3 lostRedeemedAt - pure (lostItemId, notice, lostCode) + pure (lostItemId, lostCode) runGroupService svc $ \cc env _ -> do - corrected <- waitItemText cc lostItemId "0/3 remaining" - corrected `shouldBe` ("!2 " <> lostCode <> "!\nLast redeemed: 2026-02-28 — 0/3 remaining") + corrected <- waitItemText cc lostItemId "All 3 uses redeemed" + corrected `shouldBe` (lostCode <> "\nAll 3 uses redeemed, last used 2026-02-28 23:50 UTC") awaitLane cc env - exhaustedNotices cc `shouldReturn` [notice] + sentItemsWithCode cc lostCode `shouldReturn` [corrected] redeemedTrackerCount cc `shouldReturn` 2 -- This date is far from any day the test runs on, so a body dated now cannot match it. @@ -896,21 +876,21 @@ lostRedeemedAt = UTCTime (fromGregorian 2026 2 28) (23 * 3600 + 50 * 60) testStalledTrackerReconciledOnRestart :: HasCallStack => TestParams -> IO () testStalledTrackerReconciledOnRestart ps = do svc@GroupSvc {gsKey} <- prepareGroupService ps - stalledItemId <- runWithOwner svc $ \cc env _ alice -> do + (stalledItemId, code) <- runWithOwner svc $ \cc env _ alice -> do (stalledItemId, _, code) <- issueTracked cc alice "supporter" 5 redeemOk gsKey cc env code redeemOk gsKey cc env code awaitLane cc env - stalled <- waitItemText cc stalledItemId "3/5 remaining" + stalled <- waitItemText cc stalledItemId "3 of 5 uses remaining" redeemLosingRefresh gsKey cc code readItemText cc stalledItemId `shouldReturn` stalled - pure stalledItemId + dateRedemption cc 5 lostRedeemedAt + pure (stalledItemId, code) runGroupService svc $ \cc env _ -> do - corrected <- waitItemText cc stalledItemId "2/5 remaining" - corrected `shouldSatisfy` T.isInfixOf "Last redeemed: " + corrected <- waitItemText cc stalledItemId "2 of 5 uses remaining" + corrected `shouldBe` ("!2 " <> code <> "!\n2 of 5 uses remaining, last used 2026-02-28 23:50 UTC") awaitLane cc env - exhaustedNotices cc `shouldReturn` [] - redeemedTrackerCount cc `shouldReturn` 1 + sentItemsWithCode cc code `shouldReturn` [corrected] testRevokedTrackerReconciledOnRestart :: HasCallStack => TestParams -> IO () testRevokedTrackerReconciledOnRestart ps = do @@ -921,7 +901,7 @@ testRevokedTrackerReconciledOnRestart ps = do readItemText cc trackerItemId `shouldReturn` tracker0 pure (trackerItemId, code) runGroupService svc $ \cc env _ -> do - retired <- waitItemText cc trackerItemId "revoked" + retired <- waitItemText cc trackerItemId "Revoked" retired `shouldBe` retiredText code awaitLane cc env revokedTrackerCount cc `shouldReturn` 1 @@ -938,12 +918,11 @@ testEveryStalledTrackerReconciled ps = do readItemText cc secondItemId `shouldReturn` second0 pure (firstItemId, secondItemId) runGroupService svc $ \cc env _ -> do - first1 <- waitItemText cc firstItemId "3/5 remaining" - first1 `shouldSatisfy` T.isInfixOf "Last redeemed: " - second1 <- waitItemText cc secondItemId "2/3 remaining" - second1 `shouldSatisfy` T.isInfixOf "Last redeemed: " + first1 <- waitItemText cc firstItemId "3 of 5 uses remaining" + first1 `shouldSatisfy` T.isInfixOf "last used " + second1 <- waitItemText cc secondItemId "2 of 3 uses remaining" + second1 `shouldSatisfy` T.isInfixOf "last used " awaitLane cc env - exhaustedNotices cc `shouldReturn` [] redeemedTrackerCount cc `shouldReturn` 2 testUneditableTrackerLeftAlone :: HasCallStack => TestParams -> IO () @@ -959,7 +938,7 @@ testUneditableTrackerLeftAlone ps = do pure (staleItemId, stale0, staleCode, liveItemId, liveCode) runGroupService svc $ \cc env _ -> do redeemOk gsKey cc env liveCode - void $ waitItemText cc liveItemId "2/3 remaining" + void $ waitItemText cc liveItemId "2 of 3 uses remaining" readItemText cc staleItemId `shouldReturn` stale0 sentItemsWithCode cc staleCode `shouldReturn` [stale0] trackerAnchor cc 2 `shouldReturn` Just staleItemId @@ -970,15 +949,14 @@ testRevokeRetiresTracker ps = offsetCodeIds cc (trackerItemId, _, code) <- issueTracked cc alice "supporter" 2 redeemOk gsKey cc env code - void $ waitItemText cc trackerItemId "1/2 remaining" - revokeInGroup cc alice code "revoked" - retired <- waitItemText cc trackerItemId "revoked" + void $ waitItemText cc trackerItemId "1 of 2 uses remaining" + revokeInGroup cc alice code "Revoked." + retired <- waitItemText cc trackerItemId "Revoked" retired `shouldBe` retiredText code revokedTrackerCount cc `shouldReturn` 1 - replayRefresh cc env code 2 2 + replayRefresh cc env code 2 awaitLane cc env readItemText cc trackerItemId `shouldReturn` retired - exhaustedNotices cc `shouldReturn` [] revokedTrackerCount cc `shouldReturn` 1 redeemViaService gsKey cc env code >>= (`shouldAnswerError` BSECodeInvalid) @@ -988,14 +966,14 @@ testServiceRevokeRetiresTracker ps = offsetCodeIds cc (trackerItemId, _, code) <- issueTracked cc alice "supporter" 2 redeemOk gsKey cc env code - void $ waitItemText cc trackerItemId "1/2 remaining" - revokeRaw cc code `shouldReturn` Right "revoked" + void $ waitItemText cc trackerItemId "1 of 2 uses remaining" + revokeRaw cc code `shouldReturn` Right "Revoked." readItemText cc trackerItemId `shouldReturn` retiredText code revokedTrackerCount cc `shouldReturn` 1 - revokeRaw cc code `shouldReturn` Right "already revoked" + revokeRaw cc code `shouldReturn` Right "Already revoked." revokedTrackerCount cc `shouldReturn` 1 single <- extractCode <$> replyTo cc alice "/issue legend" - revokeRaw cc single `shouldReturn` Right "revoked" + revokeRaw cc single `shouldReturn` Right "Revoked." revokedTrackerCount cc `shouldReturn` 1 testServiceRevokeRepairsTracker :: HasCallStack => TestParams -> IO () @@ -1005,7 +983,7 @@ testServiceRevokeRepairsTracker ps = (trackerItemId, tracker0, code) <- issueTracked cc alice "supporter" 2 revokeInStore cc 2 readItemText cc trackerItemId `shouldReturn` tracker0 - revokeRaw cc code `shouldReturn` Right "already revoked" + revokeRaw cc code `shouldReturn` Right "Already revoked." readItemText cc trackerItemId `shouldReturn` retiredText code revokedTrackerCount cc `shouldReturn` 1 @@ -1035,12 +1013,12 @@ queueRedemption cc env codeText = do redeemLosingRefresh :: HasCallStack => BadgeIssuerKey -> ChatController -> Text -> IO () redeemLosingRefresh key cc codeText = newTQueueIO >>= \q -> redeemOkWith key cc (Just q) codeText -replayRefresh :: HasCallStack => ChatController -> ServiceState -> Text -> Int -> Int -> IO () -replayRefresh cc env codeText uses claim = case parseBadgeCode codeText of +replayRefresh :: HasCallStack => ChatController -> ServiceState -> Text -> Int -> IO () +replayRefresh cc env codeText uses = case parseBadgeCode codeText of Nothing -> error $ "not a badge code: " <> T.unpack codeText Just code -> do badgeCodeId <- trackedCodeId cc uses - atomically $ writeTQueue (groupEventQ env) (GETracker badgeCodeId code claim) + atomically $ writeTQueue (groupEventQ env) (GETracker badgeCodeId code) getStoredGroup :: ChatController -> IO (Maybe ManagedGroup) getStoredGroup cc = withTransaction (chatStore cc) getManagedGroup @@ -1386,26 +1364,13 @@ waitTrackerRepost :: HasCallStack => ChatController -> Int -> Int64 -> IO (Int64 waitTrackerRepost cc uses itemId0 = pollUntil $ mfilter ((/= itemId0) . fst) <$> trackerItem cc uses redeemedTrackerCount :: ChatController -> IO Int -redeemedTrackerCount cc = countRows cc "chat_items WHERE item_text LIKE '%Last redeemed%'" +redeemedTrackerCount cc = countRows cc "chat_items WHERE item_text LIKE '%last used%'" revokedTrackerCount :: ChatController -> IO Int revokedTrackerCount cc = countRows cc ("chat_items WHERE item_text LIKE '" <> T.unpack (retiredText "SB-%") <> "'") retiredText :: Text -> Text -retiredText code = code <> " revoked — no longer redeemable" - -exhaustedText :: Text -> Int -> Text -exhaustedText code uses = code <> " fully redeemed — all " <> tshow uses <> " used" - --- Notices are not filtered by code or total, so a wrong one still shows up. -exhaustedNotices :: ChatController -> IO [Text] -exhaustedNotices cc = queryColumn cc "SELECT item_text FROM chat_items WHERE item_text LIKE '%fully redeemed%' ORDER BY chat_item_id" - -waitExhausted :: HasCallStack => ChatController -> IO Text -waitExhausted cc = - pollUntil (mfilter (not . null) . Just <$> exhaustedNotices cc) >>= \case - [t] -> pure t - ts -> error $ "expected one exhaustion notice, got " <> show (length ts) +retiredText code = code <> "\nRevoked, can no longer be redeemed" extractCode :: HasCallStack => Text -> Text extractCode t = maybe (error ("no badge code in: " <> T.unpack t)) formatBadgeCode (codeInTracker t) diff --git a/tests/Bots/BadgeService/GroupTests.hs b/tests/Bots/BadgeService/GroupTests.hs index d8eecf1ecc..c592178a91 100644 --- a/tests/Bots/BadgeService/GroupTests.hs +++ b/tests/Bots/BadgeService/GroupTests.hs @@ -22,9 +22,9 @@ import Test.Hspec badgeGroupTests :: Spec badgeGroupTests = describe "badge group" $ do let p = groupCmdAction GROwner - issueUsage = ReplyText "use: /issue [months ] [uses ]" - bulkUsage = ReplyText "use: /bulk [months ] count " - revokeUsage = ReplyText "use: /revoke " + issueUsage = ReplyText "Usage: /issue [months ] [uses ]" + bulkUsage = ReplyText "Usage: /bulk [months ] 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) it "bulk with count" $ p "/bulk supporter count 20" `shouldBe` RunCmd (GCBulk BTSupporter 1 20) @@ -111,7 +111,7 @@ badgeGroupTests = describe "badge group" $ do it "tells a sender below admin that their revoke did not happen" $ do code <- newCode map (`groupCmdAction` ("/revoke " <> badgeCodeText code)) [GRMember, GRModerator] - `shouldBe` replicate 2 (ReplyText "only admins can revoke codes, and this code is now visible to the group - ask an admin to revoke it") + `shouldBe` replicate 2 (ReplyText "Only admins can revoke codes. This code is now visible to all members.") describe "configured group name and description" $ do let cfg name descr = GroupConfig {gDisplayName = name, gDescription = descr} profile name descr = @@ -156,22 +156,20 @@ badgeGroupTests = describe "badge group" $ do trackerDecision within t0 `shouldBe` Edit trackerDecision past t0 `shouldBe` Repost describe "coalescing tracker refreshes" $ do - it "keeps one refresh per code, carrying the highest claim" $ do - code <- newCode - coalesceTrackerRefreshes [GETracker 1 code 1, GETracker 1 code 3, GETracker 2 code 1] - `shouldBe` [GETracker 1 code 3, GETracker 2 code 1] - it "keeps the highest claim whichever order it queued in" $ do - code <- newCode - coalesceTrackerRefreshes [GETracker 1 code 3, GETracker 1 code 1] `shouldBe` [GETracker 1 code 3] + it "keeps the last refresh of each code" $ do + code1 <- newCode + code2 <- newCode + coalesceTrackerRefreshes [GETracker 1 code1, GETracker 2 code2, GETracker 1 code1] + `shouldBe` [GETracker 2 code2, GETracker 1 code1] it "keeps every other event, in order" $ do code <- newCode coalesceTrackerRefreshes [ GEInGroup 7 (GACommand GRAdmin "a"), - GETracker 1 code 1, + GETracker 1 code, GEInGroup 7 GAJoined, - GETracker 1 code 2 + GETracker 1 code ] - `shouldBe` [GEInGroup 7 (GACommand GRAdmin "a"), GEInGroup 7 GAJoined, GETracker 1 code 2] + `shouldBe` [GEInGroup 7 (GACommand GRAdmin "a"), GEInGroup 7 GAJoined, GETracker 1 code] newCode :: IO BadgeCode newCode = C.newRandom >>= randomBadgeCode diff --git a/tests/Bots/BadgeService/WebTests.hs b/tests/Bots/BadgeService/WebTests.hs index 71a3b60d15..b83f4f8f05 100644 --- a/tests/Bots/BadgeService/WebTests.hs +++ b/tests/Bots/BadgeService/WebTests.hs @@ -159,7 +159,7 @@ badgeWebTests = do it "refuses a second row and burns the flag per group" testManagedGroupIsSingleRow describe "multi-use" $ do it "finds a key's own purchase with its newest credential, and none for another key" testKeyPurchaseLookup - it "gives concurrent claims exactly the code's uses, each a distinct count" testMultiUseConcurrentClaimsUpToLimit + it "gives concurrent claims exactly the code's uses" testMultiUseConcurrentClaimsUpToLimit it "refuses a second claim by the same key without using up a use" testSameKeyClaimsOnce describe "badge service catalog seed" $ do it "writes the compiled-in catalog into an empty database" testSeedWritesTheCatalog @@ -728,7 +728,7 @@ insertCode :: DBStore -> ByteString -> BadgeCodePaymentStatus -> Int -> UTCTime insertCode st codeHash paymentStatus redeemLimit now = withTransaction st $ \db -> insertBadgeCode db codeHash BTSupporter 1 paymentStatus redeemLimit now -claimUse :: DBStore -> Int64 -> UTCTime -> (C.PublicKeyEd25519, BadgeMasterKey) -> IO (Maybe (Int64, Int)) +claimUse :: DBStore -> Int64 -> UTCTime -> (C.PublicKeyEd25519, BadgeMasterKey) -> IO (Maybe Int64) claimUse st badgeCodeId now (purchaseKey, masterKey) = withTransaction st $ \db -> createCodePurchase db NewCodePurchase {badgeCodeId, purchaseKey, masterKey, badgeType = BTSupporter} now @@ -752,7 +752,7 @@ testKeyPurchaseLookup = withServiceStore $ \st -> do let codeHash = digestFixture 41 badgeCodeId <- insertCode st codeHash CPSFree 2 now keys@(k1, mk1) <- newPurchaseKeys - Just (purchaseId, _) <- claimUse st badgeCodeId now keys + Just purchaseId <- claimUse st badgeCodeId now keys withTransaction st (\db -> getCodePurchaseForKey db badgeCodeId k1) >>= \case KeyRedeemedUnreadable -> pure () _ -> expectationFailure "expected a purchase with no issuance to be unreadable" @@ -789,7 +789,7 @@ testMultiUseConcurrentClaimsUpToLimit = withServiceStore $ \st -> do badgeCodeId <- insertCode st codeHash CPSFree 3 now contenders <- replicateM 6 newPurchaseKeys results <- Async.mapConcurrently (claimUse st badgeCodeId now) contenders - sort (map snd $ catMaybes results) `shouldBe` [1, 2, 3] + length (catMaybes results) `shouldBe` 3 codeCounts st codeHash `shouldReturn` Just (3, 3) data StubCall