core: resume a retired Apple subscription when its store charges it again

A same-install resubscription keeps Apple's original transaction id, so its hand-over found the old credited record and was answered from it with the old credential: the subscriber paid and got nothing. A credited record is now held again when a later charge of its subscription is handed over, the charge is not revoked, its paid period runs and it is dated less than a day ahead of this device's clock, and the record's purchase is its owner's newest, a subscription and not shown, with no other receipt held. The receipt worker then sends the purchase's issueBadge, and the service grants the charge as a renewal. A covered answer shows the purchase again with the newest credential and clears an ended state. A charge the service answers without crediting is deferred an hour and refused a day after its purchase date, so it holds the profile for about a day. A refused resume is remembered on the record (every credit, re-hold and resume clears credit_error), so the app's sweep does not hold the same charge again after its day.

Run: 011-subscription-resume, slice S2a

src/Simplex/Chat/Library/Commands.hs

@@ -53,6 +53,7 @@ import Data.Text.Encoding (decodeLatin1, encodeUtf8)
 import Data.Time (NominalDiffTime, addUTCTime, defaultTimeLocale, formatTime)
 import Data.Word (Word32)
 import Data.Time.Clock (UTCTime, diffUTCTime, getCurrentTime, nominalDay)
+import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
 import Data.Type.Equality
 import qualified Data.UUID as UUID
 import qualified Data.UUID.V4 as V4
@@ -5371,14 +5372,22 @@ handOverStoreReceipt presentingUser echoedInvoiceId origin payment = do
     Nothing -> case origin of
       SROListed -> pure $ CRStoreReceiptNotRecorded presentingUser
       SROPurchased -> throwChatError $ CEInternalError "store receipt was not recorded"
-    Just BadgeReceiptRecord {ownerId, status} -> do
+    Just BadgeReceiptRecord {receiptId, ownerId, status} -> do
       owner <- withStore $ \db -> getUser db ownerId
       case status of
         RSHeld {} -> lift (resumeStoreReceiptWork ownerId) >> badgeStateResponse owner
-        RSCredited {badgePurchaseId} -> do
-          cred_ <- withStore' (`getLatestIssuedCredential` badgePurchaseId)
-          cred@(BadgeCredential _ _ _ info) <- maybe (throwChatError $ CEInternalError "credited store purchase has no credential") pure cred_
-          CRBadgeRedeemed owner (OwnBadge cred (mkBadgeStatus now (Just True) info)) False <$> getUserBadgeState owner
+        RSCredited {badgePurchaseId, refusalRecorded} -> do
+          resumed <- case resumableCharge now payment of
+            -- a charge refused after its hold is answered from the record, or the app's sweep would hold it again at every launch
+            Just purchasedAt | not (refusalRecorded && resumeHoldEnded now purchasedAt) ->
+              withStore' $ \db -> reholdStoreReceipt db owner receiptId badgePurchaseId payment now
+            _ -> pure False
+          if resumed
+            then lift (resumeStoreReceiptWork ownerId) >> badgeStateResponse owner
+            else do
+              cred_ <- withStore' (`getLatestIssuedCredential` badgePurchaseId)
+              cred@(BadgeCredential _ _ _ info) <- maybe (throwChatError $ CEInternalError "credited store purchase has no credential") pure cred_
+              CRBadgeRedeemed owner (OwnBadge cred (mkBadgeStatus now (Just True) info)) False <$> getUserBadgeState owner
         RSRefused {refusal = Just BIFServiceError {code}} -> throwRedeemError $ BREServiceError code
         RSRefused {} -> throwChatError $ CEInternalError "store purchase refused for no recorded reason"
 
@@ -5414,6 +5423,31 @@ storeReceiptRefused = \case
   BSETestPurchase -> True
   _ -> False
 
