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

Review round 1 fixes:
- R1-1: a resumable charge waiting behind another held receipt of the owner is answered held and left unfinished, rather than answered from the record and finished uncredited.
- R1-3: a resume shows the purchase again only with a credential that has not expired.
- R1-2, R1-8: tests of the resumable-charge rule and the hold's edge, of a held charge whose paid period ends before it is sent, and that a resumed profile shows the newest credential. The resume test is split in two, one environment each.
- R2-V1: a test comment that the reordered steps made false.

Run: 011-subscription-resume, review rounds 1 and 2

src/Simplex/Chat/Library/Commands.hs

@@ -5377,12 +5377,12 @@ handOverStoreReceipt presentingUser echoedInvoiceId origin payment = do
       case status of
         RSHeld {} -> lift (resumeStoreReceiptWork ownerId) >> badgeStateResponse owner
         RSCredited {badgePurchaseId, refusalRecorded} -> do
-          resumed <- case resumableCharge now payment of
+          answeredHeld <- 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
+          if answeredHeld
             then lift (resumeStoreReceiptWork ownerId) >> badgeStateResponse owner
             else do
               cred_ <- withStore' (`getLatestIssuedCredential` badgePurchaseId)
@@ -5732,7 +5732,7 @@ creditStoreReceipt a userId receiptId stash@BadgeStash {masterKey} invoiceId_ pa
         Right (Right (balance, stored)) ->
           withStore' (`getLatestIssuedCredential` badgePurchaseId) >>= \case
             Just cred@(BadgeCredential _ _ _ info)
-              | L.paidThrough balance > answeredAt && stored /= Just SSEnded -> do
+              | L.paidThrough balance > answeredAt && credentialExpiry cred > 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))

src/Simplex/Chat/Store/Badges.hs

@@ -50,7 +50,7 @@ module Simplex.Chat.Store.Badges
 where
 
 import Control.Concurrent.STM (TVar, atomically)
-import Control.Monad (forM, forM_, join)
+import Control.Monad (forM, forM_, join, when)
 import Crypto.Random (ChaChaDRG)
 import qualified Data.Aeson as J
 import Data.ByteString.Char8 (ByteString)
@@ -298,20 +298,22 @@ settleStoreReceipt db receiptId =
     "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.
+-- | Whether a later charge of a credited record's subscription is answered as held: its purchase must be its owner's
+-- newest, a subscription and not shown. The record is held again only while no other receipt of the owner is held,
+-- which the receipt worker would credit first and then skip this one while its badge is shown; until then the app
+-- keeps the charge unfinished and hands it over again.
 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)
+      | newestId == badgePurchaseId -> do
+          when (null pending) $
+            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
 

tests/BadgeTests.hs

@@ -39,7 +39,7 @@ import Simplex.Chat.Badges.Types (BadgeAlertKind (..), BadgeIssueError (..), Bad
 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, badgeRenewal, badgeRetryAfter, badgeServiceErrorText, badgeStalledInterval, boundedSubscriptionState, derivedBadgeAlert, storeTransactionRef)
+import Simplex.Chat.Library.Commands (badgeErrorRetry, badgeFailureTransient, badgeIssueFailure, badgeRenewal, badgeRetryAfter, badgeServiceErrorText, badgeStalledInterval, boundedSubscriptionState, derivedBadgeAlert, resumableCharge, resumeHoldEnded, storeTransactionRef)
 import Simplex.Chat.PaymentService (AppleTransactionFacts (..), ServicePayment (..), appleTransactionFacts, appleTransactionRef)
 import Simplex.Chat.PaymentService.Types (InvoiceId (..), PaymentProvider (..), StoreTransactionRef (..))
 import qualified Simplex.Chat.Store.Badges as SB
@@ -120,6 +120,7 @@ badgeTests = 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 and expiry dates, revocation and type from its unverified payload" testAppleTransactionFacts
+    it "resumes a retired subscription only with an Apple charge whose paid period runs, dated less than a day ahead" testResumableCharge
     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
@@ -1029,6 +1030,36 @@ testAppleTransactionFacts = do
   appleTransactionFacts (jws $ drop 1 renewal) `shouldBe` Nothing
   appleTransactionFacts "not.a-jws" `shouldBe` Nothing
 
