diff --git a/src/Simplex/Chat/Library/Commands.hs b/src/Simplex/Chat/Library/Commands.hs index 725869f885..8f835143c4 100644 --- a/src/Simplex/Chat/Library/Commands.hs +++ b/src/Simplex/Chat/Library/Commands.hs @@ -63,7 +63,7 @@ import Simplex.Chat.Badges (BadgeCredential (..), BadgeInfo (..), BadgeMasterKey import qualified Simplex.Chat.Badges.Ledger as L import Simplex.Chat.Badges.Types (BadgeAlert (..), BadgeAlertKind (..), BadgeIssueError (..), BadgeIssueFailure (..), BadgeState (..), OpenStorePurchase (..)) import Simplex.Chat.Badges.Code (badgeCodeText, parseBadgeCode) -import Simplex.Chat.Badges.Service (BadgeBalance (..), BadgeServiceCommand (..), BadgeServiceErrorCode (..), BadgeServiceRequest (..), BadgeServiceResponse (..), BadgeStatement (..), StatementDebitType (..), StatementEntry (..), StatementEntryType (..), currentBadgeServiceVersion) +import Simplex.Chat.Badges.Service (BadgeBalance (..), BadgeServiceCommand (..), BadgeServiceErrorCode (..), BadgeServiceRequest (..), BadgeServiceResponse (..), BadgeStatement (..), StatementDebitType (..), StatementEntry (..), StatementEntryType (..), SubscriptionState (..), currentBadgeServiceVersion) import Simplex.Chat.Names (SimplexDomainProof (..), SimplexDomainClaim (..), claimDomain, mkDomainClaim) import Simplex.Chat.Call import Simplex.Chat.Controller @@ -5549,18 +5549,26 @@ updateUserBadge userId emitted now = do user <- withStore $ \db -> getUser db userId withStore' (`getUserBadgePurchase` user) >>= \case Nothing -> pure Nothing - Just p@UserBadgePurchase {badgePurchaseId} -> + Just p@UserBadgePurchase {badgePurchaseId, purchaseKind} -> withStore' (`getBadgeLedgerLastEntry` badgePurchaseId) >>= \case Nothing -> pure Nothing Just balance -> do - -- retirement needs no service and an unbounded retry would not return before it - retired <- retireExpiredBadge user p now balance + -- No months come after a prepaid purchase's paidThrough, so it is retired before asking, as + -- retirement needs no service and an unbounded retry would not return before it. A + -- subscription's come from the store, so it is retired only once the service says it ended. + retiredBefore <- case purchaseKind of + PKPrepaid -> retireExpiredBadge user p now balance + PKSubscription -> pure False latest <- withStore' (`getLatestIssuedCredential` badgePurchaseId) - let requestDue = not retired && badgeRequestDue now (shownBadgeCredential user p) latest balance - (balance', serviceAt) <- + let requestDue = not retiredBefore && badgeRequestDue now purchaseKind (shownBadgeCredential user p) latest balance + (balance', subscription_, serviceAt) <- if requestDue - then either ((balance,) . Just) (,Nothing) <$> requestBadgeIssue userId p now - else pure (balance, Nothing) + then either (\at -> (balance, Nothing, Just at)) (\(b, s) -> (b, s, Nothing)) <$> requestBadgeIssue userId p now + else pure (balance, Nothing, Nothing) + retired <- + if subscription_ == Just SSEnded + then retireExpiredBadge user p now balance' + else pure retiredBefore -- presenting broadcasts the record it is handed, and the request above can block for the -- whole service timeout, so this read belongs after it and not at the top of the pass user' <- withStore $ \db -> getUser db userId @@ -5589,8 +5597,9 @@ updateUserBadge userId emitted now = do -- while topping up cannot credit months without issuing. -- TODO [badges] BAPrepaidEnding belongs here, three days before paidThrough, once that exists. derivedBadgeAlert :: UTCTime -> UserBadgePurchase -> Maybe BadgeCredential -> StatementEntry -> Maybe BadgeAlert -derivedBadgeAlert now p shownCred b - | endsAt <= now = Just $ alertOf BASupportEnded endsAt +derivedBadgeAlert now p@UserBadgePurchase {purchaseKind, shown} shownCred b + -- a subscription still shown past paidThrough is waiting for its store to charge, not ended + | endsAt <= now && not (purchaseKind == PKSubscription && shown) = Just $ alertOf BASupportEnded endsAt | otherwise = (\BadgeIssueError {failedSince} -> alertOf BAIssueFailed failedSince) <$> shownIssueError now p shownCred where endsAt = L.paidThrough b @@ -5685,9 +5694,10 @@ credentialExpiry (BadgeCredential _ _ _ BadgeInfo {badgeExpiry}) = badgeExpiry -- | Timed off the shown credential, not the period end: renewing around its shared expiry is what -- joins the anonymity set. Latest still equal to shown means this month has not been asked for. -badgeRequestDue :: UTCTime -> Maybe BadgeCredential -> Maybe BadgeCredential -> StatementEntry -> Bool -badgeRequestDue now shownCred latestCred balance = - balanceMonths balance > 0 && latestCred == shownCred && maybe False lapsingSoon shownCred +-- A subscription is asked about at zero months too: its next month comes from a store charge. +badgeRequestDue :: UTCTime -> PurchaseKind -> Maybe BadgeCredential -> Maybe BadgeCredential -> StatementEntry -> Bool +badgeRequestDue now purchaseKind shownCred latestCred balance = + (balanceMonths balance > 0 || purchaseKind == PKSubscription) && latestCred == shownCred && maybe False lapsingSoon shownCred where lapsingSoon cred = credentialExpiry cred <= badgeRequestLead `addUTCTime` now @@ -5747,7 +5757,7 @@ badgeErrorRetry = badgeFailureTransient . badgeIssueFailure -- carries when to try again, since a service error is answered rather than thrown. Any request that -- ends without a credential the ledger still owes is recorded on the purchase as a failed renewal; -- nothing else records one. -requestBadgeIssue :: UserId -> UserBadgePurchase -> UTCTime -> CM (Either UTCTime StatementEntry) +requestBadgeIssue :: UserId -> UserBadgePurchase -> UTCTime -> CM (Either UTCTime (StatementEntry, Maybe SubscriptionState)) requestBadgeIssue userId UserBadgePurchase {badgePurchaseId, badgeType, purchaseKey, purchasePrivKey, masterKey} now = do sendTarget <- asks (badgeServiceAddress . config) >>= maybe (throwCmdError "badge service not configured") pure withEntityLock "badgeIssue" (CLBadgeUser userId) $ do @@ -5763,7 +5773,7 @@ requestBadgeIssue userId UserBadgePurchase {badgePurchaseId, badgeType, purchase sendServiceRequestTo NRMBackground user sendTarget Nothing (Just purchasePrivKey) req `catchAllErrors` \e -> recordFailure (badgeIssueFailure e) >> throwError e case J.fromJSON (J.Object respData) of - J.Success BSPBadgeCredential {credential = sentCred_, statement} -> do + J.Success BSPBadgeCredential {credential = sentCred_, statement, subscription} -> do verifiedCred_ <- verifyIssuedCredential masterKey sentCred_ g <- asks random -- read again: now was taken before a lock wait and an untimed request, and the check reads @@ -5776,10 +5786,11 @@ requestBadgeIssue userId UserBadgePurchase {badgePurchaseId, badgeType, purchase case (sentCred_, verifiedCred_, applied) of (Just _, Nothing, _) -> recordFailure BIFInvalidCredential (_, _, False) -> recordUnexpected "issued badge credential has no ledger row to store it against" - -- no credential is the service saying the months ran out, which its statement then shows - (Nothing, _, _) | maybe False ((> 0) . balanceMonths) balance_ -> recordUnexpected "badge service issued no credential" + -- no credential is the service saying nothing is owed - the months ran out, or a subscription + -- waits for its store to charge - which its statement then shows + (Nothing, _, _) | maybe False ((> storedAt) . L.paidThrough) balance_ -> recordUnexpected "badge service issued no credential" _ -> pure () - maybe (throwCmdError "badge ledger has no balance") (pure . Right) balance_ + maybe (throwCmdError "badge ledger has no balance") (pure . Right . (,subscription)) balance_ J.Success BSPError {code, retryAfter} -> do eToView $ ChatError $ CECommandError $ "badge service error: " <> T.unpack (badgeServiceErrorText code) recordFailure BIFServiceError {code = boundedServiceErrorCode code, retryable = isJust retryAfter} diff --git a/src/Simplex/Chat/Store/Badges.hs b/src/Simplex/Chat/Store/Badges.hs index 9fe2fce145..27fecce6c9 100644 --- a/src/Simplex/Chat/Store/Badges.hs +++ b/src/Simplex/Chat/Store/Badges.hs @@ -10,6 +10,7 @@ module Simplex.Chat.Store.Badges ( BadgeStash (..), BadgeStashRef (..), UserBadgePurchase (..), + PurchaseKind (..), getUserBadgePurchase, getBadgePurchase, userHasBadge, @@ -390,9 +391,15 @@ data UserBadgePurchase = UserBadgePurchase alertAcked :: Maybe (BadgeAlertKind, Text), alertSnoozeUntil :: Maybe UTCTime, issueError :: Maybe BadgeIssueError, - nextWakeAt :: Maybe UTCTime + nextWakeAt :: Maybe UTCTime, + purchaseKind :: PurchaseKind } +-- | A subscription's months come from store charges, so reaching paidThrough does not end it: the +-- service says when it has. Derived from the replica, which holds a charge credit exactly for a subscription. +data PurchaseKind = PKPrepaid | PKSubscription + deriving (Eq) + -- | Newest, not the one shown_badge_id points at - retirement clears that, and the support ended -- alert is recomputed from this purchase after the badge stops being shown. getUserBadgePurchase :: DB.Connection -> User -> IO (Maybe UserBadgePurchase) @@ -420,14 +427,18 @@ getBadgePurchase db purchaseId = SELECT p.badge_purchase_id, p.purchase_key, p.purchase_priv_key, p.master_key, p.current_badge_type, (CASE WHEN u.shown_badge_id = p.badge_purchase_id THEN 1 ELSE 0 END), p.alert_acked_kind, p.alert_acked_episode, p.alert_snooze_until, - p.issue_failed_since, p.issue_error_at, p.issue_error, p.next_wake_at + p.issue_failed_since, p.issue_error_at, p.issue_error, p.next_wake_at, + (CASE WHEN EXISTS ( + SELECT 1 FROM badge_ledger l + WHERE l.badge_purchase_id = p.badge_purchase_id AND l.entry_type = 'credit' AND l.entry_credit_type = 'charge' + ) THEN 1 ELSE 0 END) FROM badge_purchases p JOIN users u ON u.user_id = p.user_id WHERE p.badge_purchase_id = ? AND p.purchase_priv_key IS NOT NULL |] (Only purchaseId) where - toPurchase ((badgePurchaseId, purchaseKey, purchasePrivKey, Binary mk, badgeType, shown_, ackedKind_, ackedEpisode_, alertSnoozeUntil) :. (failedSince_, lastAttemptAt_, reason_, nextWakeAt)) = + toPurchase ((badgePurchaseId, purchaseKey, purchasePrivKey, Binary mk, badgeType, shown_, ackedKind_, ackedEpisode_, alertSnoozeUntil) :. (failedSince_, lastAttemptAt_, reason_, nextWakeAt, BI charged)) = UserBadgePurchase { badgePurchaseId, purchaseKey, @@ -438,7 +449,8 @@ getBadgePurchase db purchaseId = alertAcked = (,) <$> ackedKind_ <*> ackedEpisode_, alertSnoozeUntil, issueError = BadgeIssueError <$> failedSince_ <*> lastAttemptAt_ <*> reason_, - nextWakeAt + nextWakeAt, + purchaseKind = if charged then PKSubscription else PKPrepaid } -- | Whether a badge is on the profile now: set when a redemption stores one, cleared when it is diff --git a/tests/Bots/BadgeService/BotTests.hs b/tests/Bots/BadgeService/BotTests.hs index e07c199ffb..afb1cdb120 100644 --- a/tests/Bots/BadgeService/BotTests.hs +++ b/tests/Bots/BadgeService/BotTests.hs @@ -182,6 +182,10 @@ badgeServiceTests = do it "should ask the store only once coverage has ended, and at most once an hour, failed checks included" testSubscriptionStoreChecksBounded it "should record and not grant a revoked, other-tier, offer, unstarted or ended charge" testSubscriptionChargeNotGranted it "should answer an unreachable store with the check interval, writing no charge or ledger row" testSubscriptionStoreUnreachable + it "should keep asking at zero months, and present the renewed credential when the old one expires" testSubscriptionRenews + it "should keep the badge and ask again a day later while the store has not charged, then issue from the period start" testSubscriptionAwaitsCharge + it "should retire the badge and alert once the service says the subscription ended, and stop asking" testSubscriptionEnds + it "should resolve an Apple renewal to the subscription's record, and credit a held record that adopted it" testAppleRenewalResolvesToPurchase badgeBotName :: Text badgeBotName = "SimpleX Badges" @@ -2155,6 +2159,146 @@ testSubscriptionStoreUnreachable ps = ledgerRows cc "sx_badge_service_badge_ledger" `shouldReturn` ledger rowCount cc "sx_badge_service_subscription_charges" `shouldReturn` 1 +-- | The client buys a monthly Play subscription an hour into its first period: that period's start, and its ledger then. +clientSubscribedMonthly :: HasCallStack => BadgeServiceEnv -> TestCC -> IO (UTCTime, [ReplicatedRow]) +clientSubscribedMonthly env@BadgeServiceEnv {bsStore} alice = do + firstStart <- addUTCTime (-3600) <$> serviceNow env + storeReports bsStore $ subscriptionCheck SSRenewing $ Just $ storeCharge "subscr-badge-supporter-month-02" firstStart 1 + alice ##> ("/_badge purchase 1 " <> paymentArg subscriptionPlay) + inAnyOrder alice [[openPurchase ""], ["1: supporter"]] + waitWakeArmed (chatController alice) + rows <- ledgerRows (chatController alice) "badge_ledger" + map (\(_, ch, m, _, _, t) -> (ch, m, t)) rows `shouldBe` [(1, 1, Just "charge"), (-1, 0, Just "badge")] + pure (firstStart, rows) + +-- | Waits for the worker to arm a wake no earlier than t, which is how a pass that issued nothing shows it has ended. +waitWakeFrom :: HasCallStack => ChatController -> UTCTime -> IO () +waitWakeFrom ChatController {chatStore} t = loop (100 :: Int) + where + loop i = do + rows :: [(Maybe UTCTime, Int64)] <- + withTransaction chatStore $ \db -> + DB.query_ db "SELECT next_wake_at, badge_purchase_id FROM badge_purchases" + case rows of + [(Just w, _)] | w >= t -> pure () + _ + | i == 0 -> error $ "expected a wake from " <> show t <> ", got " <> show rows + | otherwise -> threadDelay 50000 >> loop (i - 1) + +rowChanges :: [ReplicatedRow] -> [(Int, Int, UTCTime, Maybe Text)] +rowChanges = map (\(_, ch, m, start, _, t) -> (ch, m, start, t)) + +testSubscriptionRenews :: HasCallStack => TestParams -> IO () +testSubscriptionRenews ps = + withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClock, bsClientCfg, bsStore = store} -> + withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do + (firstStart, rows) <- clientSubscribedMonthly env alice + let (requestAt, presentAt) = renewalMoments rows + renewalStart = addMonths 1 firstStart + storeReports store $ subscriptionCheck SSRenewing $ Just $ monthlyCharge "subscr-badge-supporter-month-02" firstStart 1 + -- asked at zero months, past paidThrough, with the badge still shown + requestAt `shouldSatisfy` (> renewalStart) + setClockAt bsClock requestAt + alice ##> "/_app activate" + alice <## "ok" + renewed <- waitLedgerRows (chatController alice) 4 + alice <##. "1: supporter" + drop 2 (rowChanges renewed) `shouldBe` [(1, 1, renewalStart, Just "charge"), (-1, 0, addMonths 1 renewalStart, Just "badge")] + balanceChecks (chatController alice) `shouldReturn` replicate 4 (Just True) + issueErrorRow (chatController alice) `shouldReturn` (Nothing, Nothing) + shownBadgeId (chatController alice) >>= (`shouldSatisfy` isJust) + -- and the new credential replaces the old one at its expiry + shownAndIssuedExpiry (chatController alice) >>= \(shown, issued) -> shown `shouldNotBe` issued + setClockAt bsClock presentAt + alice ##> "/_app activate" + alice <## "ok" + waitShownIssued (chatController alice) + +testSubscriptionAwaitsCharge :: HasCallStack => TestParams -> IO () +testSubscriptionAwaitsCharge ps = + withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClock, bsClientCfg, bsController = cc, bsStore = store} -> + withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do + (_, rows) <- clientSubscribedMonthly env alice + let (requestAt, presentAt) = renewalMoments rows + recoveredAt = addUTCTime (nominalDay / 2) requestAt + storeReports store $ subscriptionCheck SSBillingRetry Nothing + checks <- subscriptionChecks store + setClockAt bsClock requestAt + alice ##> "/_app activate" + alice <## "ok" + -- nothing issued and no failure: the badge stays, and the next request is a day on + waitWakeFrom (chatController alice) (addUTCTime (nominalDay - 60) requestAt) + subscriptionChecks store `shouldReturn` checks + 1 + issueErrorRow (chatController alice) `shouldReturn` (Nothing, Nothing) + ledgerRows (chatController alice) "badge_ledger" `shouldReturn` rows + ledgerRows cc "sx_badge_service_badge_ledger" `shouldReturn` rows + shownBadgeId (chatController alice) >>= (`shouldSatisfy` isJust) + -- the charge lands, its period starting when the store recovered it + storeReports store $ subscriptionCheck SSRenewing $ Just (storeCharge "subscr-badge-supporter-month-02" recoveredAt 1) {chargeRef = "GPA.recovered"} + setClockAt bsClock presentAt + alice ##> "/_app activate" + alice <## "ok" + renewed <- waitLedgerRows (chatController alice) 4 + alice <##. "1: supporter" + drop 2 (rowChanges renewed) `shouldBe` [(1, 1, recoveredAt, Just "charge"), (-1, 0, addMonths 1 recoveredAt, Just "badge")] + issueErrorRow (chatController alice) `shouldReturn` (Nothing, Nothing) + waitShownIssued (chatController alice) + +testSubscriptionEnds :: HasCallStack => TestParams -> IO () +testSubscriptionEnds ps = + withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClock, bsClientCfg, bsStore = store} -> + withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do + (_, rows) <- clientSubscribedMonthly env alice + let (requestAt, _) = renewalMoments rows + storeReports store $ subscriptionCheck SSEnded Nothing + setClockAt bsClock requestAt + alice `send` "/_app activate" + alice + <### [ "/_app activate", + "ok", + StartsWith "badge alert: support_ended ", + StartsWith "1: supporter", + StartsWith "badge alert: support_ended " + ] + waitShownBadge (chatController alice) Nothing + -- a retired purchase is not asked about again + checks <- subscriptionChecks store + setClockAt bsClock $ addUTCTime (2 * nominalDay) requestAt + alice ##> "/_app activate" + alice <## "ok" + threadDelay 2000000 + subscriptionChecks store `shouldReturn` checks + +setStoreReceiptDue :: ChatController -> UTCTime -> IO () +setStoreReceiptDue ChatController {chatStore} t = + withTransaction chatStore $ \db -> DB.execute db "UPDATE badge_store_receipts SET next_attempt_at = ?" (Only t) + +testAppleRenewalResolvesToPurchase :: HasCallStack => TestParams -> IO () +testAppleRenewalResolvesToPurchase ps = + withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClientCfg, bsController = cc, bsStore = store@FakeStore {appleSubscriptionJWS, appleRenewalSubscriptionJWS}} -> + withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do + now <- serviceNow env + let appleReports start = setSubscription store (SubscriptionApple appleSubscriptionOriginalId) $ subscriptionCheck SSRenewing $ Just $ storeCharge "SUBSCR_BADGE_SUPPORTER_MONTH_01" start 1 + handOver jws = alice ##> ("/_badge purchase 1 " <> paymentArg SPApple {jws}) + -- the first attempt finds a period that has not started, and the record waits + appleReports $ addUTCTime 3600 now + handOver appleSubscriptionJWS + storePurchaseOpen alice "" + heldStoreReceiptErrors (chatController alice) `shouldEventuallyReturn` ["service_error retry payment_pending"] + -- a renewal with another transaction id joins that record, and is credited at its next attempt + appleReports $ addUTCTime (-3600) now + setStoreReceiptDue (chatController alice) now + handOver appleRenewalSubscriptionJWS + inAnyOrder alice [[openPurchase ""], ["1: supporter"]] + storeReceiptRows (chatController alice) `shouldReturn` [(1, Nothing, True)] + rowCount cc "sx_badge_service_badge_purchases" `shouldReturn` 1 + -- the first transaction handed over again resolves to the credited record, and creates nothing + handOver appleSubscriptionJWS + alice <## "badge already redeemed" + storeReceiptRows (chatController alice) `shouldReturn` [(1, Nothing, True)] + rowCount cc "sx_badge_service_badge_purchases" `shouldReturn` 1 + map (\(_, ch, m, _, _, t) -> (ch, m, t)) <$> ledgerRows (chatController alice) "badge_ledger" `shouldReturn` [(1, 1, Just "charge"), (-1, 0, Just "badge")] + testPurchaseBadge :: HasCallStack => TestParams -> IO () testPurchaseBadge ps = withBadgeServiceEnv ps $ \BadgeServiceEnv {bsClientCfg, bsController = cc} -> diff --git a/tests/Bots/BadgeService/FakeStore.hs b/tests/Bots/BadgeService/FakeStore.hs index 98a7b5b2aa..d553029131 100644 --- a/tests/Bots/BadgeService/FakeStore.hs +++ b/tests/Bots/BadgeService/FakeStore.hs @@ -53,8 +53,9 @@ data FakeStore = FakeStore appleThrowingJWS :: Text, appleMisnamedJWS :: Text, appleQuantityJWS :: Text, - -- a renewal of the subscription appleSubscriptionOriginalId names, and the same from Apple's Sandbox + -- two transactions of the subscription appleSubscriptionOriginalId names, and one from Apple's Sandbox appleSubscriptionJWS :: Text, + appleRenewalSubscriptionJWS :: Text, appleSandboxSubscriptionJWS :: Text, pendingSettled :: IORef Bool, googleDown :: IORef Bool, @@ -73,6 +74,7 @@ newFakeStore = do appleMisnamedJWS = unsignedJWS "{\"transactionId\":\"2000000812345698\",\"productId\":\"BADGE_SUPPORTER_01\"}" appleQuantityJWS = unsignedJWS "{\"transactionId\":\"2000000812345697\",\"productId\":\"BADGE_SUPPORTER_01\"}" appleSubscriptionJWS = subscriptionJWS "2000000812345681" + appleRenewalSubscriptionJWS = subscriptionJWS "2000000812345683" appleSandboxSubscriptionJWS = subscriptionJWS "2000000812345682" pendingSettled <- newIORef False googleDown <- newIORef False @@ -87,6 +89,7 @@ newFakeStore = do (appleQuantityJWS, (appleTransaction "2000000812345697" "BADGE_SUPPORTER_01" False 1400) {quantity = 2}), -- vouched by the ref the claim reads, the subscription's original id (appleSubscriptionJWS, appleSubscription appleSubscriptionJWS False), + (appleRenewalSubscriptionJWS, appleSubscription appleRenewalSubscriptionJWS False), (appleSandboxSubscriptionJWS, appleSubscription appleSandboxSubscriptionJWS True) ] verifyApple jws @@ -108,6 +111,7 @@ newFakeStore = do appleMisnamedJWS, appleQuantityJWS, appleSubscriptionJWS, + appleRenewalSubscriptionJWS, appleSandboxSubscriptionJWS, pendingSettled, googleDown,