core: keep a store subscription's state on the client

The screens and alerts need to know whether a subscription renews, was
cancelled, waits for a charge, or ended, and the client dropped every state
the service sent but ended. It is now stored on the purchase: from the
answer to the first credit, and from a renewal answer only when the
asserted tip's coverage had ended, since while coverage runs the service
repeats what it read at the last renewal (a year old for an annual plan).

BadgeState gains `subscription` (the plan's months, from the latest charge
credit, and the state), and fills renewsAt/willRenew from it. A changed
state is announced with CEvtBadgeChanged. The column goes into the
unreleased M20260925 migration.

Run: 003-badge-subscriptions-ui, slice 2

src/Simplex/Chat/Badges/Types.hs

@@ -30,6 +30,7 @@ module Simplex.Chat.Badges.Types
     BadgeIssuance (..),
     BadgeAlert (..),
     BadgeAlertPrice (..),
+    BadgeSubscription (..),
     BadgeState (..),
     OpenStorePurchase (..),
   ) where
@@ -290,10 +291,18 @@ data BadgeState = BadgeState
     willRenew :: Bool,
     alert :: Maybe BadgeAlert,
     issueError :: Maybe BadgeIssueError,
-    nextWakeAt :: Maybe UTCTime
+    nextWakeAt :: Maybe UTCTime,
+    subscription :: Maybe BadgeSubscription
   }
   deriving (Show)
 
+-- | A store subscription funding the purchase: the latest charge's plan, and the store's state as last observed.
+data BadgeSubscription = BadgeSubscription
+  { planMonths :: Int,
+    status :: Maybe SubscriptionState
+  }
+  deriving (Eq, Show)
+
 -- | One of a profile's store purchases that no receipt has reached yet, or whose receipt is held until
 -- the service credits it; transactionRef is set once a receipt arrived. Neither reference is a secret:
 -- Apple's is the transaction id, or a subscription's original one; Google's is a hash of the token.
@@ -409,6 +418,10 @@ instance ToJSON SubscriptionState where
 instance FromJSON SubscriptionState where
   parseJSON = textParseJSON "SubscriptionState"
 
+instance FromField SubscriptionState where fromField = fromTextField_ textDecode
+
+instance ToField SubscriptionState where toField = toField . textEncode
+
 instance StrEncoding BadgeIssueFailure where
   strEncode = \case
     BIFServiceError {code, retryable} -> "service_error " <> (if retryable then "retry " else "final ") <> encodeUtf8 (textEncode code)
@@ -458,6 +471,8 @@ $(JQ.deriveJSON (sumTypeJSON $ dropPrefix "BIF") ''BadgeIssueFailure)
 
 $(JQ.deriveJSON defaultJSON ''BadgeIssueError)
 
+$(JQ.deriveJSON defaultJSON ''BadgeSubscription)
+
 $(JQ.deriveJSON defaultJSON ''BadgeState)
 
 $(JQ.deriveJSON defaultJSON ''OpenStorePurchase)

src/Simplex/Chat/Library/Commands.hs

