core: keep a subscription badge until the service says it ended

A purchase is a subscription exactly when its ledger replica holds a
charge credit, so the kind is derived with no column or migration. A
subscription is still asked about at zero months, at the shared weekly
moment, and keeps its badge past paidThrough until an answer says the
subscription ended, so a renewed month is presented at the old
credential's expiry with no gap, and a charge the store recovers later
still re-activates it. While it waits, the client records no failure and
raises no support-ended alert; "issued no credential" now fires only while
the ledger still owes a month. Prepaid purchases are unchanged.

Run: 001-badge-subscriptions, slice 5

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}

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