+-- | How far ahead of this device's clock a charge's purchase date may be: a payload dated further ahead is never held.
+resumeClockSkew :: NominalDiffTime
+resumeClockSkew = nominalDay
+
+-- | How long after a charge's purchase date a resume the service answers without crediting keeps holding the profile.
+resumeHoldLimit :: NominalDiffTime
+resumeHoldLimit = nominalDay
+
+-- | The purchase date of an Apple subscription charge that may resume a retired purchase: not revoked, and bought
+-- for a paid period that has not ended. Read from the unverified payload, which decides only whether to ask the service.
+resumableCharge :: UTCTime -> ServicePayment -> Maybe UTCTime
+resumableCharge now = \case
+  SPApple {jws}
+    | Just AppleTransactionFacts {purchaseDate = Just purchased, expiresDate = Just expires, revoked = False, autoRenewable = True} <- appleTransactionFacts jws,
+      let purchasedAt = millisTime purchased,
+      purchasedAt < resumeClockSkew `addUTCTime` now,
+      now < millisTime expires ->
+        Just purchasedAt
+  _ -> Nothing
+  where
+    millisTime ms = posixSecondsToUTCTime $ fromIntegral ms / 1000
+
+resumeHoldEnded :: UTCTime -> UTCTime -> Bool
+resumeHoldEnded now purchasedAt = resumeHoldLimit `addUTCTime` purchasedAt <= now
+
 -- | The same reference the service claims a transaction by, read without verifying anything.
 storeTransactionRef :: ServicePayment -> Maybe StoreTransactionRef
 storeTransactionRef = \case
@@ -5642,14 +5676,15 @@ creditStoreReceipt a userId receiptId stash@BadgeStash {masterKey} invoiceId_ pa
     liftIO $ waitForUserNetwork a
     -- decided under the lock and acted on outside it: the retry sleeps, and announcing takes the chat lock
     outcome <- withEntityLock "badgePurchase" (CLBadgeUser userId) $
-      tryAllErrors attempt >>= \case
-        Right (Right (present_, _)) -> pure $ SROCredited present_
-        Right (Left (code, retryAfter))
-          | storeReceiptRefused code -> do
-              let failure = serviceFailure code retryAfter
-              SRORefused failure <$ withStore' (\db -> refuseStoreReceipt db receiptId failure)
-          | otherwise -> failed ri delay (serviceFailure code retryAfter) retryAfter
-        Left e -> failed ri delay (badgeIssueFailure e) Nothing
+      withStore' (`getStashBadgePurchase` stash) >>= \case
+        Just purchaseId -> resume ri delay purchaseId
+        Nothing ->
+          tryAllErrors attempt >>= \case
+            Right (Right (present_, _)) -> pure $ SROCredited present_
+            Right (Left (code, retryAfter))
+              | storeReceiptRefused code -> refuse $ serviceFailure code retryAfter
+              | otherwise -> failed ri delay (serviceFailure code retryAfter) retryAfter
+            Left e -> failed ri delay (badgeIssueFailure e) Nothing
     -- the invoice id is the app's only key to the store transaction, so without one nothing is emitted and its sweep finishes it
     case outcome of
       SROCredited present_ -> do