@@ -61,7 +61,7 @@ import Crypto.Random (ChaChaDRG)
 import Simplex.Messaging.Session (SessionVar (..), withGetSessVar')
 import Simplex.Chat.Badges (BadgeCredential (..), BadgeInfo (..), BadgeMasterKey, BadgeType, LocalBadge (..), badgeServerCredential, mkBadgeStatus, maxSndXFTPFileSize, verifyCredential)
 import qualified Simplex.Chat.Badges.Ledger as L
-import Simplex.Chat.Badges.Types (BadgeAlert (..), BadgeAlertKind (..), BadgeIssueError (..), BadgeIssueFailure (..), BadgeState (..), OpenStorePurchase (..))
+import Simplex.Chat.Badges.Types (BadgeAlert (..), BadgeAlertKind (..), BadgeIssueError (..), BadgeIssueFailure (..), BadgeState (..), BadgeSubscription (..), OpenStorePurchase (..))
 import Simplex.Chat.Badges.Code (badgeCodeText, parseBadgeCode)
 import Simplex.Chat.Badges.Service (BadgeBalance (..), BadgeServiceCommand (..), BadgeServiceErrorCode (..), BadgeServiceRequest (..), BadgeServiceResponse (..), BadgeStatement (..), StatementDebitType (..), StatementEntry (..), StatementEntryType (..), SubscriptionState (..), currentBadgeServiceVersion)
 import Simplex.Chat.Names (SimplexDomainProof (..), SimplexDomainClaim (..), claimDomain, mkDomainClaim)
@@ -5343,7 +5343,7 @@ requestBadgeStash nm user sendTarget stash@BadgeStash {purchaseKey, purchasePriv
   case J.fromJSON (J.Object respData) of
     J.Error _ -> throwRedeemError $ BREInvalidResponse "not a badge service response"
     J.Success BSPError {code, retryAfter} -> pure $ Left (code, retryAfter)
-    J.Success BSPBadgeCredential {credential = Just cred, statement} -> Right <$> storeRedeemedBadge user stash cred statement
+    J.Success BSPBadgeCredential {credential = Just cred, statement, subscription} -> Right <$> storeRedeemedBadge user stash cred statement (boundedSubscriptionState <$> subscription)
     J.Success _ -> throwRedeemError $ BREInvalidResponse "unexpected response type"
 
 throwRedeemError :: BadgeRedeemError -> CM a
@@ -5357,13 +5357,24 @@ badgeServiceErrorText = textEncode . boundedServiceErrorCode
 -- on controls, or a sentence the app shows the user as its own.
 boundedServiceErrorCode :: BadgeServiceErrorCode -> BadgeServiceErrorCode
 boundedServiceErrorCode = \case
-  BSEUnknown t -> BSEUnknown $ case T.filter errorCodeChar (T.take 32 t) of
-    "" -> "unknown"
-    t' -> t'
+  BSEUnknown t -> BSEUnknown $ boundedServiceText errorCodeChar t
   code -> code
   where
     errorCodeChar c = isAsciiLower c || isDigit c || c == '_'
 
+-- | A state this version does not know is stored and shown as the service named it, so it is bounded likewise.
+boundedSubscriptionState :: SubscriptionState -> SubscriptionState
+boundedSubscriptionState = \case
+  SSUnknown t -> SSUnknown $ boundedServiceText stateChar t
+  state -> state
+  where
+    stateChar c = isAsciiLower c || isAsciiUpper c || isDigit c
+
+boundedServiceText :: (Char -> Bool) -> Text -> Text
+boundedServiceText allowed t = case T.filter allowed (T.take 32 t) of
+  "" -> "unknown"
+  t' -> t'
+
 -- | The only clock badge code reads, so a test can move the client and the service together.
 badgeNow :: CM UTCTime
 badgeNow = asks (badgeCurrentTime . config) >>= liftIO
@@ -5558,7 +5569,7 @@ updateUserBadge userId emitted now = do
           -- 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
+            PKSubscription _ -> pure False
           latest <- withStore' (`getLatestIssuedCredential` badgePurchaseId)
           let requestDue = not retiredBefore && badgeRequestDue now purchaseKind (shownBadgeCredential user p) latest balance
           (balance', subscription_, serviceAt) <-
@@ -5583,14 +5594,15 @@ updateUserBadge userId emitted now = do
           -- a snooze is the one wake that is not in the ledger: nothing else brings the alert back,
           -- since support having ended leaves both ledger boundaries in the past
           let UserBadgePurchase {issueError = failureBefore} = p
-              UserBadgePurchase {alertSnoozeUntil, issueError = failureAfter} = p'
+              UserBadgePurchase {alertSnoozeUntil, issueError = failureAfter, purchaseKind = kindAfter} = p'
               snoozeAt = find (> now) alertSnoozeUntil
               stalledAt = if requestDue && not issued then Just $ badgeStalledInterval `addUTCTime` now else Nothing
               wakeAt = earliestTime [serviceAt, snoozeAt, stalledAt, badgeBoundary now (shownBadgeCredential user'' p') balance']
               failed = failureAfter /= failureBefore
+              subscriptionChanged = kindAfter /= purchaseKind
           -- written before the event, so the state it reports carries the attempt it leads to
           withStore' $ \db -> setBadgeNextWake db badgePurchaseId wakeAt
-          when (retired || issued || failed) $ toView . CEvtBadgeChanged user'' =<< getUserBadgeState user''
+          when (retired || issued || failed || subscriptionChanged) $ toView . CEvtBadgeChanged user'' =<< getUserBadgeState user''
           pure wakeAt
 
 -- | The other kinds need subscriptions, and warning before a prepaid badge ends is not actionable
@@ -5599,9 +5611,12 @@ updateUserBadge userId emitted now = do
 derivedBadgeAlert :: UTCTime -> UserBadgePurchase -> Maybe BadgeCredential -> StatementEntry -> Maybe BadgeAlert
 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
+  | endsAt <= now && not (subscribed && shown) = Just $ alertOf BASupportEnded endsAt
   | otherwise = (\BadgeIssueError {failedSince} -> alertOf BAIssueFailed failedSince) <$> shownIssueError now p shownCred
   where
+    subscribed = case purchaseKind of
+      PKSubscription _ -> True
+      PKPrepaid -> False
     endsAt = L.paidThrough b
     alertOf kind date = BadgeAlert {kind, episode = safeDecodeUtf8 $ strEncode date, date, price = Nothing}
 
@@ -5646,8 +5661,12 @@ getUserBadgeState user = do
     Just p@UserBadgePurchase {badgePurchaseId} ->
       fmap (badgeStateOf now p) <$> withStore' (`getBadgeLedgerLastEntry` badgePurchaseId)
   where
-    badgeStateOf now p@UserBadgePurchase {badgePurchaseId, purchaseKey, badgeType, shown, nextWakeAt} balance =
+    badgeStateOf now p@UserBadgePurchase {badgePurchaseId, purchaseKey, badgeType, shown, nextWakeAt, purchaseKind} balance =
       let shownCred = shownBadgeCredential user p
+          subscription = case purchaseKind of
+            PKSubscription s -> Just s
+            PKPrepaid -> Nothing
+          (renewsAt, willRenew) = badgeRenewal (L.paidThrough balance) subscription
        in BadgeState
             { badgePurchaseId,
               purchaseKey,
@@ -5655,13 +5674,20 @@ getUserBadgeState user = do
               shown = BoolDef shown,
               monthsLeft = balanceMonths balance,
               paidThrough = L.paidThrough balance,
-              renewsAt = Nothing,
-              willRenew = False,
+              renewsAt,
+              willRenew,
               alert = unansweredBadgeAlert now p shownCred balance,
               issueError = shownIssueError now p shownCred,
-              nextWakeAt
+              nextWakeAt,
+              subscription
             }
 
+-- | renewsAt and willRenew predate the subscription's state, and say only whether it was last seen renewing.
+badgeRenewal :: UTCTime -> Maybe BadgeSubscription -> (Maybe UTCTime, Bool)
+badgeRenewal paidThrough = \case
+  Just BadgeSubscription {status = Just SSRenewing} -> (Just paidThrough, True)
+  _ -> (Nothing, False)
+
 -- | How long a month that did not issue waits before it is tried again, whatever stopped it. Not
 -- derived from the failure, so a misclassified one cannot leave a funded badge to expire.
 badgeStalledInterval :: NominalDiffTime
@@ -5697,8 +5723,11 @@ credentialExpiry (BadgeCredential _ _ _ BadgeInfo {badgeExpiry}) = badgeExpiry
 -- 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
+  (balanceMonths balance > 0 || subscribed) && latestCred == shownCred && maybe False lapsingSoon shownCred
   where
+    subscribed = case purchaseKind of
+      PKSubscription _ -> True
+      PKPrepaid -> False
     lapsingSoon cred = credentialExpiry cred <= badgeRequestLead `addUTCTime` now
 
 -- | The request and the presentation, a day apart, both read off the credential the profile shows,
@@ -5781,6 +5810,9 @@ requestBadgeIssue userId UserBadgePurchase {badgePurchaseId, badgeType, purchase
         storedAt <- badgeNow
         (applied, balance_) <- withStore' $ \db -> do
           applied <- applyBadgeStatement db g badgePurchaseId badgeType statement verifiedCred_ storedAt
+          -- the service reads the store only for a request whose asserted coverage had ended when it was made;
+          -- to any other it repeats the state it stored, which for an annual plan can be a year old
+          when (L.paidThrough lastEntry <= now) $ forM_ subscription $ setBadgeSubscriptionStatus db badgePurchaseId . boundedSubscriptionState
           (applied,) <$> getBadgeLedgerLastEntry db badgePurchaseId
         -- the statement is applied either way, so a month can be spent with nothing to show for it
         case (sentCred_, verifiedCred_, applied) of
@@ -5854,11 +5886,11 @@ stopBadgeWorkers workers =
     cancelBadgeWorker v =
       void $ forkIO $ atomically (badgeWorkerAsync <$> readTMVar (sessionVar v)) >>= uninterruptibleCancel
 
--- | Verify the credential before writing anything; the purchase, the statement's rows, the
--- issuance and the profile's badge go in one transaction. Answers the user to tell contacts about,
+-- | Verify the credential before writing anything; the purchase, its subscription's state, the statement's
+-- rows, the issuance and the profile's badge go in one transaction. Answers the user to tell contacts about,
 -- which the caller does once the badge lock is released.
-storeRedeemedBadge :: User -> BadgeStash -> BadgeCredential -> BadgeStatement -> CM (Maybe User, ChatResponse)
-storeRedeemedBadge user@User {userId} stash@BadgeStash {masterKey} cred@(BadgeCredential _ credMasterKey _ info@BadgeInfo {badgeType}) statement =
+storeRedeemedBadge :: User -> BadgeStash -> BadgeCredential -> BadgeStatement -> Maybe SubscriptionState -> CM (Maybe User, ChatResponse)
+storeRedeemedBadge user@User {userId} stash@BadgeStash {masterKey} cred@(BadgeCredential _ credMasterKey _ info@BadgeInfo {badgeType}) statement subscription_ =
   verifyOwnBadge cred >>= \case
     Nothing -> throwRedeemError BREUnknownKeyIndex
     Just False -> throwRedeemError BRECredentialNotVerified
@@ -5872,6 +5904,7 @@ storeRedeemedBadge user@User {userId} stash@BadgeStash {masterKey} cred@(BadgeCr
       -- TODO [badges] retire a previously held badge
       (user', newBadge, applied) <- withStore $ \db -> do
         (purchaseId, newBadge) <- liftIO $ createStashBadgePurchase db user stash cred now
+        when newBadge $ forM_ subscription_ $ liftIO . setBadgeSubscriptionStatus db purchaseId
         applied <- liftIO $ applyBadgeStatement db g purchaseId badgeType statement (Just cred) now
         -- a replay must not put a superseded badge back, or tell every contact again
         user' <- if newBadge then setUserBadge db user (Just badge) else getUser db userId

src/Simplex/Chat/Store/Badges.hs

@@ -13,6 +13,7 @@ module Simplex.Chat.Store.Badges
     PurchaseKind (..),
     getUserBadgePurchase,
     getBadgePurchase,
+    setBadgeSubscriptionStatus,
     userHasBadge,
     setBadgeAlertAcked,
     setBadgeIssueError,
@@ -54,7 +55,7 @@ import Data.Time.Clock (UTCTime)
 import Simplex.Chat.Badges
 import Simplex.Chat.Badges.Ledger
 import Simplex.Chat.Badges.Service (StatementCreditType (..), StatementDebitType (..), StatementEntry (..), StatementEntryType (..))
-import Simplex.Chat.Badges.Types (BadgeAlertKind, BadgeIssueError (..), BadgeIssueFailure, BadgePurchaseStatus (..), OpenStorePurchase (..))
+import Simplex.Chat.Badges.Types (BadgeAlertKind, BadgeIssueError (..), BadgeIssueFailure, BadgePurchaseStatus (..), BadgeSubscription (..), OpenStorePurchase (..), SubscriptionState)
 import Simplex.Chat.PaymentService (ServicePayment)
 import Simplex.Chat.PaymentService.Types (StoreTransactionRef (..))
 import Simplex.Chat.Store.Shared (StoreError, insertedRowId)
@@ -397,7 +398,7 @@ data UserBadgePurchase = UserBadgePurchase
 
 -- | 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
+data PurchaseKind = PKPrepaid | PKSubscription BadgeSubscription
   deriving (Eq)
 
 -- | Newest, not the one shown_badge_id points at - retirement clears that, and the support ended
@@ -428,17 +429,18 @@ getBadgePurchase db purchaseId =
                (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,
-               (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)
+               (SELECT l.change_months FROM badge_ledger l
+                WHERE l.badge_purchase_id = p.badge_purchase_id AND l.entry_type = 'credit' AND l.entry_credit_type = 'charge'
+                ORDER BY l.entry_id DESC
+                LIMIT 1),
+               p.subscription_status
         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, BI charged)) =
+    toPurchase ((badgePurchaseId, purchaseKey, purchasePrivKey, Binary mk, badgeType, shown_, ackedKind_, ackedEpisode_, alertSnoozeUntil) :. (failedSince_, lastAttemptAt_, reason_, nextWakeAt, planMonths_, status)) =
       UserBadgePurchase
         { badgePurchaseId,
           purchaseKey,
@@ -450,9 +452,13 @@ getBadgePurchase db purchaseId =
           alertSnoozeUntil,
           issueError = BadgeIssueError <$> failedSince_ <*> lastAttemptAt_ <*> reason_,
           nextWakeAt,
-          purchaseKind = if charged then PKSubscription else PKPrepaid
+          purchaseKind = maybe PKPrepaid (\planMonths -> PKSubscription BadgeSubscription {planMonths, status}) planMonths_
         }
 
+setBadgeSubscriptionStatus :: DB.Connection -> Int64 -> SubscriptionState -> IO ()
+setBadgeSubscriptionStatus db badgePurchaseId state =
+  DB.execute db "UPDATE badge_purchases SET subscription_status = ? WHERE badge_purchase_id = ?" (state, badgePurchaseId)
+
 -- | Whether a badge is on the profile now: set when a redemption stores one, cleared when it is
 -- retired. Read as the id rather than as a comparison, which in Postgres would be a boolean.
 userHasBadge :: DB.Connection -> User -> IO Bool

src/Simplex/Chat/Store/Postgres/Migrations/M20260925_badge_store_receipts.hs

@@ -36,11 +36,15 @@ CREATE INDEX idx_badge_store_receipts_user ON badge_store_receipts(user_id);
 ALTER TABLE badge_purchases ADD COLUMN badge_store_receipt_id BIGINT REFERENCES badge_store_receipts;
 
 CREATE UNIQUE INDEX idx_badge_purchases_store_receipt ON badge_purchases(badge_store_receipt_id);
+
+ALTER TABLE badge_purchases ADD COLUMN subscription_status TEXT;
 |]
 
 down_m20260925_badge_store_receipts :: Text
 down_m20260925_badge_store_receipts =
   [r|
+ALTER TABLE badge_purchases DROP COLUMN subscription_status;
+
 DROP INDEX idx_badge_purchases_store_receipt;
 
 ALTER TABLE badge_purchases DROP COLUMN badge_store_receipt_id;

src/Simplex/Chat/Store/SQLite/Migrations/M20260925_badge_store_receipts.hs

@@ -35,11 +35,15 @@ CREATE INDEX idx_badge_store_receipts_user ON badge_store_receipts(user_id);
 ALTER TABLE badge_purchases ADD COLUMN badge_store_receipt_id INTEGER REFERENCES badge_store_receipts;
 
 CREATE UNIQUE INDEX idx_badge_purchases_store_receipt ON badge_purchases(badge_store_receipt_id);
+
+ALTER TABLE badge_purchases ADD COLUMN subscription_status TEXT;
 |]
 
 down_m20260925_badge_store_receipts :: Query
 down_m20260925_badge_store_receipts =
   [sql|
+ALTER TABLE badge_purchases DROP COLUMN subscription_status;
+
 DROP INDEX idx_badge_purchases_store_receipt;
 
 ALTER TABLE badge_purchases DROP COLUMN badge_store_receipt_id;

src/Simplex/Chat/Store/SQLite/Migrations/chat_schema.sql

@@ -939,6 +939,7 @@ CREATE TABLE badge_purchases(
   issue_error TEXT,
   next_wake_at TEXT,
   badge_store_receipt_id INTEGER REFERENCES badge_store_receipts,
+  subscription_status TEXT,
   UNIQUE(purchase_key)
 ) STRICT;
 CREATE TABLE badge_ledger(

src/Simplex/Chat/View.hs

@@ -46,7 +46,7 @@ import Simplex.Chat.Markdown
 import Simplex.Chat.Badges (BadgeInfo (..), BadgeStatus (..), BadgeType (..), LocalBadge, localBadgeInfo, localBadgeStatus)
 import Simplex.Chat.Badges.Ledger (creditTypeTag, debitTypeTag)
 import Simplex.Chat.Badges.Service (StatementEntry (..), StatementEntryType (..))
-import Simplex.Chat.Badges.Types (BadgeAlert (..), BadgeIssueError (..), BadgeState (..), OpenStorePurchase (..))
+import Simplex.Chat.Badges.Types (BadgeAlert (..), BadgeIssueError (..), BadgeState (..), BadgeSubscription (..), OpenStorePurchase (..))
 import Simplex.Chat.Messages hiding (NewChatItem (..))
 import Simplex.Chat.Messages.CIContent
 import Simplex.Chat.Operators
@@ -1845,7 +1845,7 @@ viewContactBadge = maybe [] $ \lb ->
 viewUserBadgeState :: Maybe BadgeState -> [StyledString]
 viewUserBadgeState = maybe [] viewBadge
   where
-    viewBadge BadgeState {badgePurchaseId, badgeType, monthsLeft, paidThrough, alert, issueError, nextWakeAt} =
+    viewBadge BadgeState {badgePurchaseId, badgeType, monthsLeft, paidThrough, alert, issueError, nextWakeAt, subscription} =
       plain
         ( tshow badgePurchaseId
             <> ": "
@@ -1854,10 +1854,12 @@ viewUserBadgeState = maybe [] viewBadge
             <> tshow monthsLeft
             <> " months left, paid through "
             <> day paidThrough
+            <> maybe "" viewSubscription subscription
             <> maybe "" ((", next check " <>) . dayTime) nextWakeAt
         )
         : maybe [] viewBadgeIssueError issueError
           <> maybe [] viewBadgeAlert alert
+    viewSubscription BadgeSubscription {status} = ", subscription" <> maybe "" ((" " <>) . textEncode) status
 
 viewBadgeIssueError :: BadgeIssueError -> [StyledString]
 viewBadgeIssueError BadgeIssueError {failedSince, lastAttemptAt, reason} =