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} =

tests/BadgeTests.hs

@@ -35,12 +35,14 @@ import Simplex.Chat.Badges
 import Simplex.Chat.Badges.Code
 import Simplex.Chat.Badges.Ledger
 import Simplex.Chat.Badges.Service
-import Simplex.Chat.Badges.Types (BadgeIssueFailure (..))
+import Simplex.Chat.Badges.Types (BadgeIssueFailure (..), BadgeSubscription (..))
+import qualified Simplex.Chat.Badges.Types as BT
 import Simplex.Chat (defaultChatConfig)
 import Simplex.Chat.Controller (BadgeRedeemError (..), ChatError (..), ChatErrorType (..), badgeRetryInterval, chatErrorAgent)
-import Simplex.Chat.Library.Commands (badgeErrorRetry, badgeFailureTransient, badgeIssueFailure, badgeRetryAfter, badgeServiceErrorText, badgeStalledInterval, storeTransactionRef)
+import Simplex.Chat.Library.Commands (badgeErrorRetry, badgeFailureTransient, badgeIssueFailure, badgeRenewal, badgeRetryAfter, badgeServiceErrorText, badgeStalledInterval, boundedSubscriptionState, storeTransactionRef)
 import Simplex.Chat.PaymentService (ServicePayment (..), appleTransactionRef)
 import Simplex.Chat.PaymentService.Types (InvoiceId (..), PaymentProvider (..), StoreTransactionRef (..))
+import Simplex.Chat.Types (BoolDef (..))
 import Simplex.Messaging.Agent.Protocol (AgentErrorType (..), AgentServiceError (..), SMPAgentError (..))
 import Simplex.Messaging.Agent.RetryInterval (RetryInterval (..), nextRetryDelay)
 import Simplex.Messaging.Crypto.BBS
@@ -109,6 +111,8 @@ badgeTests = do
     it "badgeCredential carries a subscription's state, and reads one it does not know as unknown" testCredentialSubscriptionJSON
     it "error response matches the schema" testErrorResponseJSON
     it "statement entries round-trip, unknown entry types verbatim" testStatementJSON
+  describe "badge state" $ do
+    it "carries a subscription's plan and last seen state, renewing only when it was seen renewing, and bounds a state it does not know" testBadgeSubscriptionJSON
   describe "store purchases" $ do
     it "keys a purchase by the store's transaction id, not by the evidence signed over it" testStoreTransactionRef
     it "claims an Apple subscription by its original transaction id, and any other transaction by its own" testAppleTransactionRef
@@ -1073,6 +1077,31 @@ testCredentialSubscriptionJSON = do
   J.toJSON resp `shouldBe` response (Just "renewing")
   roundTrips resp
 
