diff --git a/bots/src/API/Docs/Commands.hs b/bots/src/API/Docs/Commands.hs index ca95a37f4e..b5653c7fd5 100644 --- a/bots/src/API/Docs/Commands.hs +++ b/bots/src/API/Docs/Commands.hs @@ -430,6 +430,7 @@ undocumentedCommands = "APISendCallOffer", "APISendServiceRequest", "APISetAppFilePaths", + "APISetBadgeSubscriptionStatus", "APISetChatItemTTL", "APISetChatSettings", "APISetChatTags", diff --git a/src/Simplex/Chat/Controller.hs b/src/Simplex/Chat/Controller.hs index e8fe0b44f8..07d100d872 100644 --- a/src/Simplex/Chat/Controller.hs +++ b/src/Simplex/Chat/Controller.hs @@ -85,7 +85,7 @@ import Simplex.Messaging.Client (HostMode (..), SMPProxyFallback (..), SMPProxyM import qualified Simplex.Messaging.Crypto as C import Simplex.Chat.Badges (BadgeCredential, FileSizeLimits, LocalBadge) import Simplex.Chat.Badges.Service (BadgeServiceErrorCode, StatementEntry) -import Simplex.Chat.Badges.Types (BadgeAlert (..), BadgeAlertKind, BadgeIssueFailure, BadgeState (..), OpenStorePurchase (..)) +import Simplex.Chat.Badges.Types (BadgeAlert (..), BadgeAlertKind, BadgeIssueFailure, BadgeState (..), OpenStorePurchase (..), SubscriptionState) import Simplex.Chat.PaymentService (ServicePayment) import Simplex.Messaging.Crypto.BBS (BBSPublicKey) import Simplex.Messaging.Crypto.File (CryptoFile (..)) @@ -666,6 +666,7 @@ data ChatCommand | AddBadge BadgeCredential -- attach an issued badge credential (testing; credential from `simplex-chat badge sign`) | APIRedeemBadgeCode {userId :: UserId, code :: Text} -- redeem a badge code with the configured badge service | APIPurchaseBadge {userId :: UserId, echoedInvoiceId :: Maybe Text, payment :: ServicePayment} -- hand over an App Store or Google Play receipt, held until a worker credits it; answers from the record and sends nothing + | APISetBadgeSubscriptionStatus {status :: SubscriptionState, payment :: ServicePayment} -- the device store's view of a credited subscription, which changes only what is shown and alerted | APICreateBadgeInvoice {userId :: UserId} -- the record of a store purchase, created before the store charges; answers the id the store echoes | APIGetBadgeState {userId :: UserId} -- the user's badges, their balances and any current alert | APIGetBadgeLedger {userId :: UserId, badgePurchaseId :: Int64} -- the purchase's ledger, oldest first diff --git a/src/Simplex/Chat/Library/Commands.hs b/src/Simplex/Chat/Library/Commands.hs index 81a1138168..5ef428c754 100644 --- a/src/Simplex/Chat/Library/Commands.hs +++ b/src/Simplex/Chat/Library/Commands.hs @@ -3582,6 +3582,7 @@ processChatCommand cxt nm = \case AddBadge cred -> withUser $ \user -> addUserBadge user cred >> ok user APIRedeemBadgeCode userId codeText -> withUserId userId $ \user -> redeemBadgeCode nm user codeText APIPurchaseBadge userId echoedInvoiceId payment -> withUserId userId $ \user -> handOverStoreReceipt user echoedInvoiceId payment + APISetBadgeSubscriptionStatus status payment -> recordStoreSubscriptionStatus status payment >> ok_ APICreateBadgeInvoice userId -> withUserId userId $ \user -> do void requireBadgeService refuseWhileBadgeHeld user @@ -5303,6 +5304,30 @@ handOverStoreReceipt presentingUser echoedInvoiceId payment = do RSRefused {refusal = Just BIFServiceError {code}} -> throwRedeemError $ BREServiceError code RSRefused {} -> throwChatError $ CEInternalError "store purchase refused for no recorded reason" +-- | Renewing does not replace billing retry or ended: Play lists a subscription in its grace period as renewing, +-- and the service's answer clears billing retry once the store charges. +recordStoreSubscriptionStatus :: SubscriptionState -> ServicePayment -> CM () +recordStoreSubscriptionStatus reported payment = do + txRef <- maybe (throwRedeemError BREInvalidReceipt) pure $ storeTransactionRef payment + changedOwner_ <- withStore' $ \db -> + getReceiptRecord db txRef >>= \case + Just BadgeReceiptRecord {ownerId, status = RSCredited {badgePurchaseId}} -> + getBadgePurchase db badgePurchaseId >>= \case + Just UserBadgePurchase {purchaseKind = PKSubscription BadgeSubscription {status}} + | replaces status -> Just ownerId <$ setBadgeSubscriptionStatus db badgePurchaseId reported + _ -> pure Nothing + _ -> pure Nothing + forM_ changedOwner_ $ \ownerId -> do + owner <- withStore (`getUser` ownerId) + toView . CEvtBadgeChanged owner =<< getUserBadgeState owner + lift $ startBadgeWork owner + where + replaces = \case + Just stored | stored == reported -> False + Just SSBillingRetry -> reported /= SSRenewing + Just SSEnded -> reported /= SSRenewing + _ -> True + -- | The receipt will never be credited to its key; any other refusal may pass on a retry. storeReceiptRefused :: BadgeServiceErrorCode -> Bool storeReceiptRefused = \case @@ -6352,6 +6377,7 @@ chatCommandP = "/_service_request " *> (APISendServiceRequest <$> A.decimal <* A.space <*> strP <*> optional (" timeout=" *> (realToFrac <$> A.double)) <*> optional (" sign_key=" *> strP) <* A.space <*> jsonP), "/_redeem_badge_code " *> (APIRedeemBadgeCode <$> A.decimal <* A.space <*> textP), "/_badge purchase " *> (APIPurchaseBadge <$> A.decimal <*> optional (" invoice=" *> (safeDecodeUtf8 <$> A.takeTill (== ' '))) <* A.space <*> jsonP), + "/_badge subscription " *> (APISetBadgeSubscriptionStatus <$> subscriptionStateP <* A.space <*> jsonP), "/_badge invoice " *> (APICreateBadgeInvoice <$> A.decimal), "/_badge state " *> (APIGetBadgeState <$> A.decimal), "/_badge ledger " *> (APIGetBadgeLedger <$> A.decimal <* A.space <*> A.decimal), @@ -6778,6 +6804,13 @@ chatCommandP = badgeAlertKindP = do t <- A.takeTill (== ' ') maybe (fail "bad badge alert kind") pure $ textDecode $ safeDecodeUtf8 t + subscriptionStateP = + A.takeTill (== ' ') >>= \case + "renewing" -> pure SSRenewing + "cancelled" -> pure SSCancelled + "billingRetry" -> pure SSBillingRetry + "ended" -> pure SSEnded + _ -> fail "bad subscription state" pwdP = jsonP <|> (UserPwd . safeDecodeUtf8 <$> A.takeTill (== ' ')) verifyCodeP = safeDecodeUtf8 <$> A.takeWhile (\c -> isDigit c || c == ' ') msgTextP = jsonP <|> textP diff --git a/src/Simplex/Chat/Store/Badges.hs b/src/Simplex/Chat/Store/Badges.hs index a5869f00d8..55d02559c9 100644 --- a/src/Simplex/Chat/Store/Badges.hs +++ b/src/Simplex/Chat/Store/Badges.hs @@ -24,6 +24,7 @@ module Simplex.Chat.Store.Badges BadgeReceiptRecord (..), BadgeReceiptStatus (..), holdStoreReceipt, + getReceiptRecord, createBadgeStoreReceipt, getOpenStorePurchases, getNextHeldStoreReceipt, diff --git a/tests/Bots/BadgeService/BotTests.hs b/tests/Bots/BadgeService/BotTests.hs index 66eb20148a..25e607286d 100644 --- a/tests/Bots/BadgeService/BotTests.hs +++ b/tests/Bots/BadgeService/BotTests.hs @@ -198,6 +198,7 @@ badgeServiceTests = do 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 keep the device store's view of a credited subscription, except renewing over billing retry, and nothing for any other transaction" testSubscriptionStateFromStore 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 @@ -2373,6 +2374,42 @@ testAnnualStateNotFromStoredAnswer ps = subscriptionPayments cc `shouldReturn` [("google", googlePurchaseRef googleSubscriptionToken, Just "renewing", Just googleSubscriptionToken)] subscriptionStatuses (chatController alice) `shouldReturn` [Just "cancelled"] +testSubscriptionStateFromStore :: HasCallStack => TestParams -> IO () +testSubscriptionStateFromStore ps = + withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClock, bsClientCfg, bsStore = store} -> + withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do + (_, rows) <- clientSubscribedMonthly env alice + let report state payment = alice ##> ("/_badge subscription " <> state <> " " <> paymentArg payment) + report "cancelled" subscriptionPlay + alice <### ["ok", Predicate (", subscription cancelled" `isInfixOf`)] + subscriptionStatuses (chatController alice) `shouldReturn` [Just "cancelled"] + report "cancelled" subscriptionPlay + alice <## "ok" + -- Play lists a subscription in its grace period as renewing, which does not replace the service's billing retry + storeReports store $ subscriptionCheck SSBillingRetry Nothing + setClockAt bsClock $ fst $ renewalMoments rows + alice `send` "/_app activate" + alice <### ["/_app activate", "ok", Predicate (", subscription billingRetry" `isInfixOf`)] + checks <- subscriptionChecks store + report "renewing" subscriptionPlay + alice <## "ok" + subscriptionStatuses (chatController alice) `shouldReturn` [Just "billingRetry"] + -- a held transaction, here a one-time purchase handed over while the badge is shown, and an unknown one change nothing + alice ##> ("/_badge purchase 1 " <> paymentArg supporterPlay) + alice <##. "1: supporter" + alice <##. openPurchase "" + report "cancelled" supporterPlay + alice <## "ok" + report "cancelled" $ googlePayment "subscr_badge_supporter_01" "fake-play-token-unknown.AO-J1Os2q5djX0pRm6" + alice <## "ok" + subscriptionStatuses (chatController alice) `shouldReturn` [Just "billingRetry"] + report "cancelled" SPApple {jws = "not.a-jws"} + alice <## "cannot get badge: invalid store receipt" + report "paused" subscriptionPlay + alice <##. "bad chat command: " + subscriptionStatuses (chatController alice) `shouldReturn` [Just "billingRetry"] + subscriptionChecks store `shouldReturn` checks + setStoreReceiptDue :: ChatController -> UTCTime -> IO () setStoreReceiptDue ChatController {chatStore} t = withTransaction chatStore $ \db -> DB.execute db "UPDATE badge_store_receipts SET next_attempt_at = ?" (Only t)