core: make the badge subscription tests fail on the defects they name (#7798)

tests/Bots/BadgeService/BotTests.hs

@@ -34,7 +34,7 @@ import ChatTests.Utils
 import Control.Concurrent (newEmptyMVar, putMVar, takeMVar, threadDelay)
 import Control.Concurrent.Async (async, cancel)
 import Control.Concurrent.STM (TQueue, atomically, readTMVar, readTQueue, readTVarIO)
-import Control.Monad (forM_, replicateM, void, when)
+import Control.Monad (forM, forM_, replicateM, void, when)
 import Control.Monad.Except (runExceptT)
 import Control.Exception (finally)
 import qualified Data.Aeson as J
@@ -206,12 +206,13 @@ badgeServiceTests = do
     describe "transfers" $ do
       it "should move a store subscription to a new key, ending the old key's share, and renew it for the new key" testStoreRebind
       it "should move a payment again only once the credential of the key it last moved from has expired" testStoreRebindCapped
-      it "should fund the new key from a charge the service never recorded, ending the idle old key at zero months" testStoreRebindNewCharge
+      it "should fund the new key from a charge the service never recorded, ending the idle old key at zero months, and grant that charge once" testStoreRebindNewCharge
       it "should answer the old key ended with no credential, without asking the store, and its purchase receipt_used" testStoreRebindOldKeyEnded
       it "should move an App Store subscription only with its latest transaction, writing nothing for an older one" testStoreRebindStaleAppleTransaction
       it "should credit a transfer of a payment credited nowhere as a first purchase" testTransferUncredited
       it "should answer a repeated transfer from the record, without asking the store or limiting it" testTransferReplayAnswered
       it "should refuse a transfer to a key that holds a purchase, without asking the store" testTransferKnownKeyRefused
+      it "should answer a transfer of a one-time purchase credited to another key receipt_used, moving nothing" testTransferOneTimeRefused
     describe "restore" $ do
       it "should move a subscription to another device on Restore, retire it on the old one, and credit one credited nowhere" testRestoreOnNewDevice
       it "should move a subscription to another profile on Restore, and refuse a move on before the first key's credential expires, once" testRestoreOnOtherProfile
@@ -288,8 +289,7 @@ badgeServiceTests = do
     it "should allow the purchase path at most the maximum of Play reads in a minute, counted from its first read" testPlayReadsBounded
     it "should answer a Play subscription rate_limited without asking Play once the minute's reads are used, and not hold it off" testPlayPurchaseReadsLimited
     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
-    it "should answer an App Store subscription provider_not_configured every time when only Play's subscriptions are checked" testAppleSubscriptionWithPlayChecker
+    it "should answer an App Store subscription provider_not_configured every time without an API key, and credit a one-time purchase" testAppleSubscriptionWithoutApiKey
     it "should acknowledge a Play subscription as a subscription before crediting it, and credit nothing when acknowledging fails" testPlaySubscriptionAcknowledgedBeforeCrediting
     it "should credit a Play subscription Play reports, beside a one-time purchase, and answer provider_not_configured without [google]" testPlaySubscriptionThroughPlay
     it "should have the dev mock credit and renew the plan a subscription names, end one it does not know, and still vouch for a one-time purchase" testMockSubscriptions
@@ -2323,7 +2323,7 @@ testSubscriptionChargeNotGranted ps =
         checkedAt i = addUTCTime (3 * nominalDay + fromIntegral (i :: Int) * 3700) (addMonths 1 firstStart)
         notGranted =
           [ (monthlyCharge monthly firstStart 1) {revoked = True},
-            (monthlyCharge monthly firstStart 3) {offer = True},
+            (monthlyCharge monthly firstStart 1) {offer = True, chargeRef = "GPA.offer"},
             (monthlyCharge monthly firstStart 4) {periodStart = addUTCTime nominalDay (checkedAt 3), periodEnd = addMonths 1 (addUTCTime nominalDay (checkedAt 3))},
             (monthlyCharge monthly firstStart 5) {periodStart = firstStart, periodEnd = addMonths 1 firstStart},
             -- an unsold Play plan, given an empty period
@@ -2815,8 +2815,9 @@ testStoreRebindNewCharge ps =
         verifiedAfter tip_ rows = do
           now <- serviceNow env
           map snd (balanceChecked now BTSupporter tip_ rows) `shouldBe` map (const $ Just True) rows
-    -- the old key went idle after its first month, and the store has since charged a month the service never recorded
-    storeReports store $ subscriptionCheck SSRenewing $ Just $ monthlyCharge "subscr-badge-supporter-month-02" firstStart 2
+    -- the old key went idle after its first month, and the store has since charged a month the service never recorded;
+    -- its period runs past the month the move funds, so the charge is still current once that month is spent
+    storeReports store $ subscriptionCheck SSRenewing $ Just (monthlyCharge "subscr-badge-supporter-month-02" firstStart 2) {periodEnd = addUTCTime (10 * nominalDay) (addMonths 1 chargeStart)}
     setClockAt bsClock $ addUTCTime (3 * nominalDay) chargeStart
     (newKey, moved) <- transferWithNewKey env subscriptionPlay
     let movedRows = fst $ statementOf moved
@@ -2833,6 +2834,14 @@ testStoreRebindNewCharge ps =
     map entryTag (fst $ statementOf again) `shouldBe` []
     credentialOf again `shouldBe` credentialOf moved
     ledgerRows cc "sx_badge_service_badge_ledger" `shouldReturn` ledger
+    -- the store still reports that charge once the month it funded has run out, and it is not granted again
+    checks <- subscriptionChecks store
+    setClockAt bsClock $ addUTCTime (3 * nominalDay) (addMonths 1 chargeStart)
+    reported <- assertBalance env newKey (last movedRows)
+    subscriptionChecks store `shouldReturn` checks + 1
+    map entryTag (fst $ statementOf reported) `shouldBe` []
+    credentialOf reported `shouldBe` Nothing
+    ledgerRows cc "sx_badge_service_badge_ledger" `shouldReturn` ledger
 
 testStoreRebindCapped :: HasCallStack => TestParams -> IO ()
 testStoreRebindCapped ps =
@@ -2933,6 +2942,25 @@ testTransferKnownKeyRefused ps =
     rowCount cc "sx_badge_service_badge_purchases" `shouldReturn` 2
     reboundPayments cc `shouldReturn` 0
 
+-- | Restore presents every transaction it finds as a transfer, a one-time purchase bought on another device included.
+testTransferOneTimeRefused :: HasCallStack => TestParams -> IO ()
+testTransferOneTimeRefused ps =
+  withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsController = cc, bsStore = store@FakeStore {appleSupporterJWS}} -> do
+    let oneTime = [supporterPlay, SPApple {jws = appleSupporterJWS}]
+    owned <- forM oneTime $ \payment -> do
+      (ownerKey, ownerMasterKey) <- newPurchaseKeys
+      purchased <- serviceCmd env ownerKey $ purchaseCmd ownerMasterKey payment
+      pure (ownerKey, ownerMasterKey, payment, purchased)
+    checks <- subscriptionChecks store
+    ledger <- ledgerRows cc "sx_badge_service_badge_ledger"
+    forM_ oneTime $ \payment -> refusalOf . snd <$> transferWithNewKey env payment `shouldReturn` (BSEReceiptUsed, Nothing)
+    subscriptionChecks store `shouldReturn` checks
+    ledgerRows cc "sx_badge_service_badge_ledger" `shouldReturn` ledger
+    rowCount cc "sx_badge_service_badge_purchases" `shouldReturn` 2
+    reboundPayments cc `shouldReturn` 0
+    forM_ owned $ \(ownerKey, ownerMasterKey, payment, purchased) ->
+      credentialOf <$> serviceCmd env ownerKey (purchaseCmd ownerMasterKey payment) `shouldReturn` credentialOf purchased
+
 restoredCmd :: Int64 -> ServicePayment -> String
 restoredCmd userId payment = "/_badge purchase " <> show userId <> " restored " <> paymentArg payment
 
@@ -4632,18 +4660,7 @@ testAppleSandboxSubscriptionNotAsked ps = do
       nothingPurchased cc
 
 testAppleSubscriptionWithoutApiKey :: HasCallStack => TestParams -> IO ()
-testAppleSubscriptionWithoutApiKey = appleSubscriptionNotConfigured id
-
--- | [google] beside an [apple] with no API key: configureStoreVerifier builds a checker that answers App Store refs not configured.
-testAppleSubscriptionWithPlayChecker :: HasCallStack => TestParams -> IO ()
-testAppleSubscriptionWithPlayChecker = appleSubscriptionNotConfigured $ \v -> v {checkSubscription = Just playOnly}
-  where
-    playOnly ref _ = case ref of
-      SubscriptionApple _ -> pure $ Left SRNotConfigured
-      SubscriptionGoogle _ -> pure $ Left $ SRUnreachable "no Play in this test"
-
-appleSubscriptionNotConfigured :: HasCallStack => (StoreVerifier -> StoreVerifier) -> TestParams -> IO ()
-appleSubscriptionNotConfigured withChecker ps = do
+testAppleSubscriptionWithoutApiKey ps = do
   chain <- trustedChain
   createDirectoryIfMissing True "tests/tmp"
   withTempDirectory "tests/tmp" "apple-no-api-key" $ \d -> do
@@ -4652,7 +4669,7 @@ appleSubscriptionNotConfigured withChecker ps = do
     Right cfg <- readServiceConfig (d </> "badge_service.ini")
     let apple = AppleStoreConfig {aBundleId = ourBundleId, aRootCertificates = (d </> "root.cer") :| [], aServerApi = Nothing}
     ServiceState {storeVerifier} <- newServiceState >>= configureStoreVerifier (Just cfg {appleStore = Just apple})
-    withBadgeServiceVerifier ps (const $ withChecker storeVerifier) $ \env@BadgeServiceEnv {bsController = cc} -> do
+    withBadgeServiceVerifier ps (const storeVerifier) $ \env@BadgeServiceEnv {bsController = cc} -> do
       (purchaseKey, masterKey) <- newPurchaseKeys
       subscription <- signedBy chain $ subscriptionPayload [] []
       let presentSubscription = refusalOf <$> serviceCmd env purchaseKey (purchaseCmd masterKey SPApple {jws = subscription})
@@ -4817,7 +4834,9 @@ testStoreChecksDuringCoverageGrantedOnce ps =
   withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsController = cc, bsStore = store} -> do
     (purchaseKey, _, purchased) <- subscribedMonthly env
     ledger <- ledgerRows cc "sx_badge_service_badge_ledger"