@@ -5670,6 +5705,43 @@ creditStoreReceipt a userId receiptId stash@BadgeStash {masterKey} invoiceId_ pa
       sendTarget <- requireBadgeService
       payment' <- maybe (throwChatError $ CEInternalError "held store payment does not decode") pure $ decodeJSON payment
       requestBadgeStash NRMBackground user sendTarget stash BSCPurchaseBadge {masterKey, payment = payment', upgrade = Nothing}
+    -- a held record whose keys already fund a purchase is a resume of that retired subscription, checked before every send
+    resume ri delay purchaseId = do
+      user <- withStore $ \db -> getUser db userId
+      p_ <- withStore' (`getBadgePurchase` purchaseId)
+      newest_ <- withStore' (`getUserBadgePurchase` user)
+      now <- badgeNow
+      let isNewest = maybe False (\UserBadgePurchase {badgePurchaseId} -> badgePurchaseId == purchaseId) newest_
+      case p_ of
+        Just UserBadgePurchase {shown = True} -> SROCredited Nothing <$ withStore' (`settleStoreReceipt` receiptId)
+        Just p@UserBadgePurchase {purchaseKind = PKSubscription _}
+          | isNewest, Just purchasedAt <- resumableCharge now =<< decodeJSON payment -> resumeIssue ri delay user p purchasedAt now
+        _ -> refuse receiptInvalid
+    resumeIssue ri delay user p@UserBadgePurchase {badgePurchaseId} purchasedAt now = do
+      answer <- tryAllErrors $ requireBadgeService >>= \sendTarget -> sendBadgeIssue sendTarget userId p now
+      answeredAt <- badgeNow
+      -- a charge the service does not grant, as one of another tier, stops holding the profile once its hold ends
+      let notCredited holding
+            | resumeHoldEnded answeredAt purchasedAt = refuse receiptInvalid
+            | otherwise = holding
+      case answer of
+        Left e -> failed ri delay (badgeIssueFailure e) Nothing
+        Right (Left (code, retryAfter))
+          | storeReceiptRefused code -> refuse $ serviceFailure code retryAfter
+          | otherwise -> notCredited $ failed ri delay (serviceFailure code retryAfter) retryAfter
+        Right (Right (balance, stored)) ->
+          withStore' (`getLatestIssuedCredential` badgePurchaseId) >>= \case
+            Just cred@(BadgeCredential _ _ _ info)
+              | L.paidThrough balance > answeredAt && stored /= Just SSEnded -> do
+                  user' <- withStore $ \db -> do
+                    liftIO $ showResumedPurchase db user receiptId badgePurchaseId stored
+                    setUserBadge db user (Just $ OwnBadge cred (mkBadgeStatus answeredAt (Just True) info))
+                  lift $ startBadgeWork user'
+                  pure $ SROCredited (Just user')
+            -- the service's own check interval
+            _ -> notCredited $ failed ri delay BIFServiceError {code = BSEPaymentPending, retryable = True} (Just 3600)
+    receiptInvalid = BIFServiceError {code = BSEReceiptInvalid, retryable = False}
+    refuse failure = SRORefused failure <$ withStore' (\db -> refuseStoreReceipt db receiptId failure)
     serviceFailure code retryAfter = BIFServiceError {code = boundedServiceErrorCode code, retryable = isJust retryAfter}
     failed ri delay failure retryAfter = do
       now <- badgeNow

src/Simplex/Chat/PaymentService.hs

@@ -69,22 +69,24 @@ appleTransactionRef = applePayloadRef <=< applePayload
 data AppleTransactionFacts = AppleTransactionFacts
   { transactionId :: Text,
     purchaseDate :: Maybe Int64, -- epoch milliseconds
+    expiresDate :: Maybe Int64, -- epoch milliseconds
     revoked :: Bool,
     autoRenewable :: Bool
   }
   deriving (Eq, Show)
 
--- | A purchaseDate or type that does not read is taken as absent rather than failing the whole payload.
+-- | A date or type that does not read is taken as absent rather than failing the whole payload.
 appleTransactionFacts :: Text -> Maybe AppleTransactionFacts
 appleTransactionFacts = JT.parseMaybe facts <=< applePayload
   where
     facts o = do
       transactionId <- o J..: "transactionId"
       purchaseDate <- o J..:? "purchaseDate" <|> pure Nothing
+      expiresDate <- o J..:? "expiresDate" <|> pure Nothing
       -- as the service reads it: null is not revoked
       revoked <- isJust <$> (o J..:? "revocationDate" :: JT.Parser (Maybe J.Value))
       type_ <- o J..:? "type" <|> pure Nothing
-      pure AppleTransactionFacts {transactionId, purchaseDate, revoked, autoRenewable = type_ == Just ("Auto-Renewable Subscription" :: Text)}
+      pure AppleTransactionFacts {transactionId, purchaseDate, expiresDate, revoked, autoRenewable = type_ == Just ("Auto-Renewable Subscription" :: Text)}
 
 -- | A subscription is named by its original transaction id, which every renewal keeps, so all its
 -- charges claim one purchase; any other transaction by its own id.

src/Simplex/Chat/Store/Badges.hs

@@ -33,6 +33,9 @@ module Simplex.Chat.Store.Badges
     getNextHeldStoreReceipt,
     recordStoreReceiptFailure,
     refuseStoreReceipt,
+    settleStoreReceipt,
+    reholdStoreReceipt,
+    showResumedPurchase,
     deleteUnfundedStoreReceipts,
     deleteBadgeCodeRedemption,
     createStashBadgePurchase,
@@ -125,7 +128,7 @@ data BadgeReceiptRecord = BadgeReceiptRecord
 
 data BadgeReceiptStatus
   = RSHeld {stash :: BadgeStash, invoiceId :: Maybe Text, payment :: Text, nextAttemptAt :: UTCTime, retryDelay :: Maybe Int64}
-  | RSCredited {badgePurchaseId :: Int64}
+  | RSCredited {badgePurchaseId :: Int64, refusalRecorded :: Bool} -- a resume of it was refused
   | RSRefused {refusal :: Maybe BadgeIssueFailure}
 
 -- | Resolves a store transaction to the record that owns it, looking up by its reference again after each step
@@ -139,7 +142,8 @@ holdStoreReceipt :: DB.Connection -> TVar ChaChaDRG -> User -> StoreReceiptOrigi
 holdStoreReceipt db g User {userId} origin invoiceId_ txRef@StoreTransactionRef {provider, transactionRef} payment now =
   getReceiptRecord db txRef >>= \case
     Just r@BadgeReceiptRecord {receiptId, status} -> do
-      -- a resolved record stays resolved, so a hand-over landing just after its credit cannot hold it again
+      -- a resolved record stays resolved here, so a hand-over landing just after its credit cannot hold it again;
+      -- only a resume re-holds a credited one, which the hand-over decides
       case status of
         RSHeld {payment = held}
           | laterAppleTransaction payment held ->
@@ -212,7 +216,7 @@ getReceiptRecord db StoreTransactionRef {provider, transactionRef} =
       where
         status = case (payment_, nextAttemptAt_) of
           (Just payment, Just nextAttemptAt) -> RSHeld {stash = toBadgeStash BSRStoreReceipt (receiptId, purchaseKey, purchasePrivKey, mk), invoiceId, payment, nextAttemptAt, retryDelay}
-          _ -> maybe (RSRefused refusal) RSCredited purchaseId_
+          _ -> maybe (RSRefused refusal) (\badgePurchaseId -> RSCredited {badgePurchaseId, refusalRecorded = isJust refusal}) purchaseId_
 
 -- | The record made when Buy is tapped, before any receipt: the store echoes its invoice id.
 createBadgeStoreReceipt :: DB.Connection -> TVar ChaChaDRG -> User -> Text -> UTCTime -> IO ()
@@ -286,6 +290,39 @@ refuseStoreReceipt db receiptId refusal =
     "UPDATE badge_store_receipts SET payment = NULL, next_attempt_at = NULL, retry_delay = NULL, retry_count = 0, credit_error = ? WHERE badge_store_receipt_id = ?"
     (refusal, receiptId)
 
+-- | Every settle clears the failure, so one recorded on a credited record is a refused resume.
+settleStoreReceipt :: DB.Connection -> Int64 -> IO ()
+settleStoreReceipt db receiptId =
+  DB.execute
+    db
+    "UPDATE badge_store_receipts SET payment = NULL, next_attempt_at = NULL, retry_delay = NULL, retry_count = 0, credit_error = NULL WHERE badge_store_receipt_id = ?"
+    (Only receiptId)
+
+-- | Holds a credited record again for a later charge of its subscription while its purchase is its owner's newest,
+-- a subscription and not shown, and no other receipt of the owner is held: the receipt worker would credit that one
+-- first, and then skip this one while its badge is shown.
+reholdStoreReceipt :: DB.Connection -> User -> Int64 -> Int64 -> ServicePayment -> UTCTime -> IO Bool
+reholdStoreReceipt db owner receiptId badgePurchaseId payment now = do
+  newest_ <- getUserBadgePurchase db owner
+  pending <- getPendingStoreReceipts db owner
+  case newest_ of
+    Just UserBadgePurchase {badgePurchaseId = newestId, shown = False, purchaseKind = PKSubscription _}
+      | newestId == badgePurchaseId && null pending -> do
+          DB.execute
+            db
+            "UPDATE badge_store_receipts SET payment = ?, next_attempt_at = ?, retry_delay = NULL, retry_count = 0, credit_error = NULL WHERE badge_store_receipt_id = ? AND payment IS NULL"
+            (safeDecodeUtf8 . LB.toStrict $ J.encode payment, now, receiptId)
+          pure True
+    _ -> pure False
+
+-- | A resume's credit. The purchase keeps only the state the answer stored, so an ended state from before does not
+-- retire it again.
+showResumedPurchase :: DB.Connection -> User -> Int64 -> Int64 -> Maybe SubscriptionState -> IO ()
+showResumedPurchase db User {userId} receiptId badgePurchaseId state = do
+  settleStoreReceipt db receiptId
+  DB.execute db "UPDATE badge_purchases SET subscription_status = ? WHERE badge_purchase_id = ?" (state, badgePurchaseId)
+  DB.execute db "UPDATE users SET shown_badge_id = ? WHERE user_id = ?" (badgePurchaseId, userId)
+
 -- | A held record is paid for and a credited one is referenced by its purchase, so neither is deleted.
 deleteUnfundedStoreReceipts :: DB.Connection -> UTCTime -> IO ()
 deleteUnfundedStoreReceipts db createdBefore =
@@ -320,7 +357,7 @@ deleteBadgeCodeRedemption db User {userId} code =
 createStashBadgePurchase :: DB.Connection -> User -> BadgeStash -> BadgeCredential -> UTCTime -> IO (Int64, Bool)
 createStashBadgePurchase db User {userId} stash credential now = do
   -- the credit settles a held receipt in the transaction that stores its purchase, a replay included
-  forM_ storeReceiptId_ $ \storeReceiptId -> DB.execute db "UPDATE badge_store_receipts SET payment = NULL, next_attempt_at = NULL, retry_delay = NULL, retry_count = 0 WHERE badge_store_receipt_id = ?" (Only storeReceiptId)
+  forM_ storeReceiptId_ $ settleStoreReceipt db
   getStashBadgePurchase db stash >>= \case
     Just purchaseId -> pure (purchaseId, False)
     Nothing -> do

tests/BadgeTests.hs

@@ -119,7 +119,7 @@ badgeTests = do
   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
-    it "reads an Apple transaction's id, purchase date, revocation and type from its unverified payload" testAppleTransactionFacts
+    it "reads an Apple transaction's id, purchase and expiry dates, revocation and type from its unverified payload" testAppleTransactionFacts
     it "shows a service request in the terminal as its type alone" testShownServiceRequest
     it "refuses for good a Play product id that could name another purchase, before any verifier" testGoogleProductIdPath
     it "does not send a Play token that could name another purchase, and leaves it retryable" testGoogleTokenPath
@@ -1016,8 +1016,10 @@ testAppleTransactionFacts = do
   let jws fields = T.intercalate "." [part "{\"alg\":\"ES256\"}", part (safeDecodeUtf8 $ LB.toStrict $ J.encode $ J.object fields), "c2lnbmVk"]
       part = safeDecodeUtf8 . B64U.encodeUnpadded . encodeUtf8
       renewal = ["transactionId" J..= ("2000000900000002" :: T.Text), "type" J..= ("Auto-Renewable Subscription" :: T.Text)]
-      facts purchaseDate revoked autoRenewable = Just AppleTransactionFacts {transactionId = "2000000900000002", purchaseDate, revoked, autoRenewable}
+      facts purchaseDate revoked autoRenewable = Just AppleTransactionFacts {transactionId = "2000000900000002", purchaseDate, expiresDate = Nothing, revoked, autoRenewable}
   appleTransactionFacts (jws $ ("purchaseDate" J..= (1769904000000 :: Int)) : renewal) `shouldBe` facts (Just 1769904000000) False True
+  appleTransactionFacts (jws $ ("expiresDate" J..= (1772582400000 :: Int)) : renewal) `shouldBe` ((\f -> f {expiresDate = Just 1772582400000}) <$> facts Nothing False True)
+  appleTransactionFacts (jws $ ("expiresDate" J..= ("next month" :: T.Text)) : renewal) `shouldBe` facts Nothing False True
   -- the service reads a null revocationDate as not revoked, and so does the client
   appleTransactionFacts (jws $ ("revocationDate" J..= J.Null) : renewal) `shouldBe` facts Nothing False True
   appleTransactionFacts (jws $ ("revocationDate" J..= (1770000000000 :: Int)) : renewal) `shouldBe` facts Nothing True True

tests/Bots/BadgeService/BotTests.hs

@@ -54,6 +54,7 @@ import Data.Text (Text)
 import qualified Data.Text as T
 import Data.Time.Calendar (fromGregorian, toGregorian)
 import Data.Time.Clock (NominalDiffTime, UTCTime (..), addUTCTime, diffUTCTime, getCurrentTime, nominalDay)
+import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds)
 import Data.Time.Format (defaultTimeLocale, formatTime)
 import Data.Word (Word32)
 import Simplex.Chat.Badges (BadgeCredential (..), BadgeInfo (..), BadgeMasterKey, BadgeType (..), generateMasterKey)
@@ -64,7 +65,7 @@ import Simplex.Chat.Badges.Types (BadgeCodePaymentStatus (..))
 import Simplex.Chat.Bot.Store (withDB')
 import Simplex.Chat.Controller (ChatConfig (..), ChatController (..), ChatError (..), ChatErrorType (..), ChatResponse (CRCustomChatResponse))
 import Simplex.Chat.Core (sendChatCmdStr)
-import Simplex.Chat.Library.Commands (subscriptionRecoveryWindow)
+import Simplex.Chat.Library.Commands (resumeHoldLimit, subscriptionRecoveryWindow)
 import Simplex.Chat.Options (ChatOpts (..), CoreChatOpts (..))
 import Simplex.Chat.Options.DB
 import Simplex.Chat.PaymentService (ServicePayment (..), googlePurchaseRef)
@@ -232,6 +233,8 @@ badgeServiceTests = do
     it "should resolve an Apple renewal to the subscription's record, and credit a held record that adopted it once the subscription's hourly check allows" testAppleRenewalResolvesToPurchase
     it "should adopt into a held Apple record only another transaction bought later and not revoked" testAppleAdoptionRules
     it "should present an adopted Apple transaction at once though the attempt with the one before it failed, and credit it once the subscription's hourly check allows" testAdoptedReceiptNotOverwritten
+    it "should resume a retired Apple subscription on the same purchase when its store charges it again, retired past or within its coverage" testAppleResubscribeResumes
+    it "should answer an Apple resubscription from the record when it cannot resume, and refuse one the service does not grant once its hold ends" testAppleResubscribeBounded
     it "should ask the App Store about a subscription claim at most once an hour, whoever presents it and as any of its transactions" testApplePurchaseChecksBounded
     it "should ask Play about a subscription token at most once an hour, whoever presents it, credited to another key or not" testPlayPurchaseChecksBounded
     it "should keep at most the maximum of purchase checks, asking without recording once full, and drop expired ones" testPurchaseChecksBounded
@@ -3146,6 +3149,129 @@ testAppleRenewalResolvesToPurchase ps =
       rowCount cc "sx_badge_service_badge_purchases" `shouldReturn` 1
       map (\(_, ch, m, _, _, t) -> (ch, m, t)) <$> ledgerRows (chatController alice) "badge_ledger" `shouldReturn` [(1, 1, Just "charge"), (-1, 0, Just "badge")]
 
+testAppleResubscribeResumes :: HasCallStack => TestParams -> IO ()
+testAppleResubscribeResumes ps = do
+  -- retired past its coverage on the service's answer that it ended, then charged again for the same tier
+  withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClock, bsClientCfg, bsStore = store} ->
+    withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do
+      requestAt <- appleSubscriptionRetired env alice
+      -- past the hour in which the service answers from the check that found it ended
+      let resubscribedAt = addUTCTime 7200 requestAt
+      setClockAt bsClock resubscribedAt
+      appleStoreReports store $ subscriptionCheck SSRenewing $ Just (storeCharge "SUBSCR_BADGE_SUPPORTER_MONTH_01" resubscribedAt 1) {chargeRef = "apple.resubscribed"}
+      alice ##> ("/_badge purchase 1 " <> paymentArg SPApple {jws = appleResubscription "2000000812345690" resubscribedAt})
+      expectLinesWithin 30 alice ["1: supporter", openPurchase "", "1: supporter"] ["badge alert: subscription_ended ", "subscribed "]
+      waitShownBadge (chatController alice) (Just 1)
+      heldStoreReceipts (chatController alice) `shouldReturn` 0
+      storeReceiptCreditErrors (chatController alice) `shouldReturn` []
+      storeReceiptRows (chatController alice) `shouldReturn` [(1, Nothing, True)]
+      map (\(_, _, _, _, _, t) -> t) <$> ledgerRows (chatController alice) "badge_ledger" `shouldReturn` [Just "charge", Just "badge", Just "charge", Just "badge"]
+      [retiredExpiry, resumedExpiry] <- issuedExpiries (chatController alice)
+      resumedExpiry `shouldSatisfy` (> retiredExpiry)
+      subscriptionStatuses (chatController alice) `shouldReturn` [Just "renewing"]
+  -- retired within its coverage on an ended answer, as clocks that disagree give
+  withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClock, bsClientCfg, bsController = ChatController {chatStore}, bsStore = store@FakeStore {appleSubscriptionJWS}} ->
+    withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do
+      firstStart <- addUTCTime (-3600) <$> serviceNow env
+      appleStoreReports store $ subscriptionCheck SSRenewing $ Just $ storeCharge "SUBSCR_BADGE_SUPPORTER_YEAR_01" firstStart 12
+      alice ##> ("/_badge purchase 1 " <> paymentArg SPApple {jws = appleSubscriptionJWS})
+      inAnyOrder alice [[openPurchase ""], ["1: supporter"]]
+      waitWakeArmed (chatController alice)
+      rows <- ledgerRows (chatController alice) "badge_ledger"
+      withTransaction chatStore $ \db -> DB.execute_ db "UPDATE sx_badge_service_payments SET subscription_state = 'ended'"
+      setClockAt bsClock $ fst $ renewalMoments rows
+      alice `send` "/_app activate"
+      alice <### ["/_app activate", "ok", Predicate (\l -> "1: supporter" `isPrefixOf` l && ", subscription ended" `isInfixOf` l)]
+      waitShownBadge (chatController alice) Nothing
+      -- stands in for the service's check finding the new charge
+      withTransaction chatStore $ \db -> DB.execute_ db "UPDATE sx_badge_service_payments SET subscription_state = 'renewing'"
+      now <- serviceNow env
+      alice ##> ("/_badge purchase 1 " <> paymentArg SPApple {jws = appleResubscription "2000000812345691" now})
+      expectLinesWithin 30 alice ["1: supporter", openPurchase "", "1: supporter"] ["subscribed "]
+      waitShownBadge (chatController alice) (Just 1)
+      subscriptionStatuses (chatController alice) `shouldReturn` [Nothing]
+      alice ##> "/_app activate"
+      alice <## "ok"
+      threadDelay 2000000
+      shownBadgeId (chatController alice) `shouldReturn` Just 1
+
+testAppleResubscribeBounded :: HasCallStack => TestParams -> IO ()
+testAppleResubscribeBounded ps =
+  withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClock, bsClientCfg, bsStore = store} ->
+    withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do
+      requestAt <- appleSubscriptionRetired env alice
+      let handOver jws = alice ##> ("/_badge purchase 1 " <> paymentArg SPApple {jws})
+          answeredFromRecord jws = do
+            handOver jws
+            alice <## "badge already redeemed"
+            heldStoreReceipts (chatController alice) `shouldReturn` 0
+      -- a charge whose paid period has ended
+      answeredFromRecord $ appleTransactionDated "2000000812345692" (addUTCTime (-40 * nominalDay) requestAt) (addUTCTime (-10 * nominalDay) requestAt)
+      -- a charge of another tier, which the service does not grant, dated a minute ahead of the client's clock
+      let resubscribedAt = addUTCTime 7200 requestAt
+          otherTier = appleResubscription "2000000812345693" (addUTCTime 60 resubscribedAt)
+      setClockAt bsClock resubscribedAt
+      appleStoreReports store $ subscriptionCheck SSRenewing $ Just (storeCharge "SUBSCR_BADGE_LEGEND_MONTH_01" resubscribedAt 1) {chargeRef = "apple.legend"}
+      handOver otherTier
+      expectLinesWithin 30 alice ["1: supporter", "badge alert: subscription_ended ", openPurchase ""] ["subscribed "]
+      heldStoreReceiptErrors (chatController alice) `shouldEventuallyReturn` ["service_error retry payment_pending"]
+      setClockAt bsClock $ addUTCTime (resumeHoldLimit + 120) resubscribedAt
+      alice ##> "/_app activate"
+      alice <## "ok"
+      heldStoreReceipts (chatController alice) `shouldEventuallyReturn` 0
+      storeReceiptCreditErrors (chatController alice) `shouldReturn` ["service_error final receipt_invalid"]
+      shownBadgeId (chatController alice) `shouldReturn` Nothing
+      answeredFromRecord otherTier
+      invoiceId <- createInvoice alice 1
+      -- while another receipt of the owner is held
+      setGoogleDown store True
+      alice ##> purchaseWithInvoice 1 invoiceId supporterPlay
+      expectLinesWithin 30 alice ["1: supporter", "badge alert: subscription_ended ", invoicePurchase "" invoiceId] ["subscribed "]
+      now <- serviceNow env
+      handOver $ appleResubscription "2000000812345694" now
+      alice <## "badge already redeemed"
+      heldStoreReceipts (chatController alice) `shouldReturn` 1
+
+-- | A monthly Apple subscription bought an hour into its first period and retired past its coverage, at its request
+-- moment, on the service's answer that it ended: that moment.
+appleSubscriptionRetired :: HasCallStack => BadgeServiceEnv -> TestCC -> IO UTCTime
+appleSubscriptionRetired env@BadgeServiceEnv {bsClock, bsStore = store@FakeStore {appleSubscriptionJWS}} alice = do
+  firstStart <- addUTCTime (-3600) <$> serviceNow env
+  appleStoreReports store $ subscriptionCheck SSRenewing $ Just $ storeCharge "SUBSCR_BADGE_SUPPORTER_MONTH_01" firstStart 1
+  alice ##> ("/_badge purchase 1 " <> paymentArg SPApple {jws = appleSubscriptionJWS})
+  inAnyOrder alice [[openPurchase ""], ["1: supporter"]]
+  waitWakeArmed (chatController alice)
+  (requestAt, _) <- renewalMoments <$> ledgerRows (chatController alice) "badge_ledger"
+  appleStoreReports store $ subscriptionCheck SSEnded Nothing
+  setClockAt bsClock requestAt
+  alice `send` "/_app activate"
+  alice
+    <### [ "/_app activate",
+           "ok",
+           StartsWith "badge alert: subscription_ended ",
+           StartsWith "1: supporter",
+           StartsWith "badge alert: subscription_ended "
+         ]
+  waitShownBadge (chatController alice) Nothing
+  pure requestAt
+
+appleStoreReports :: FakeStore -> SubscriptionCheck -> IO ()
+appleStoreReports store = setSubscription store (SubscriptionApple appleSubscriptionOriginalId)
+
+-- | Another transaction of appleSubscriptionOriginalId's subscription, bought at the time given for a month.
+appleResubscription :: Text -> UTCTime -> Text
+appleResubscription txId bought = appleTransactionDated txId bought (addMonths 1 bought)
+
+appleTransactionDated :: Text -> UTCTime -> UTCTime -> Text
+appleTransactionDated txId bought expires =
+  subscriptionJWS appleSubscriptionOriginalId txId ["purchaseDate" J..= epochMs bought, "expiresDate" J..= epochMs expires]
+  where
+    epochMs t = round (utcTimeToPOSIXSeconds t * 1000) :: Int64
+
+storeReceiptCreditErrors :: ChatController -> IO [Text]
+storeReceiptCreditErrors ChatController {chatStore} =
+  withTransaction chatStore $ \db -> map fromOnly <$> DB.query_ db "SELECT credit_error FROM badge_store_receipts WHERE credit_error IS NOT NULL"
+
 testApplePurchaseChecksBounded :: HasCallStack => TestParams -> IO ()
 testApplePurchaseChecksBounded ps =
   withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClock, bsController = cc, bsStore = store@FakeStore {appleSubscriptionJWS, appleRenewalSubscriptionJWS, appleSecondSubscriptionJWS, appleThirdSubscriptionJWS}} -> do