diff --git a/tests/Bots/BadgeService/BotTests.hs b/tests/Bots/BadgeService/BotTests.hs index 4b6e2431be..5af7a74f27 100644 --- a/tests/Bots/BadgeService/BotTests.hs +++ b/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 diff --git a/tests/Bots/BadgeService/StoreVerifierTests.hs b/tests/Bots/BadgeService/StoreVerifierTests.hs index 2bee2b0951..737a1fcc8b 100644 --- a/tests/Bots/BadgeService/StoreVerifierTests.hs +++ b/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