+    checks <- subscriptionChecks store
     answered <- serviceCmd env {bsVerifier = (fakeVerifier store) {storeChecks = ChecksAtEveryRequest}} purchaseKey BSCIssueBadge {balance = BadgeBalance {lastEntry = last purchased}}
+    subscriptionChecks store `shouldReturn` checks + 1
     map entryTag (fst $ statementOf answered) `shouldBe` []
     ledgerRows cc "sx_badge_service_badge_ledger" `shouldReturn` ledger
     rowCount cc "sx_badge_service_subscription_charges" `shouldReturn` 1

tests/Bots/BadgeService/StoreVerifierTests.hs

@@ -82,6 +82,7 @@ badgeStoreVerifierTests = describe "badge store verifiers" $ do
     it "has nothing to acknowledge" testAppleNoAcknowledgement
   describe "App Store subscriptions" $ do
     it "maps each status, renewing or cancelled by autoRenewStatus, and the charge to the latest transaction, with one token reused" testAppleSubscriptionStatuses
+    it "reads the subscription asked about from an answer that lists another one first" testAppleSubscriptionAmongOthers
     it "reports a revoked charge and one in an offer, refuses a family-shared one, and names a Sandbox one a test purchase" testAppleSubscriptionCharges
     it "fails, rather than refuses, a status Apple did not sign or that was changed after signing" testAppleSubscriptionUnsigned
     it "fails on a verifier that cannot place what the store signed, and is unreachable on any other throw" testSubscriptionCheckThrows
