diff --git a/src/Simplex/Chat/Library/Commands.hs b/src/Simplex/Chat/Library/Commands.hs index 8e3ba3dd26..4041ab5fbb 100644 --- a/src/Simplex/Chat/Library/Commands.hs +++ b/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 diff --git a/src/Simplex/Chat/PaymentService.hs b/src/Simplex/Chat/PaymentService.hs index d66c71cb98..22185e0686 100644 --- a/src/Simplex/Chat/PaymentService.hs +++ b/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. diff --git a/src/Simplex/Chat/Store/Badges.hs b/src/Simplex/Chat/Store/Badges.hs index b6ec08c233..a68649ed24 100644 --- a/src/Simplex/Chat/Store/Badges.hs +++ b/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 diff --git a/tests/BadgeTests.hs b/tests/BadgeTests.hs index aee5f41881..13f7aff106 100644 --- a/tests/BadgeTests.hs +++ b/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 diff --git a/tests/Bots/BadgeService/BotTests.hs b/tests/Bots/BadgeService/BotTests.hs index fd0d7930b2..edaa0e2db7 100644 --- a/tests/Bots/BadgeService/BotTests.hs +++ b/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