From 424602bf60e484ca42e03465eaaaeacd0a36314e Mon Sep 17 00:00:00 2001 From: shum Date: Fri, 25 Sep 2026 15:51:22 +0000 Subject: [PATCH] badges: add multi-use codes --- .../src/BadgeService/Codes.hs | 28 +++ .../src/BadgeService/Service.hs | 52 ++--- .../src/BadgeService/Store.hs | 113 +++++----- .../BadgeService/Store/Postgres/Migrations.hs | 31 ++- .../BadgeService/Store/SQLite/Migrations.hs | 31 ++- simplex-chat.cabal | 2 + tests/Bots/BadgeService/BotTests.hs | 210 ++++++++++++++++-- tests/Bots/BadgeService/WebTests.hs | 171 ++++++++++++-- 8 files changed, 526 insertions(+), 112 deletions(-) create mode 100644 apps/simplex-badge-service/src/BadgeService/Codes.hs diff --git a/apps/simplex-badge-service/src/BadgeService/Codes.hs b/apps/simplex-badge-service/src/BadgeService/Codes.hs new file mode 100644 index 0000000000..195adf849d --- /dev/null +++ b/apps/simplex-badge-service/src/BadgeService/Codes.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} + +module BadgeService.Codes + ( issueOneCode, + singleUse, + ) +where + +import BadgeService.Store (insertBadgeCode) +import BadgeService.Store.Invoices (truncateToSecond) +import Data.Int (Int64) +import Data.Time.Clock (getCurrentTime) +import Simplex.Chat.Badges (BadgeType) +import Simplex.Chat.Badges.Code (BadgeCode, badgeCodeHash, randomBadgeCode) +import Simplex.Chat.Badges.Types (BadgeCodePaymentStatus) +import Simplex.Chat.Bot.Store (withDB') +import Simplex.Chat.Controller (ChatController (..)) + +singleUse :: Int +singleUse = 1 + +-- | 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)) +issueOneCode cc badgeType months paymentStatus redeemLimit = do + code <- randomBadgeCode $ random cc + now <- truncateToSecond <$> getCurrentTime + fmap (code,) <$> withDB' "issueBadgeCode" cc (\db -> insertBadgeCode db (badgeCodeHash code) badgeType months paymentStatus redeemLimit now) diff --git a/apps/simplex-badge-service/src/BadgeService/Service.hs b/apps/simplex-badge-service/src/BadgeService/Service.hs index 9a3a3f4236..03ead6e987 100644 --- a/apps/simplex-badge-service/src/BadgeService/Service.hs +++ b/apps/simplex-badge-service/src/BadgeService/Service.hs @@ -21,6 +21,7 @@ module BadgeService.Service where import BadgeService.Catalog (defaultCatalog) +import BadgeService.Codes (issueOneCode, singleUse) import BadgeService.Config (BadgeIssuerKey (..), ServiceConfig (..), readServiceConfig) import BadgeService.Options import BadgeService.Poller (newPollerEnv, newReadHints, runPoller) @@ -259,13 +260,9 @@ data IssueCodeOpts = IssueCodeOpts paymentStatus :: BadgeCodePaymentStatus } --- | The caller sees the code once; only its hash is stored, so a lost code cannot be recovered. issueBadgeCode :: ChatController -> IssueCodeOpts -> IO (Either String BadgeCode) -issueBadgeCode cc IssueCodeOpts {badgeType, months, paymentStatus} = do - code <- randomBadgeCode $ random cc - now <- getCurrentTime - r <- withDB' "issueBadgeCode" cc $ \db -> insertBadgeCode db (badgeCodeHash code) badgeType months paymentStatus now - pure $ code <$ r +issueBadgeCode cc IssueCodeOpts {badgeType, months, paymentStatus} = + fmap fst <$> issueOneCode cc badgeType months paymentStatus singleUse processQueuedRequests :: BadgeIssuerKey -> ServiceState -> IO () processQueuedRequests key env = do @@ -395,14 +392,14 @@ redeemCode key cc purchaseKey masterKey codeText = case parseBadgeCode codeText Just issued -> credentialForEntry key masterKey issued >>= \case Left e -> logError ("badge service signing failed: " <> T.pack e) $> errorResponse BSEInternal Right signed -> do - -- If the code was revoked or redeemed while signing, the claim fails. Read the code again to tell the client why. + -- If the code was revoked or used up while signing, the claim fails. Read the code again to tell the client why. r <- withDB "writeCodeRedemption" cc $ \db -> liftIO (createCodePurchase db NewCodePurchase {badgeCodeId, purchaseKey, masterKey, badgeType} now) >>= \case Nothing -> readCode now code db >>= \case Left resp -> pure resp - Right _ -> logError "badge service: redeeming a code failed, but the code is neither redeemed nor revoked" $> errorResponse BSEInternal - Just purchaseId -> liftIO $ do + Right _ -> logError "badge service: redeeming a code failed, but the code has uses left and is not revoked" $> errorResponse BSEInternal + 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_ @@ -411,25 +408,24 @@ redeemCode key cc purchaseKey masterKey codeText = case parseBadgeCode codeText readCode now code db = liftIO $ getBadgeCode db (badgeCodeHash code) >>= \case Nothing -> pure $ Left $ errorResponse BSECodeInvalid - Just c@IssuedCode {revokedAt, paymentStatus, expiresAt, redemption} - -- Revoked is checked first, so it answers as if the code never existed. - | Just _ <- revokedAt -> pure $ Left $ errorResponse BSECodeInvalid - -- Redeeming an unpaid code would issue a free badge, so unpaid is refused. - | CPSUnpaid <- paymentStatus -> pure $ Left $ errorResponse BSEPaymentPending - | otherwise -> - checkUnspent db redemption >>= \case - Left resp -> pure $ Left resp - Right () - | maybe False (now >=) expiresAt -> pure $ Left $ errorResponse BSECodeExpired - | otherwise -> pure $ Right c - checkUnspent db = \case - CodeUnredeemed -> pure $ Right () - CodeRedeemedUnreadable -> pure $ Left $ errorResponse BSEInternal - CodeRedeemed RedeemedCode {purchaseKey = k, badgePurchaseId, credential} - | k /= purchaseKey -> pure $ Left $ errorResponse BSECodeUsed - | otherwise -> - maybe (Left $ errorResponse BSEInternal) (Left . credentialResponse (Just credential) Nothing) - <$> getLedgerEntries db badgePurchaseId 0 + Just c@IssuedCode {badgeCodeId, revokedAt, paymentStatus, expiresAt, redeemLimit, redeemCount} -> + getCodePurchaseForKey db badgeCodeId purchaseKey >>= \case + -- A key that already redeemed gets its credential back without a use, even if the code has since + -- expired or been revoked: a client whose reply was lost retries, and would otherwise lose the badge. + KeyRedeemed KeyPurchase {badgePurchaseId, credential} -> + maybe (Left $ errorResponse BSEInternal) (Left . credentialResponse (Just credential) Nothing) + <$> getLedgerEntries db badgePurchaseId 0 + -- code_used would make the client drop its keys, so the holder could never get the badge back. + KeyRedeemedUnreadable -> + logError "badge service: a redeemed code's credential is missing or unreadable" $> Left (errorResponse BSEInternal) + KeyUnredeemed + -- Revoked is checked first, so it answers as if the code never existed. + | Just _ <- revokedAt -> pure $ Left $ errorResponse BSECodeInvalid + -- Redeeming an unpaid code would issue a free badge, so unpaid is refused. + | CPSUnpaid <- paymentStatus -> pure $ Left $ errorResponse BSEPaymentPending + | redeemCount >= redeemLimit -> pure $ Left $ errorResponse BSECodeUsed + | maybe False (now >=) expiresAt -> pure $ Left $ errorResponse BSECodeExpired + | otherwise -> pure $ Right c -- | The purchase is reached through the verified signer key and no other way. issueBadgeCmd :: BadgeIssuerKey -> ChatController -> C.PublicKeyEd25519 -> BadgeBalance -> IO BadgeServiceResponse diff --git a/apps/simplex-badge-service/src/BadgeService/Store.hs b/apps/simplex-badge-service/src/BadgeService/Store.hs index d8ab44c268..ab39dc38ad 100644 --- a/apps/simplex-badge-service/src/BadgeService/Store.hs +++ b/apps/simplex-badge-service/src/BadgeService/Store.hs @@ -4,14 +4,16 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} module BadgeService.Store ( IssuedCode (..), - CodeRedemption (..), - RedeemedCode (..), + KeyRedemption (..), + KeyPurchase (..), NewCodePurchase (..), ServicePurchase (..), getBadgeCode, + getCodePurchaseForKey, purchaseKeyExists, getPurchaseByKey, getLedgerTip, @@ -27,6 +29,7 @@ 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 @@ -58,17 +61,17 @@ data IssuedCode = IssuedCode paymentStatus :: BadgeCodePaymentStatus, revokedAt :: Maybe UTCTime, expiresAt :: Maybe UTCTime, - redemption :: CodeRedemption + redeemLimit :: Int, + redeemCount :: Int } -data CodeRedemption - = CodeUnredeemed - | CodeRedeemed RedeemedCode - | CodeRedeemedUnreadable +data KeyRedemption + = KeyUnredeemed + | KeyRedeemed KeyPurchase + | KeyRedeemedUnreadable -data RedeemedCode = RedeemedCode +data KeyPurchase = KeyPurchase { badgePurchaseId :: Int64, - purchaseKey :: C.PublicKeyEd25519, credential :: BadgeCredential } @@ -91,24 +94,33 @@ getBadgeCode db codeHash = DB.query db [sql| - SELECT c.badge_code_id, c.badge_type, c.months, c.code_payment_status, c.revoked_at, - c.expires_at, p.badge_purchase_id, p.purchase_key, i.credential - FROM sx_badge_service_badge_codes c - LEFT JOIN sx_badge_service_badge_purchases p ON p.badge_code_id = c.badge_code_id - LEFT JOIN sx_badge_service_badge_issuances i ON i.badge_purchase_id = p.badge_purchase_id - WHERE c.code_hash = ? - ORDER BY i.period_end DESC - LIMIT 1 + SELECT badge_code_id, badge_type, months, code_payment_status, revoked_at, expires_at, redeem_limit, redeem_count + FROM sx_badge_service_badge_codes + WHERE code_hash = ? |] (Only (Binary codeHash)) where - toCode (badgeCodeId, badgeType, months, paymentStatus, revokedAt, expiresAt, purchaseId_, purchaseKey_, credential_) = - IssuedCode {badgeCodeId, badgeType, months, paymentStatus, revokedAt, expiresAt, redemption = codeRedemption purchaseId_ purchaseKey_ credential_} - codeRedemption purchaseId_ purchaseKey_ credential_ = case (purchaseId_, purchaseKey_) of - (Just badgePurchaseId, Just purchaseKey) -> case decodeCredential =<< credential_ of - Just credential -> CodeRedeemed RedeemedCode {badgePurchaseId, purchaseKey, credential} - Nothing -> CodeRedeemedUnreadable - _ -> CodeUnredeemed + toCode (badgeCodeId, badgeType, months, paymentStatus, revokedAt, expiresAt, redeemLimit, redeemCount) = + IssuedCode {badgeCodeId, badgeType, months, paymentStatus, revokedAt, expiresAt, redeemLimit, redeemCount} + +getCodePurchaseForKey :: DB.Connection -> Int64 -> C.PublicKeyEd25519 -> IO KeyRedemption +getCodePurchaseForKey db badgeCodeId key = + maybeFirstRow' KeyUnredeemed toRedemption $ + DB.query + db + [sql| + SELECT p.badge_purchase_id, i.credential + FROM sx_badge_service_badge_purchases p + LEFT JOIN sx_badge_service_badge_issuances i ON i.badge_purchase_id = p.badge_purchase_id + WHERE p.badge_code_id = ? AND p.purchase_key = ? + ORDER BY i.period_end DESC + LIMIT 1 + |] + (badgeCodeId, key) + where + toRedemption (badgePurchaseId, credential_) = case decodeCredential =<< credential_ of + Just credential -> KeyRedeemed KeyPurchase {badgePurchaseId, credential} + Nothing -> KeyRedeemedUnreadable decodeCredential (Binary bs) = J.decodeStrict' bs purchaseKeyExists :: DB.Connection -> C.PublicKeyEd25519 -> IO Bool @@ -222,39 +234,37 @@ appendLedgerPlan db purchaseId rows issuance_ = do ((entryId, purchaseId, changeMonths, balanceMonths, balanceStartTs, balanceAnchorTs) :. (balanceBadgeType, createdAt, createdAt, entryTypeT, creditType, debitType)) insertedRowId db --- redeemed_at is stamped here, so this must run in the same transaction as the credential rows. --- Mark the code as redeemed before adding the purchase. On Postgres, a revoke or redemption running --- at the same time then waits, sees the code is taken, and fails. -createCodePurchase :: DB.Connection -> NewCodePurchase -> UTCTime -> IO (Maybe Int64) +-- 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)) createCodePurchase db NewCodePurchase {badgeCodeId, purchaseKey, masterKey = BadgeMasterKey mk, badgeType} now = do - claimed <- - executeChanging - db - "UPDATE sx_badge_service_badge_codes SET redeemed_at = ? WHERE badge_code_id = ? AND redeemed_at IS NULL AND revoked_at IS NULL" - (now, badgeCodeId) - if claimed == 0 - then pure Nothing - else do - DB.execute + claimed_ <- + maybeFirstRow fromOnly $ + DB.query 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 + "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 + 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 data RevokeResult = Revoked | AlreadyRevoked | AlreadyRedeemed | NoSuchCode deriving (Eq, Show) --- | A code that was already redeemed can't be revoked, because its badge was already given out. +-- | A code with no uses left can't be revoked, because every badge it grants was already given out. revokeCode :: DB.Connection -> ByteString -> UTCTime -> IO RevokeResult revokeCode db codeHash now = do revoked <- executeChanging db - "UPDATE sx_badge_service_badge_codes SET revoked_at = ? WHERE code_hash = ? AND revoked_at IS NULL AND redeemed_at IS NULL" + "UPDATE sx_badge_service_badge_codes SET revoked_at = ? WHERE code_hash = ? AND revoked_at IS NULL AND redeem_count < redeem_limit" (now, Binary codeHash) if revoked > 0 then pure Revoked @@ -265,12 +275,13 @@ revokeCode db codeHash now = do refusal :: Only (Maybe UTCTime) -> RevokeResult refusal (Only revokedAt) = maybe AlreadyRedeemed (const AlreadyRevoked) revokedAt -insertBadgeCode :: DB.Connection -> ByteString -> BadgeType -> Int -> BadgeCodePaymentStatus -> UTCTime -> IO () -insertBadgeCode db codeHash badgeType months paymentStatus now = +insertBadgeCode :: DB.Connection -> ByteString -> BadgeType -> Int -> BadgeCodePaymentStatus -> Int -> UTCTime -> IO Int64 +insertBadgeCode db codeHash badgeType months paymentStatus redeemLimit now = do DB.execute db [sql| - INSERT INTO sx_badge_service_badge_codes (code_hash, badge_type, months, code_payment_status, created_at) - VALUES (?,?,?,?,?) + INSERT INTO sx_badge_service_badge_codes (code_hash, badge_type, months, code_payment_status, redeem_limit, created_at) + VALUES (?,?,?,?,?,?) |] - (Binary codeHash, badgeType, months, paymentStatus, now) + (Binary codeHash, badgeType, months, paymentStatus, redeemLimit, now) + insertedRowId db diff --git a/apps/simplex-badge-service/src/BadgeService/Store/Postgres/Migrations.hs b/apps/simplex-badge-service/src/BadgeService/Store/Postgres/Migrations.hs index c8179d5df2..c59fa73b5e 100644 --- a/apps/simplex-badge-service/src/BadgeService/Store/Postgres/Migrations.hs +++ b/apps/simplex-badge-service/src/BadgeService/Store/Postgres/Migrations.hs @@ -17,7 +17,8 @@ badgeServiceSchemaMigrations = sortOn name $ map migration schemaMigrations schemaMigrations :: [(String, Text, Maybe Text)] schemaMigrations = - [ ("20260915_badge_service_schema", m20260915_badge_service_schema, Just down_m20260915_badge_service_schema) + [ ("20260915_badge_service_schema", m20260915_badge_service_schema, Just down_m20260915_badge_service_schema), + ("20260918_badge_group_ops", m20260918_badge_group_ops, Just down_m20260918_badge_group_ops) ] -- | The client tables share this database, so the service tables are the same names behind a prefix. @@ -109,6 +110,34 @@ DROP INDEX @idx_badge_purchases_code; DROP TABLE @badge_codes; |] +m20260918_badge_group_ops :: Text +m20260918_badge_group_ops = + withPrefix + servicePrefix + [r| +ALTER TABLE @badge_codes ADD COLUMN redeem_limit INTEGER NOT NULL DEFAULT 1; + +ALTER TABLE @badge_codes ADD COLUMN redeem_count INTEGER NOT NULL DEFAULT 0; + +-- Redemptions made before this migration must count against the new limit, or every code +-- redeemed already would read as unspent and could be redeemed once more. +UPDATE @badge_codes SET redeem_count = 1 WHERE redeemed_at IS NOT NULL; + +DROP INDEX @idx_badge_purchases_code; + +CREATE INDEX @idx_badge_purchases_code ON @badge_purchases(badge_code_id); +|] + +-- The index stays non-unique, since a multi-use code may already have several purchases. +down_m20260918_badge_group_ops :: Text +down_m20260918_badge_group_ops = + withPrefix + servicePrefix + [r| +ALTER TABLE @badge_codes DROP COLUMN redeem_count; +ALTER TABLE @badge_codes DROP COLUMN redeem_limit; +|] + {- TODO [badges] deferred with the draft in M20260915_user_badges, service only. ALTER TABLE @payments ADD COLUMN receipt_hash BYTEA; diff --git a/apps/simplex-badge-service/src/BadgeService/Store/SQLite/Migrations.hs b/apps/simplex-badge-service/src/BadgeService/Store/SQLite/Migrations.hs index bf022f189c..d2f5d274f6 100644 --- a/apps/simplex-badge-service/src/BadgeService/Store/SQLite/Migrations.hs +++ b/apps/simplex-badge-service/src/BadgeService/Store/SQLite/Migrations.hs @@ -18,7 +18,8 @@ badgeServiceSchemaMigrations = sortOn name $ map migration schemaMigrations schemaMigrations :: [(String, Query, Maybe Query)] schemaMigrations = - [ ("20260915_badge_service_schema", m20260915_badge_service_schema, Just down_m20260915_badge_service_schema) + [ ("20260915_badge_service_schema", m20260915_badge_service_schema, Just down_m20260915_badge_service_schema), + ("20260918_badge_group_ops", m20260918_badge_group_ops, Just down_m20260918_badge_group_ops) ] -- | The client tables share this database, so the service tables are the same names behind a prefix. @@ -110,6 +111,34 @@ DROP INDEX @idx_badge_purchases_code; DROP TABLE @badge_codes; |] +m20260918_badge_group_ops :: Query +m20260918_badge_group_ops = + withPrefix + servicePrefix + [sql| +ALTER TABLE @badge_codes ADD COLUMN redeem_limit INTEGER NOT NULL DEFAULT 1; + +ALTER TABLE @badge_codes ADD COLUMN redeem_count INTEGER NOT NULL DEFAULT 0; + +-- Redemptions made before this migration must count against the new limit, or every code +-- redeemed already would read as unspent and could be redeemed once more. +UPDATE @badge_codes SET redeem_count = 1 WHERE redeemed_at IS NOT NULL; + +DROP INDEX @idx_badge_purchases_code; + +CREATE INDEX @idx_badge_purchases_code ON @badge_purchases(badge_code_id); +|] + +-- The index stays non-unique, since a multi-use code may already have several purchases. +down_m20260918_badge_group_ops :: Query +down_m20260918_badge_group_ops = + withPrefix + servicePrefix + [sql| +ALTER TABLE @badge_codes DROP COLUMN redeem_count; +ALTER TABLE @badge_codes DROP COLUMN redeem_limit; +|] + {- TODO [badges] deferred with the draft in M20260915_user_badges, service only. ALTER TABLE @payments ADD COLUMN receipt_hash BLOB; diff --git a/simplex-chat.cabal b/simplex-chat.cabal index e759fbdd3e..548b2e5c7d 100644 --- a/simplex-chat.cabal +++ b/simplex-chat.cabal @@ -429,6 +429,7 @@ executable simplex-badge-service StrictData other-modules: BadgeService.Catalog + BadgeService.Codes BadgeService.Config BadgeService.Log BadgeService.Options @@ -717,6 +718,7 @@ test-suite simplex-chat-test API.Docs.Types API.TypeInfo BadgeService.Catalog + BadgeService.Codes BadgeService.Config BadgeService.Log BadgeService.Options diff --git a/tests/Bots/BadgeService/BotTests.hs b/tests/Bots/BadgeService/BotTests.hs index c11af7f4d1..a6b57a6674 100644 --- a/tests/Bots/BadgeService/BotTests.hs +++ b/tests/Bots/BadgeService/BotTests.hs @@ -10,10 +10,12 @@ module Bots.BadgeService.BotTests where +import BadgeService.Codes (issueOneCode) import BadgeService.Config (BadgeIssuerKey (..), readServiceConfig) import Bots.BadgeService.ConfigTests (withIssuer) import BadgeService.Options import BadgeService.Service +import BadgeService.Store (IssuedCode (..), getBadgeCode) import BadgeService.Store.Invoices (markCodePaid) import Simplex.Messaging.Agent.Store.DB (Binary (..)) import qualified Simplex.Messaging.Agent.Store.DB as DB @@ -43,6 +45,7 @@ import Simplex.Chat.Badges (BadgeCredential (..), BadgeInfo (..), BadgeMasterKey import Simplex.Chat.Badges.Code (BadgeCode, badgeCodeHash, badgeCodeText, formatBadgeCode, parseBadgeCode, randomBadgeCode) import Simplex.Chat.Badges.Ledger (addMonths, creditTypeTag, debitTypeTag, endOfMondayAfter) import Simplex.Chat.Badges.Service +import Simplex.Chat.Badges.Types (BadgeCodePaymentStatus (..)) import Simplex.Chat.Bot.Store (withDB') import Simplex.Chat.Controller (ChatConfig (..), ChatController (..), ChatResponse (CRCustomChatResponse)) import Simplex.Chat.Core (sendChatCmdStr) @@ -50,7 +53,7 @@ import Simplex.Chat.Options (CoreChatOpts (..)) import Simplex.Chat.Options.DB import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (..)) import Simplex.Messaging.Agent.RetryInterval (RetryInterval (..)) -import Simplex.Messaging.Agent.Store.Common (withTransaction) +import Simplex.Messaging.Agent.Store.Common (DBStore, withTransaction) import Simplex.Messaging.Agent.Store.DB (BoolInt (..)) import Simplex.Chat.Types (ChatPeerType (..), Profile (..)) import qualified Simplex.Messaging.Crypto as C @@ -85,11 +88,16 @@ badgeServiceTests = do it "should refuse to start when the [issuer] key is not one clients trust" testIssuerIniKeyMustBeTrusted it "should credit a code's months and issue one credential per month" testCodeMonthsRenew it "should return the stored credential for a repeat inside an issued period" testRepeatInsideIssuedPeriod + it "should redeem a multi-use code to its limit" testMultiUseWithoutGroup + it "should not spend a multi-use code again when its holder redeems it after the badge ended" testMultiUseRepeatAfterExpiry + it "should answer internal, spending no use, when a holder's stored credential is unreadable" testUnreadableCredentialIsInternal it "should lapse only the months that elapsed while the client was away" testLapseWhileAway it "should round the last month's expiry up to the end of the Monday after it" testLastMonthExpiryRounds it "should sign a renewal with the master key stored on the purchase" testRenewalSignsWithStoredMasterKey it "should leave the client holding the same ledger rows as the service" testClientReplicatesLedger it "should renew a badge whose credential is lapsing, with no command" testWorkerRenews + it "should keep answering and renewing a holder after its partly used multi-use code is revoked" testRevokedMultiUseHolderRenews + it "should return a multi-use holder's renewed credential on a repeat, apart from a later holder" testMultiUseHoldersRenewApart it "should request from the wake it set a day before the credential lapses" testRequestWakeFires it "should present from the wake it set at the credential's expiry" testPresentWakeFires it "should renew a badge whose newest ledger row is of an unknown type" testRenewsAfterUnknownEntry @@ -180,7 +188,9 @@ withBadgeServiceEnv ps test = do bsLink <- withTestChat ps serviceDbPrefix $ \bs -> do bs <## "subscribed 1 connections on server localhost" bs ##> "/sa" - (sLink, _) <- getContactLinks bs False + -- getContactLinks gives the old-clients line only half a second, which a loaded run can miss. + sLink <- getContactLink_ bs False + bs <##. "The contact link for old clients: " bs <## "auto_accept off" pure sLink let clientCfg = @@ -387,6 +397,17 @@ credentialOf = \case BSPBadgeCredential {credential} -> credential r -> error $ "expected badgeCredential, got " <> show (J.toJSON r) +shouldAnswerError :: HasCallStack => BadgeServiceResponse -> BadgeServiceErrorCode -> IO () +shouldAnswerError r expected = case r of + BSPError {code = ec} -> ec `shouldBe` expected + _ -> expectationFailure $ "expected " <> show expected <> ", got: " <> show (J.toJSON r) + +codeCounts :: DBStore -> ByteString -> IO (Maybe (Int, Int)) +codeCounts st codeHash = fmap (\IssuedCode {redeemLimit, redeemCount} -> (redeemLimit, redeemCount)) <$> withTransaction st (`getBadgeCode` codeHash) + +codeUses :: ChatController -> BadgeCode -> IO (Maybe (Int, Int)) +codeUses cc code = codeCounts (chatStore cc) (badgeCodeHash code) + nextDue :: [StatementEntry] -> UTCTime nextDue entries = let (_, _, start) = entryOf (last entries) in start @@ -396,6 +417,12 @@ newPurchaseKeys = do (purchaseKey, _) <- atomically $ C.generateKeyPair g :: IO (C.KeyPair 'C.Ed25519) (purchaseKey,) <$> generateMasterKey g +redeemAsNewPurchase :: HasCallStack => BadgeServiceEnv -> BadgeCode -> IO BadgeServiceResponse +redeemAsNewPurchase env code = newPurchaseKeys >>= \keys -> redeemWithKeys env keys code + +redeemWithKeys :: HasCallStack => BadgeServiceEnv -> (C.PublicKeyEd25519, BadgeMasterKey) -> BadgeCode -> IO BadgeServiceResponse +redeemWithKeys env (purchaseKey, masterKey) code = serviceCmd env purchaseKey BSCRedeemBadgeCode {masterKey, code = badgeCodeText code} + assertBalance :: HasCallStack => BadgeServiceEnv -> C.PublicKeyEd25519 -> StatementEntry -> IO BadgeServiceResponse assertBalance env purchaseKey lastEntry = serviceCmd env purchaseKey BSCIssueBadge {balance = BadgeBalance {lastEntry}} @@ -403,6 +430,9 @@ assertBalance env purchaseKey lastEntry = expiryOf :: HasCallStack => BadgeServiceResponse -> Maybe UTCTime expiryOf r = (\(BadgeCredential _ _ _ BadgeInfo {badgeExpiry}) -> badgeExpiry) <$> credentialOf r +badgeTypeOf :: HasCallStack => BadgeServiceResponse -> Maybe BadgeType +badgeTypeOf r = (\(BadgeCredential _ _ _ BadgeInfo {badgeType}) -> badgeType) <$> credentialOf r + masterKeyOf :: HasCallStack => BadgeServiceResponse -> Maybe BadgeMasterKey masterKeyOf r = (\(BadgeCredential _ mk _ _) -> mk) <$> credentialOf r @@ -410,8 +440,8 @@ testCodeMonthsRenew :: HasCallStack => TestParams -> IO () testCodeMonthsRenew ps = withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClock, bsController = cc} -> do code <- issueCode cc BTSupporter 3 - (purchaseKey, masterKey) <- newPurchaseKeys - redeemed <- serviceCmd env purchaseKey BSCRedeemBadgeCode {masterKey, code = badgeCodeText code} + keys@(purchaseKey, _) <- newPurchaseKeys + redeemed <- redeemWithKeys env keys code let (entries, previousEntryId) = statementOf redeemed previousEntryId `shouldBe` Nothing map entryTag entries `shouldBe` ["code", "badge"] @@ -435,19 +465,79 @@ testRepeatInsideIssuedPeriod :: HasCallStack => TestParams -> IO () testRepeatInsideIssuedPeriod ps = withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsController = cc} -> do code <- issueCode cc BTSupporter 2 - (purchaseKey, masterKey) <- newPurchaseKeys - redeemed <- serviceCmd env purchaseKey BSCRedeemBadgeCode {masterKey, code = badgeCodeText code} + keys@(purchaseKey, _) <- newPurchaseKeys + redeemed <- redeemWithKeys env keys code let (entries, _) = statementOf redeemed repeated <- assertBalance env purchaseKey (last entries) map entryTag (fst $ statementOf repeated) `shouldBe` [] credentialOf repeated `shouldBe` credentialOf redeemed +testMultiUseRepeatAfterExpiry :: HasCallStack => TestParams -> IO () +testMultiUseRepeatAfterExpiry ps = + withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClock, bsClientCfg, bsController = cc} -> + withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do + code <- issueMultiUseCode cc BTSupporter 1 2 + redeemFirstBadge alice code + rows <- ledgerRows (chatController alice) "badge_ledger" + setClockAt bsClock $ dueAtOf rows + alice ##> "/_app activate" + alice <## "ok" + alice <##. "badge alert: support_ended " + alice <##. "1: supporter" + alice <##. "badge alert: support_ended " + waitShownBadge (chatController alice) Nothing + -- The repeat uses the same purchase key, so the service returns the credential it already issued. + alice ##> ("/_redeem_badge_code 1 " <> codeArg code) + alice <## "badge already redeemed" + waitShownBadge (chatController alice) Nothing + codeUses cc code `shouldReturn` Just (2, 1) + withNewTestChatCfg ps bsClientCfg "bob" bobProfile $ \bob -> redeemFirstBadge bob code + redeemAsNewPurchase env code >>= (`shouldAnswerError` BSECodeUsed) + +testMultiUseWithoutGroup :: HasCallStack => TestParams -> IO () +testMultiUseWithoutGroup ps = + withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsController = cc} -> do + code <- issueMultiUseCode cc BTLegend 2 2 + forM_ [1 :: Int, 2] $ \claimed -> do + keys@(_, masterKey) <- newPurchaseKeys + redeemed <- redeemWithKeys env keys code + let (entries, _) = statementOf redeemed + map (\e -> let (c, m, _) = entryOf e in (c, m)) entries `shouldBe` [(2, 2), (-1, 1)] + badgeTypeOf redeemed `shouldBe` Just BTLegend + expiryOf redeemed `shouldBe` Just (endOfMondayAfter (nextDue entries)) + masterKeyOf redeemed `shouldBe` Just masterKey + codeUses cc code `shouldReturn` Just (2, claimed) + redeemAsNewPurchase env code >>= (`shouldAnswerError` BSECodeUsed) + +testUnreadableCredentialIsInternal :: HasCallStack => TestParams -> IO () +testUnreadableCredentialIsInternal ps = + withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsController = cc} -> do + code <- issueMultiUseCode cc BTSupporter 1 2 + let redeem keys = redeemWithKeys env keys code + holder <- newPurchaseKeys + redeem holder >>= (`shouldSatisfy` isJust) . credentialOf + withTransaction (chatStore cc) $ \db -> + DB.execute db "UPDATE sx_badge_service_badge_issuances SET credential = ?" (Only (Binary ("not a credential" :: ByteString))) + redeem holder >>= (`shouldAnswerError` BSEInternal) + codeUses cc code `shouldReturn` Just (2, 1) + newPurchaseKeys >>= redeem >>= (`shouldSatisfy` isJust) . credentialOf + codeUses cc code `shouldReturn` Just (2, 2) + redeem holder >>= (`shouldAnswerError` BSEInternal) + codeUses cc code `shouldReturn` Just (2, 2) + +-- The operator's //issue makes single-use codes only, so multi-use codes are issued directly. +issueMultiUseCode :: HasCallStack => ChatController -> BadgeType -> Int -> Int -> IO BadgeCode +issueMultiUseCode cc badgeType months uses = + issueOneCode cc badgeType months CPSFree uses >>= \case + Right (code, _) -> pure code + Left e -> error $ "issuing a multi-use code failed: " <> e + testLapseWhileAway :: HasCallStack => TestParams -> IO () testLapseWhileAway ps = withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClock, bsController = cc} -> do code <- issueCode cc BTSupporter 6 - (purchaseKey, masterKey) <- newPurchaseKeys - redeemed <- serviceCmd env purchaseKey BSCRedeemBadgeCode {masterKey, code = badgeCodeText code} + keys@(purchaseKey, _) <- newPurchaseKeys + redeemed <- redeemWithKeys env keys code let (entries, _) = statementOf redeemed -- The clock is moved from the anchor because adding months to an already clipped due date would miss the boundary. setClockAt bsClock (addMonths 4 (anchorOf (last entries))) @@ -461,8 +551,8 @@ testLastMonthExpiryRounds :: HasCallStack => TestParams -> IO () testLastMonthExpiryRounds ps = withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClock, bsController = cc} -> do code <- issueCode cc BTSupporter 2 - (purchaseKey, masterKey) <- newPurchaseKeys - redeemed <- serviceCmd env purchaseKey BSCRedeemBadgeCode {masterKey, code = badgeCodeText code} + keys@(purchaseKey, _) <- newPurchaseKeys + redeemed <- redeemWithKeys env keys code let (entries, _) = statementOf redeemed setClockAt bsClock (nextDue entries) renewed <- assertBalance env purchaseKey (last entries) @@ -475,8 +565,8 @@ testRenewalSignsWithStoredMasterKey :: HasCallStack => TestParams -> IO () testRenewalSignsWithStoredMasterKey ps = withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClock, bsController = cc} -> do code <- issueCode cc BTSupporter 2 - (purchaseKey, masterKey) <- newPurchaseKeys - redeemed <- serviceCmd env purchaseKey BSCRedeemBadgeCode {masterKey, code = badgeCodeText code} + keys@(purchaseKey, masterKey) <- newPurchaseKeys + redeemed <- redeemWithKeys env keys code masterKeyOf redeemed `shouldBe` Just masterKey let (entries, _) = statementOf redeemed setClockAt bsClock (nextDue entries) @@ -486,14 +576,30 @@ testRenewalSignsWithStoredMasterKey ps = -- This type omits service_created_at and created_at because the client records when it stored a row, not when the service wrote it, so those columns never match. type ReplicatedRow = (Text, Int, Int, UTCTime, Text, Maybe Text) +replicatedColumns :: String +replicatedColumns = + "entry_uuid, change_months, balance_months, balance_start_ts, balance_badge_type, " + <> "COALESCE(entry_credit_type, entry_debit_type)" + ledgerRows :: ChatController -> String -> IO [ReplicatedRow] ledgerRows ChatController {chatStore} table = withTransaction chatStore $ \db -> DB.query_ db . fromString $ - "SELECT entry_uuid, change_months, balance_months, balance_start_ts, balance_badge_type, " - <> "COALESCE(entry_credit_type, entry_debit_type) FROM " - <> table - <> " ORDER BY entry_id" + "SELECT " <> replicatedColumns <> " FROM " <> table <> " ORDER BY entry_id" + +purchaseLedgerRows :: ChatController -> Text -> IO [ReplicatedRow] +purchaseLedgerRows ChatController {chatStore} entryUuid = + withTransaction chatStore $ \db -> + DB.query + db + ( fromString $ + "SELECT " + <> replicatedColumns + <> " FROM sx_badge_service_badge_ledger " + <> "WHERE badge_purchase_id = (SELECT badge_purchase_id FROM sx_badge_service_badge_ledger WHERE entry_uuid = ?) " + <> "ORDER BY entry_id" + ) + (Only entryUuid) -- the two dates the CLI prints for each row ledgerTimes :: ChatController -> IO [(UTCTime, UTCTime)] @@ -697,6 +803,78 @@ testWorkerRenews ps = alice <## "ok" waitShownIssued (chatController alice) +testRevokedMultiUseHolderRenews :: HasCallStack => TestParams -> IO () +testRevokedMultiUseHolderRenews ps = + withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClock, bsClientCfg, bsController = cc} -> + withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do + code <- issueMultiUseCode cc BTSupporter 3 2 + redeemFirstBadge alice code + redeemed <- ledgerRows (chatController alice) "badge_ledger" + revokeCodeAs cc code `shouldReturn` "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. + alice ##> ("/_redeem_badge_code 1 " <> codeArg code) + alice <## "badge already redeemed" + codeUses cc code `shouldReturn` Just (2, 1) + let (requestAt, presentAt) = renewalMoments redeemed + setClockAt bsClock requestAt + alice ##> "/_app activate" + alice <## "ok" + renewed <- waitLedgerRows (chatController alice) 3 + alice <##. "1: supporter" + map (\(_, ch, m, _, _, t) -> (ch, m, t)) renewed `shouldBe` [(3, 3, Just "code"), (-1, 2, Just "badge"), (-1, 1, Just "badge")] + ledgerRows cc "sx_badge_service_badge_ledger" `shouldReturn` renewed + setClockAt bsClock presentAt + alice ##> "/_app activate" + alice <## "ok" + waitShownIssued (chatController alice) + +testMultiUseHoldersRenewApart :: HasCallStack => TestParams -> IO () +testMultiUseHoldersRenewApart ps = + withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClock, bsClientCfg, bsController = cc} -> + withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do + code <- issueMultiUseCode cc BTSupporter 3 2 + redeemFirstBadge alice code + redeemed <- ledgerRows (chatController alice) "badge_ledger" + let requestAt = fst $ renewalMoments redeemed + setClockAt bsClock requestAt + alice ##> "/_app activate" + alice <## "ok" + renewed <- waitLedgerRows (chatController alice) 3 + alice <##. "1: supporter" + map (\(_, ch, m, _, _, t) -> (ch, m, t)) renewed `shouldBe` [(3, 3, Just "code"), (-1, 2, Just "badge"), (-1, 1, Just "badge")] + bobRows <- withNewTestChatCfg ps bsClientCfg "bob" bobProfile $ \bob -> do + redeemFirstBadge bob code + ledgerRows (chatController bob) "badge_ledger" + map (\(_, ch, m, _, _, t) -> (ch, m, t)) bobRows `shouldBe` [(3, 3, Just "code"), (-1, 2, Just "badge")] + let (bobFirstUuid, _, _, bobRedeemedAt, _, _) = head bobRows + bobRedeemedAt `shouldSatisfy` (>= requestAt) + purchaseLedgerRows cc bobFirstUuid `shouldReturn` bobRows + issued <- issuedExpiries (chatController alice) + length issued `shouldBe` 2 + alice ##> ("/_redeem_badge_code 1 " <> codeArg code) + alice <## "badge already redeemed" + codeUses cc code `shouldReturn` Just (2, 2) + let (aliceFirstUuid, _, _, _, _, _) = head renewed + ledgerRows (chatController alice) "badge_ledger" `shouldReturn` renewed + purchaseLedgerRows cc aliceFirstUuid `shouldReturn` renewed + issuedExpiries (chatController alice) `shouldReturn` issued + alicePurchaseKey <- codeRedemptionKey (chatController alice) + (_, masterKey) <- newPurchaseKeys + repeated <- redeemWithKeys env (alicePurchaseKey, masterKey) code + expiryOf repeated `shouldBe` Just (last issued) + codeUses cc code `shouldReturn` Just (2, 2) + +codeRedemptionKey :: HasCallStack => ChatController -> IO C.PublicKeyEd25519 +codeRedemptionKey ChatController {chatStore} = do + rows :: [Only C.PublicKeyEd25519] <- + withTransaction chatStore $ \db -> + DB.query_ db "SELECT purchase_key FROM badge_code_redemptions" + case rows of + [Only k] -> pure k + _ -> error $ "expected one code redemption, got " <> show (length rows) + testRequestWakeFires :: HasCallStack => TestParams -> IO () testRequestWakeFires ps = withBadgeServiceEnv ps $ \BadgeServiceEnv {bsClock, bsClientCfg, bsController = cc} -> diff --git a/tests/Bots/BadgeService/WebTests.hs b/tests/Bots/BadgeService/WebTests.hs index dd21c820dd..f1f58f5173 100644 --- a/tests/Bots/BadgeService/WebTests.hs +++ b/tests/Bots/BadgeService/WebTests.hs @@ -14,11 +14,11 @@ import BadgeService.Poller import BadgeService.Providers import BadgeService.Providers.BTCPay (btcpayProvider, listPageSize, maxListPages) import BadgeService.Providers.Stripe (stripeProvider) -import BadgeService.Store (CodeRedemption (..), IssuedCode (..), NewCodePurchase (..), RevokeResult (..), createCodePurchase, getBadgeCode, insertBadgeCode, revokeCode) +import BadgeService.Store (KeyPurchase (..), KeyRedemption (..), NewCodePurchase (..), RevokeResult (..), createCodePurchase, getCodePurchaseForKey, insertBadgeCode, revokeCode) import BadgeService.Store.Invoices import BadgeService.Waiters (awaitStatus, newWaiters, publish, waitingCount) import BadgeService.Web.Server -import Bots.BadgeService.BotTests (newPurchaseKeys) +import Bots.BadgeService.BotTests (codeCounts, newPurchaseKeys) import Bots.BadgeService.CatalogTests (WebOffer (..), WebPrice (..), parseCatalogSource) import Bots.BadgeService.FakeBTCPay import Bots.BadgeService.FakeStripe (FakeStripe (..), fakeIntentStatus, setIntentState, stripeEvent, stripeSigHeader, withFakeStripe) @@ -41,9 +41,10 @@ import qualified Data.ByteString.Lazy.Char8 as LB import Data.Char (toLower) import Data.Either (isLeft) import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef) +import Data.Int (Int64) import Data.List (sort, sortOn) import qualified Data.Map.Strict as Map -import Data.Maybe (isJust, isNothing, fromMaybe) +import Data.Maybe (catMaybes, isJust, isNothing, fromMaybe, mapMaybe) import Data.Text (Text) import qualified Data.Text as T import Data.Text.Encoding (encodeUtf8) @@ -57,15 +58,16 @@ import Network.HTTP.Client (Manager, Request (..), RequestBody (..), Response, d import Network.HTTP.Types (Header, HeaderName, hCacheControl, hContentType) import Network.HTTP.Types.Status (statusCode) import qualified Network.Wai.Handler.Warp as Warp -import Simplex.Chat.Badges (BadgeType (..)) +import Simplex.Chat.Badges (BadgeCredential (..), BadgeInfo (..), BadgeMasterKey (..), BadgeType (..)) import Simplex.Chat.Badges.Service (BadgeOffer (..), BadgePrice (..)) import Simplex.Chat.Badges.Types (BadgeCodePaymentStatus (..), BadgeItemStatus (..), BadgeOfferId (..), BadgePriceId (..), OfferDiscount (..)) import Simplex.Chat.PaymentService.Types (CryptoCurrency (..), CurrencyAmount (..), InvoiceId (..), InvoiceStatus (..), PaymentProvider (..), PaymentStatus (..), ServicePaymentDestination (..), ServicePaymentMethod (..)) import Simplex.Messaging.Agent.Store.Common (DBStore (..), withConnection, withTransaction) import qualified Simplex.Messaging.Agent.Store.DB as DB import Simplex.Messaging.Agent.Store.Interface -import Simplex.Messaging.Agent.Store.Shared (MigrationConfig (..), MigrationConfirmation (..)) +import Simplex.Messaging.Agent.Store.Shared (Migration (..), MigrationConfig (..), MigrationConfirmation (..), MigrationsToRun (..), toDownMigration) import qualified Simplex.Messaging.Crypto as C +import Simplex.Messaging.Crypto.BBS (BBSSignature (..)) import Simplex.Messaging.Encoding.String (textDecode, textEncode) import Simplex.Messaging.Util (safeDecodeUtf8, tshow) import System.Directory (createDirectoryIfMissing, createFileLink, doesFileExist, listDirectory) @@ -81,6 +83,7 @@ import UnliftIO.Temporary (withTempDirectory) import BadgeService.Store.Postgres.Migrations (badgeServiceSchemaMigrations) import ChatClient (testDBConnectInfo, testDBConnstr) import Database.PostgreSQL.Simple (Only (..)) +import qualified Simplex.Messaging.Agent.Store.Postgres.Migrations as Migrations import Simplex.Messaging.Agent.Store.Postgres.Util (createDBAndUserIfNotExists, dropDatabaseAndUser) #else import BadgeService.Store.SQLite.Migrations (badgeServiceSchemaMigrations) @@ -88,6 +91,7 @@ import Data.String (fromString) import Database.SQLite.Simple (Only (..)) import qualified Database.SQLite.Simple as SQL import Simplex.Messaging.Agent.Store.DB (TrackQueries (..)) +import qualified Simplex.Messaging.Agent.Store.SQLite.Migrations as Migrations #endif #if defined(dbPostgres) @@ -134,6 +138,10 @@ badgeWebTests = do describe "badge service schema" $ do it "carries the five service-only columns" testServiceColumns it "refuses a duplicate provider_ref" testProviderRefUnique + it "M20260918 adds the multi-use columns" testGroupOpsColumns + it "M20260918 defaults a fresh code to one use with none spent" testGroupOpsRedeemCounts + it "migrates all the way down and up again" testSchemaDownUpCycle + it "rolls back only the group migration and re-applies it, keeping a code redeemed twice spent" testGroupOpsDownUp describe "badge service store" $ do it "writes the invoice, its code and their link atomically" testCreationIsAtomic it "newInvoiceId is 128 CSPRNG bits, base64url, and two calls differ" testNewInvoiceIdRandom @@ -144,7 +152,12 @@ badgeWebTests = do it "expireOverdue spares an invoice funded by dust, or by the verdict alone" testExpireOverdueSparesAZeroAmount it "readCatalogRows drops every disabled row" testReadCatalogRowsDropsDisabled it "a revoked code cannot be redeemed, and a redeemed code cannot be revoked" testRevokeAndRedeemExcludeEachOther + it "a multi-use code can be revoked while it has uses left, and not once they are gone" testRevokeMultiUseCode it "every timestamp round-trips to the second" testTimestampRoundTrip + 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 "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 it "leaves exactly one row per id when the service starts twice" testSeedIsIdempotent @@ -301,6 +314,56 @@ testServiceColumns = withServiceStore $ \st -> do columnsOf st "sx_badge_service_badge_codes" >>= (`shouldSatisfy` \cs -> all (`elem` cs) ["expires_at", "revoked_at"]) +testGroupOpsColumns :: IO () +testGroupOpsColumns = withServiceStore assertGroupOpsColumns + +assertGroupOpsColumns :: HasCallStack => DBStore -> IO () +assertGroupOpsColumns st = do + columnsOf st "sx_badge_service_badge_codes" + >>= (`shouldSatisfy` \cs -> all (`elem` cs) ["redeem_limit", "redeem_count"]) + +runMigrations :: DBStore -> MigrationsToRun -> IO () +#if defined(dbPostgres) +runMigrations st = Migrations.run st Nothing +#else +runMigrations st = Migrations.run st Nothing True +#endif + +testSchemaDownUpCycle :: IO () +testSchemaDownUpCycle = withServiceStore $ \st -> do + let downMigrations = mapMaybe toDownMigration badgeServiceSchemaMigrations + length downMigrations `shouldBe` length badgeServiceSchemaMigrations + runMigrations st $ MTRDown downMigrations + columnsOf st "sx_badge_service_badge_codes" `shouldReturn` [] + runMigrations st $ MTRUp badgeServiceSchemaMigrations + assertGroupOpsColumns st + +testGroupOpsDownUp :: IO () +testGroupOpsDownUp = withServiceStore $ \st -> do + now <- truncateToSecond <$> getCurrentTime + let redeemedHash = digestFixture 44 + unredeemedHash = digestFixture 45 + groupOps = [m | m@Migration {name = "20260918_badge_group_ops"} <- badgeServiceSchemaMigrations] + redeemed <- insertCode st redeemedHash CPSPaid 2 now + void $ insertCode st unredeemedHash CPSPaid 1 now + -- Two purchases of one code would break a down migration that restored the unique index. + replicateM_ 2 $ newPurchaseKeys >>= claimUse st redeemed now >>= (`shouldSatisfy` isJust) + runMigrations st $ MTRDown (mapMaybe toDownMigration groupOps) + columnsOf st "sx_badge_service_badge_codes" >>= (`shouldNotSatisfy` elem "redeem_count") + runMigrations st $ MTRUp groupOps + codeCounts st redeemedHash `shouldReturn` Just (1, 1) + codeCounts st unredeemedHash `shouldReturn` Just (1, 0) + +testGroupOpsRedeemCounts :: IO () +testGroupOpsRedeemCounts = withServiceStore $ \st -> do + let codeHash = digestFixture 43 + withConnection st $ \db -> + DB.execute + db + "INSERT INTO sx_badge_service_badge_codes (code_hash, badge_type, months, code_payment_status, created_at) VALUES (?,?,?,?,?)" + (DB.Binary codeHash, "supporter" :: Text, 1 :: Int, "free" :: Text, someCreated) + codeCounts st codeHash `shouldReturn` Just (1, 0) + testProviderRefUnique :: IO () testProviderRefUnique = withServiceStore $ \st -> do seedBadgePrice st "price1" @@ -463,25 +526,35 @@ expireAllOverdue st now = overdueInvoices st now >>= expireOverdue st now . map testRevokeAndRedeemExcludeEachOther :: IO () testRevokeAndRedeemExcludeEachOther = withServiceStore $ \st -> do now <- truncateToSecond <$> getCurrentTime - (purchaseKey, masterKey) <- newPurchaseKeys - let newCode codeHash = withTransaction st $ \db -> do - insertBadgeCode db codeHash BTSupporter 1 CPSPaid now - maybe (error "the code was not written") (\IssuedCode {badgeCodeId} -> badgeCodeId) <$> getBadgeCode db codeHash - redeem badgeCodeId = withTransaction st $ \db -> createCodePurchase db NewCodePurchase {badgeCodeId, purchaseKey, masterKey, badgeType = BTSupporter} now + keys <- newPurchaseKeys + let newCode codeHash = insertCode st codeHash CPSPaid 1 now + redeem badgeCodeId = claimUse st badgeCodeId now keys revoke codeHash = withTransaction st $ \db -> revokeCode db codeHash now - unredeemed codeHash = - withTransaction st (`getBadgeCode` codeHash) >>= \case - Just IssuedCode {redemption = CodeUnredeemed} -> pure True - _ -> pure False revokedFirst <- newCode "revoked-first" revoke "revoked-first" `shouldReturn` Revoked redeem revokedFirst `shouldReturn` Nothing - unredeemed "revoked-first" `shouldReturn` True + codeCounts st "revoked-first" `shouldReturn` Just (1, 0) redeemedFirst <- newCode "redeemed-first" isJust <$> redeem redeemedFirst `shouldReturn` True revoke "redeemed-first" `shouldReturn` AlreadyRedeemed redeem redeemedFirst `shouldReturn` Nothing +testRevokeMultiUseCode :: IO () +testRevokeMultiUseCode = withServiceStore $ \st -> do + now <- truncateToSecond <$> getCurrentTime + let newCode codeHash = insertCode st codeHash CPSPaid 2 now + -- A purchase key redeems once, so every redemption here brings its own. + redeem badgeCodeId = newPurchaseKeys >>= claimUse st badgeCodeId now + revoke codeHash = withTransaction st $ \db -> revokeCode db codeHash now + partlyUsed <- newCode "partly-used" + isJust <$> redeem partlyUsed `shouldReturn` True + revoke "partly-used" `shouldReturn` Revoked + redeem partlyUsed `shouldReturn` Nothing + usedUp <- newCode "used-up" + isJust <$> redeem usedUp `shouldReturn` True + isJust <$> redeem usedUp `shouldReturn` True + revoke "used-up" `shouldReturn` AlreadyRedeemed + testReadCatalogRowsDropsDisabled :: IO () testReadCatalogRowsDropsDisabled = withServiceStore $ \st -> do insertPrice st "price-active" "supporter" 500 "active" @@ -615,6 +688,74 @@ testTimestampRoundTrip = withServiceStore $ \st -> do irExpiresAt row `shouldBe` truncated irCreatedAt row `shouldBe` truncated +insertCode :: DBStore -> ByteString -> BadgeCodePaymentStatus -> Int -> UTCTime -> IO Int64 +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 st badgeCodeId now (purchaseKey, masterKey) = + withTransaction st $ \db -> + createCodePurchase db NewCodePurchase {badgeCodeId, purchaseKey, masterKey, badgeType = BTSupporter} now + +-- The signature is dummy bytes, since only the JSON round-trip is under test; 80 is the length its decoder accepts. +seededCredential :: BadgeMasterKey -> UTCTime -> BadgeCredential +seededCredential masterKey expiry = + BadgeCredential {badgeKeyIdx = 1, masterKey, signature = BBSSignature (BS.replicate 80 7), badgeInfo = BadgeInfo {badgeType = BTSupporter, badgeExpiry = expiry, badgeExtra = ""}} + +seedIssuance :: DBStore -> Int64 -> Text -> BadgeMasterKey -> UTCTime -> UTCTime -> IO () +seedIssuance st purchaseId issuanceId masterKey at periodEnd = + withConnection st $ \db -> + DB.execute + db + "INSERT INTO sx_badge_service_badge_issuances (issuance_id, badge_purchase_id, badge_type, period_start, period_end, expiry, credential, created_at) VALUES (?,?,?,?,?,?,?,?)" + (issuanceId, purchaseId, "supporter" :: Text, at, periodEnd, periodEnd, DB.Binary (LB.toStrict (J.encode (seededCredential masterKey periodEnd))), at) + +testKeyPurchaseLookup :: IO () +testKeyPurchaseLookup = withServiceStore $ \st -> do + now <- getCurrentTime + let codeHash = digestFixture 41 + badgeCodeId <- insertCode st codeHash CPSFree 2 now + keys@(k1, mk1) <- newPurchaseKeys + 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" + let firstPeriodEnd = someExpiry + renewedPeriodEnd = addUTCTime 86400 someExpiry + seedIssuance st purchaseId "iss-first" mk1 now firstPeriodEnd + seedIssuance st purchaseId "iss-renewed" mk1 now renewedPeriodEnd + (unusedKey, _) <- newPurchaseKeys + withTransaction st (\db -> getCodePurchaseForKey db badgeCodeId unusedKey) >>= \case + KeyUnredeemed -> pure () + _ -> expectationFailure "expected no purchase for a key that never redeemed" + replayed <- withTransaction st (\db -> getCodePurchaseForKey db badgeCodeId k1) + case replayed of + KeyRedeemed KeyPurchase {badgePurchaseId, credential} -> do + badgePurchaseId `shouldBe` purchaseId + credential `shouldBe` seededCredential mk1 renewedPeriodEnd + _ -> expectationFailure "expected the redeemed key's purchase" + +testSameKeyClaimsOnce :: IO () +testSameKeyClaimsOnce = withServiceStore $ \st -> do + now <- getCurrentTime + let codeHash = digestFixture 46 + badgeCodeId <- insertCode st codeHash CPSFree 3 now + keys <- newPurchaseKeys + claimUse st badgeCodeId now keys >>= (`shouldSatisfy` isJust) + -- The key is unique across purchases, so the second insert fails and its transaction returns the use. + claimUse st badgeCodeId now keys `shouldThrow` anyException + codeCounts st codeHash `shouldReturn` Just (3, 1) + +testMultiUseConcurrentClaimsUpToLimit :: IO () +testMultiUseConcurrentClaimsUpToLimit = withServiceStore $ \st -> do + now <- getCurrentTime + let codeHash = digestFixture 42 + 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] + codeCounts st codeHash `shouldReturn` Just (3, 3) + data StubCall = StubCreate ServicePaymentMethod OrderDraft | StubRead Text