@@ -466,19 +467,26 @@ renewalPayload overrides =
 
 -- | Get All Subscription Statuses as Apple answers it, with the subscription's latest transaction.
 statusBody :: Int -> Text -> Text -> J.Value
-statusBody status signedTx signedRenewal =
+statusBody status signedTx signedRenewal = statusListing [lastTransaction subscriptionId status signedTx signedRenewal]
+
+-- | Get All Subscription Statuses listing these subscriptions, all in one subscription group.
+statusListing :: [J.Value] -> J.Value
+statusListing lastTransactions =
   J.object
     [ "environment" J..= ("Production" :: Text),
       "bundleId" J..= ourBundleId,
       "data"
         J..= [ J.object
                  [ "subscriptionGroupIdentifier" J..= ("21000000" :: Text),
-                   "lastTransactions"
-                     J..= [J.object ["originalTransactionId" J..= subscriptionId, "status" J..= status, "signedTransactionInfo" J..= signedTx, "signedRenewalInfo" J..= signedRenewal]]
+                   "lastTransactions" J..= lastTransactions
                  ]
              ]
     ]
 
+lastTransaction :: Text -> Int -> Text -> Text -> J.Value
+lastTransaction originalId status signedTx signedRenewal =
+  J.object ["originalTransactionId" J..= originalId, "status" J..= status, "signedTransactionInfo" J..= signedTx, "signedRenewalInfo" J..= signedRenewal]
+
 -- | The check the service runs, through the same runner as a purchase and a renewal.
 withAppleChecker :: TestChain -> (FakeAppStore -> (Text -> IO (Either StoreRefusal SubscriptionCheck)) -> IO a) -> IO a
 withAppleChecker chain action = withFakeAppStore ourBundleId $ \fake -> do
@@ -532,6 +540,19 @@ testAppleSubscriptionStatuses = do
   where
     millis ms = posixSecondsToUTCTime $ fromIntegral ms / 1000
 
+-- | Apple lists every subscription the customer holds in the app, a family member's shared one included.
+testAppleSubscriptionAmongOthers :: IO ()
+testAppleSubscriptionAmongOthers = do
+  chain <- trustedChain
+  withAppleChecker chain $ \fake check -> do
+    let sharedId = "2000000900000011"
+    sharedTx <- signedBy chain $ subscriptionPayload [("originalTransactionId", J.String sharedId), ("transactionId", "2000000900000012"), ("inAppOwnershipType", "FAMILY_SHARED")] []
+    sharedRenewal <- signedBy chain $ renewalPayload [("originalTransactionId", J.String sharedId)]
+    ownTx <- signedBy chain $ subscriptionPayload [] []
+    ownRenewal <- signedBy chain $ renewalPayload []
+    answerStatus fake subscriptionId $ AppStoreBody $ statusListing [lastTransaction sharedId 1 sharedTx sharedRenewal, lastTransaction subscriptionId 1 ownTx ownRenewal]
+    stateOf <$> check subscriptionId `shouldReturn` Right SSRenewing
+
 testAppleSubscriptionCharges :: IO ()
 testAppleSubscriptionCharges = do
   chain <- trustedChain