+testResumableCharge :: IO ()
+testResumableCharge = do
+  let nowSeconds = 1770000000 :: Integer
+      now = posixSecondsToUTCTime $ fromInteger nowSeconds
+      secondsAhead s = addUTCTime (fromInteger s) now
+      epochMs s = (nowSeconds + s) * 1000
+      oneDay = 86400
+      oneMonth = 30 * oneDay
+      jws fields = T.intercalate "." [part "{\"alg\":\"ES256\"}", part (safeDecodeUtf8 $ LB.toStrict $ J.encode $ J.object fields), "c2lnbmVk"]
+      part = safeDecodeUtf8 . B64U.encodeUnpadded . encodeUtf8
+      ofType t fields = SPApple {jws = jws $ ["transactionId" J..= ("2000000900000002" :: T.Text), "type" J..= (t :: T.Text)] <> fields}
+      renewalWith = ofType "Auto-Renewable Subscription"
+      dated bought expires = renewalWith ["purchaseDate" J..= epochMs bought, "expiresDate" J..= epochMs expires]
+  resumableCharge now (dated 0 oneMonth) `shouldBe` Just now
+  resumableCharge now (dated 60 oneMonth) `shouldBe` Just (secondsAhead 60)
+  resumableCharge now (dated (oneDay - 1) oneMonth) `shouldBe` Just (secondsAhead (oneDay - 1))
+  -- dated as far ahead as the allowed skew or further, as a forged payload can be
+  resumableCharge now (dated oneDay oneMonth) `shouldBe` Nothing
+  resumableCharge now (dated (365 * oneDay) (400 * oneDay)) `shouldBe` Nothing
+  -- the paid period it bought has ended
+  resumableCharge now (dated (-oneMonth) 1) `shouldBe` Just (secondsAhead (-oneMonth))
+  resumableCharge now (dated (-oneMonth) 0) `shouldBe` Nothing
+  resumableCharge now (renewalWith ["purchaseDate" J..= epochMs 0, "expiresDate" J..= epochMs oneMonth, "revocationDate" J..= epochMs 0]) `shouldBe` Nothing
+  resumableCharge now (ofType "Non-Renewing Subscription" ["purchaseDate" J..= epochMs 0, "expiresDate" J..= epochMs oneMonth]) `shouldBe` Nothing
+  resumableCharge now (renewalWith ["expiresDate" J..= epochMs oneMonth]) `shouldBe` Nothing
+  resumableCharge now (renewalWith ["purchaseDate" J..= epochMs 0]) `shouldBe` Nothing
+  resumableCharge now SPGoogle {productId = "subscr_badge_supporter_01", token = "fake-play-token"} `shouldBe` Nothing
+  resumeHoldEnded (secondsAhead oneDay) now `shouldBe` True
+  resumeHoldEnded (secondsAhead (oneDay - 1)) now `shouldBe` False
+
 testShownServiceRequest :: IO ()
 testShownServiceRequest = do
   drg <- C.newRandom

tests/Bots/BadgeService/BotTests.hs

@@ -233,8 +233,9 @@ 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 resume a retired Apple subscription on the same purchase when its store charges it again" testAppleResubscribeResumes
+    it "should resume an Apple subscription retired within its coverage, with the state the service ended it with cleared" testAppleResubscribeResumesWithinCoverage
+    it "should answer an Apple resubscription from the record when it cannot resume, refuse a held one that stops being resumable or that the service does not grant within its hold, and keep one behind another held receipt unfinished" 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
@@ -3150,7 +3151,7 @@ testAppleRenewalResolvesToPurchase ps =
       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
+testAppleResubscribeResumes ps =
   -- 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
@@ -3168,7 +3169,11 @@ testAppleResubscribeResumes ps = do
       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)
+      waitShownIssued (chatController alice)
       subscriptionStatuses (chatController alice) `shouldReturn` [Just "renewing"]
+
+testAppleResubscribeResumesWithinCoverage :: HasCallStack => TestParams -> IO ()
+testAppleResubscribeResumesWithinCoverage ps =
   -- 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
@@ -3207,14 +3212,27 @@ testAppleResubscribeBounded ps =
             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
+      -- the store charges another tier, which the service does not grant
       let resubscribedAt = addUTCTime 7200 requestAt
-          otherTier = appleResubscription "2000000812345693" (addUTCTime 60 resubscribedAt)
+          handOverHeld jws = do
+            handOver jws
+            expectLinesWithin 30 alice ["1: supporter", "badge alert: subscription_ended ", openPurchase ""] ["subscribed "]
+            heldStoreReceiptErrors (chatController alice) `shouldEventuallyReturn` ["service_error retry payment_pending"]
       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"]
+      -- a charge whose paid period ends while it is held is refused before it is sent again
+      handOverHeld $ appleTransactionDated "2000000812345695" resubscribedAt (addUTCTime 7200 resubscribedAt)
+      checks <- subscriptionChecks store
+      setClockAt bsClock $ addUTCTime 10800 resubscribedAt
+      alice ##> "/_app activate"
+      alice <## "ok"
+      heldStoreReceipts (chatController alice) `shouldEventuallyReturn` 0
+      storeReceiptCreditErrors (chatController alice) `shouldReturn` ["service_error final receipt_invalid"]
+      subscriptionChecks store `shouldReturn` checks
+      shownBadgeId (chatController alice) `shouldReturn` Nothing
+      -- a later charge is held again though a resume was refused, while its own hold, from its purchase date, runs
+      let otherTier = appleResubscription "2000000812345693" (addUTCTime 60 resubscribedAt)
+      handOverHeld otherTier
       setClockAt bsClock $ addUTCTime (resumeHoldLimit + 120) resubscribedAt
       alice ##> "/_app activate"
       alice <## "ok"
@@ -3223,13 +3241,14 @@ testAppleResubscribeBounded ps =
       shownBadgeId (chatController alice) `shouldReturn` Nothing
       answeredFromRecord otherTier
       invoiceId <- createInvoice alice 1
-      -- while another receipt of the owner is held
+      -- while another receipt of the owner is held, a resubscription is answered held and left unfinished, not held here
       setGoogleDown store True
       alice ##> purchaseWithInvoice 1 invoiceId supporterPlay
-      expectLinesWithin 30 alice ["1: supporter", "badge alert: subscription_ended ", invoicePurchase "" invoiceId] ["subscribed "]
+      let heldLines = expectLinesWithin 30 alice ["1: supporter", "badge alert: subscription_ended ", invoicePurchase "" invoiceId] ["subscribed "]
+      heldLines
       now <- serviceNow env
       handOver $ appleResubscription "2000000812345694" now
-      alice <## "badge already redeemed"
+      heldLines
       heldStoreReceipts (chatController alice) `shouldReturn` 1
 
 -- | A monthly Apple subscription bought an hour into its first period and retired past its coverage, at its request