+testBadgeSubscriptionJSON :: IO ()
+testBadgeSubscriptionJSON = do
+  drg <- C.newRandom
+  (k, _) <- atomically $ C.generateKeyPair drg :: IO (C.KeyPair 'C.Ed25519)
+  let badgeState subscription =
+        BT.BadgeState {badgePurchaseId = 1, purchaseKey = k, badgeType = BTSupporter, shown = BoolDef True, monthsLeft = 0, paidThrough = futureTime, renewsAt = Nothing, willRenew = False, alert = Nothing, issueError = Nothing, nextWakeAt = Nothing, subscription}
+      subscriptionField v = case J.toJSON v of
+        J.Object o -> KM.lookup "subscription" o
+        _ -> Nothing
+  subscriptionField (badgeState Nothing) `shouldBe` Nothing
+  subscriptionField (badgeState $ Just BadgeSubscription {planMonths = 12, status = Just SSCancelled})
+    `shouldBe` Just (J.object ["planMonths" J..= (12 :: Int), "status" J..= ("cancelled" :: T.Text)])
+  -- not yet observed: the field is left out rather than sent as null
+  subscriptionField (badgeState $ Just BadgeSubscription {planMonths = 1, status = Nothing})
+    `shouldBe` Just (J.object ["planMonths" J..= (1 :: Int)])
+  let renewal status = badgeRenewal futureTime $ Just BadgeSubscription {planMonths = 1, status}
+  renewal (Just SSRenewing) `shouldBe` (Just futureTime, True)
+  mapM_ (\s -> renewal s `shouldBe` (Nothing, False)) [Nothing, Just SSCancelled, Just SSBillingRetry, Just SSEnded, Just (SSUnknown "renewing soon")]
+  badgeRenewal futureTime Nothing `shouldBe` (Nothing, False)
+  boundedSubscriptionState SSBillingRetry `shouldBe` SSBillingRetry
+  boundedSubscriptionState (SSUnknown "onHold") `shouldBe` SSUnknown "onHold"
+  boundedSubscriptionState (SSUnknown "Visit evil.example.com!\ESC[2J") `shouldBe` SSUnknown "Visitevilexamplecom2J"
+  boundedSubscriptionState (SSUnknown (T.replicate 100 "a")) `shouldBe` SSUnknown (T.replicate 32 "a")
+  boundedSubscriptionState (SSUnknown "") `shouldBe` SSUnknown "unknown"
+
 testErrorResponseJSON :: IO ()
 testErrorResponseJSON = do
   let resp = BSPError {code = BSECodeInvalid, message = Nothing, retryAfter = Nothing}

tests/Bots/BadgeService/BotTests.hs

@@ -43,7 +43,7 @@ import Data.Char (toLower)
 import Data.Either (isLeft, isRight)
 import Data.Int (Int64)
 import Data.IORef (IORef, modifyIORef', newIORef, readIORef, writeIORef)
-import Data.List (isPrefixOf, stripPrefix)
+import Data.List (isInfixOf, isPrefixOf, stripPrefix)
 import Data.List.NonEmpty (NonEmpty (..))
 import qualified Data.Map.Strict as M
 import Data.Maybe (isJust, isNothing)
@@ -196,6 +196,8 @@ badgeServiceTests = do
     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 keep the state the service answered when it credited and when it renewed past paid coverage, and announce a change" testSubscriptionStateKept
+    it "should keep the state from the credit through an issuance the service answers from its stored state" testAnnualStateNotFromStoredAnswer
     it "should resolve an Apple renewal to the subscription's record, and credit a held record that adopted it" testAppleRenewalResolvesToPurchase
     it "should refuse an App Store Sandbox subscription as a test purchase without asking Apple" testAppleSandboxSubscriptionNotAsked
     it "should answer an App Store subscription provider_not_configured without an API key, and credit a one-time purchase" testAppleSubscriptionWithoutApiKey
@@ -2283,8 +2285,8 @@ testSubscriptionAwaitsCharge ps =
       storeReports store $ subscriptionCheck SSBillingRetry Nothing
       checks <- subscriptionChecks store
       setClockAt bsClock requestAt
-      alice ##> "/_app activate"
-      alice <## "ok"
+      alice `send` "/_app activate"
+      alice <### ["/_app activate", "ok", Predicate (", subscription billingRetry" `isInfixOf`)]
       -- 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
@@ -2328,6 +2330,49 @@ testSubscriptionEnds ps =
       threadDelay 2000000
       subscriptionChecks store `shouldReturn` checks
 
+subscriptionStatuses :: ChatController -> IO [Maybe Text]
+subscriptionStatuses ChatController {chatStore} =
+  withTransaction chatStore $ \db -> map fromOnly <$> DB.query_ db "SELECT subscription_status FROM badge_purchases"
+
+testSubscriptionStateKept :: HasCallStack => TestParams -> IO ()
+testSubscriptionStateKept ps =
+  withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClock, bsClientCfg, bsStore = store} ->
+    withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do
+      (_, rows) <- clientSubscribedMonthly env alice
+      subscriptionStatuses (chatController alice) `shouldReturn` [Just "renewing"]
+      alice ##> "/_badge state 1"
+      alice <### [Predicate (\l -> "1: supporter, 0 months left" `isPrefixOf` l && ", subscription renewing" `isInfixOf` l)]
+      -- the request asserts coverage that has ended, so the service asks the store for its answer
+      storeReports store $ subscriptionCheck SSBillingRetry Nothing
+      setClockAt bsClock $ fst $ renewalMoments rows
+      alice `send` "/_app activate"
+      alice <### ["/_app activate", "ok", Predicate (", subscription billingRetry" `isInfixOf`)]
+      subscriptionStatuses (chatController alice) `shouldReturn` [Just "billingRetry"]
+
+-- | The service answers a request made while coverage runs from the state it stored, which for an annual plan is up to a year old.
+testAnnualStateNotFromStoredAnswer :: HasCallStack => TestParams -> IO ()
+testAnnualStateNotFromStoredAnswer ps =
+  withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClock, bsClientCfg, bsController = cc@ChatController {chatStore}, bsStore = store} ->
+    withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do
+      firstStart <- addUTCTime (-3600) <$> serviceNow env
+      storeReports store $ subscriptionCheck SSCancelled $ Just $ storeCharge "subscr-badge-supporter-year-01" firstStart 12
+      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` [(12, 12, Just "charge"), (-1, 11, Just "badge")]
+      subscriptionStatuses (chatController alice) `shouldReturn` [Just "cancelled"]
+      withTransaction chatStore $ \db -> DB.execute_ db "UPDATE sx_badge_service_payments SET subscription_state = 'renewing'"
+      checks <- subscriptionChecks store
+      setClockAt bsClock $ fst $ renewalMoments rows
+      alice ##> "/_app activate"
+      alice <## "ok"
+      _ <- waitLedgerRows (chatController alice) 3
+      alice <### [Predicate (\l -> "1: supporter, 10 months left" `isPrefixOf` l && ", subscription cancelled" `isInfixOf` l)]
+      subscriptionChecks store `shouldReturn` checks
+      subscriptionPayments cc `shouldReturn` [("google", googlePurchaseRef googleSubscriptionToken, Just "renewing", Just googleSubscriptionToken)]
+      subscriptionStatuses (chatController alice) `shouldReturn` [Just "cancelled"]
+
 setStoreReceiptDue :: ChatController -> UTCTime -> IO ()
 setStoreReceiptDue ChatController {chatStore} t =
   withTransaction chatStore $ \db -> DB.execute db "UPDATE badge_store_receipts SET next_attempt_at = ?" (Only t)