From 7bc4dbca3646fda32ebe224f838299a66838dc18 Mon Sep 17 00:00:00 2001 From: spacedandy-agents-simplex <342056592+spacedandy-agents-simplex@users.noreply.github.com> Date: Wed, 14 Oct 2026 20:27:40 +0000 Subject: [PATCH] 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 | 17 ++++- src/Simplex/Chat/Library/Commands.hs | 69 ++++++++++++++----- src/Simplex/Chat/Store/Badges.hs | 22 +++--- .../M20260925_badge_store_receipts.hs | 4 ++ .../M20260925_badge_store_receipts.hs | 4 ++ .../Store/SQLite/Migrations/chat_schema.sql | 1 + src/Simplex/Chat/View.hs | 6 +- tests/BadgeTests.hs | 33 ++++++++- tests/Bots/BadgeService/BotTests.hs | 51 +++++++++++++- 9 files changed, 173 insertions(+), 34 deletions(-) diff --git a/src/Simplex/Chat/Badges/Types.hs b/src/Simplex/Chat/Badges/Types.hs index b773ef409a..88f5c03cc5 100644 --- a/src/Simplex/Chat/Badges/Types.hs +++ b/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) diff --git a/src/Simplex/Chat/Library/Commands.hs b/src/Simplex/Chat/Library/Commands.hs index 8f835143c4..81a1138168 100644 --- a/src/Simplex/Chat/Library/Commands.hs +++ b/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 diff --git a/src/Simplex/Chat/Store/Badges.hs b/src/Simplex/Chat/Store/Badges.hs index 27fecce6c9..a5869f00d8 100644 --- a/src/Simplex/Chat/Store/Badges.hs +++ b/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 diff --git a/src/Simplex/Chat/Store/Postgres/Migrations/M20260925_badge_store_receipts.hs b/src/Simplex/Chat/Store/Postgres/Migrations/M20260925_badge_store_receipts.hs index 093031e21d..04165e760a 100644 --- a/src/Simplex/Chat/Store/Postgres/Migrations/M20260925_badge_store_receipts.hs +++ b/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; diff --git a/src/Simplex/Chat/Store/SQLite/Migrations/M20260925_badge_store_receipts.hs b/src/Simplex/Chat/Store/SQLite/Migrations/M20260925_badge_store_receipts.hs index bf02837cb9..52f48de3cd 100644 --- a/src/Simplex/Chat/Store/SQLite/Migrations/M20260925_badge_store_receipts.hs +++ b/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; diff --git a/src/Simplex/Chat/Store/SQLite/Migrations/chat_schema.sql b/src/Simplex/Chat/Store/SQLite/Migrations/chat_schema.sql index 9ef56d8aa9..aae133a968 100644 --- a/src/Simplex/Chat/Store/SQLite/Migrations/chat_schema.sql +++ b/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( diff --git a/src/Simplex/Chat/View.hs b/src/Simplex/Chat/View.hs index c8c106f323..4672699a33 100644 --- a/src/Simplex/Chat/View.hs +++ b/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} = diff --git a/tests/BadgeTests.hs b/tests/BadgeTests.hs index c2a3470742..3d81ba2dae 100644 --- a/tests/BadgeTests.hs +++ b/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} diff --git a/tests/Bots/BadgeService/BotTests.hs b/tests/Bots/BadgeService/BotTests.hs index 732e50e262..66eb20148a 100644 --- a/tests/Bots/BadgeService/BotTests.hs +++ b/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)