diff --git a/src/Simplex/Chat/Badges/Ledger.hs b/src/Simplex/Chat/Badges/Ledger.hs index 3378c6a8fb..d7f939058f 100644 --- a/src/Simplex/Chat/Badges/Ledger.hs +++ b/src/Simplex/Chat/Badges/Ledger.hs @@ -98,12 +98,13 @@ lapseEntry t entryId e@StatementEntry {balanceMonths} -- replace the balance, so they are granted only onto an empty one. grantEntry :: UTCTime -> Text -> BadgeType -> Int -> StatementCreditType -> StatementEntry -> StatementEntry grantEntry t entryId badgeType n credit e@StatementEntry {balanceMonths, balanceStartTs, balanceBadgeType} - -- only a lapsed run, or one of another tier, restarts; topping up before coverage ends continues the + -- only a lapsed run, or one of another tier before coverage ends, restarts; topping up before coverage ends continues the -- run on its anchor, so buying a month at a time keeps the same day of month as buying a year at once - | lapsed || badgeType /= balanceBadgeType = credited {balanceMonths = n, balanceStartTs = t, balanceAnchorTs = t} + | lapsed || (badgeType /= balanceBadgeType && not atCoverageEnd) = credited {balanceMonths = n, balanceStartTs = t, balanceAnchorTs = t} | otherwise = credited {balanceMonths = balanceMonths + n} where lapsed = balanceMonths == 0 && t > balanceStartTs + atCoverageEnd = balanceMonths == 0 && t == balanceStartTs credited = e {entryId, createdAt = t, changeMonths = n, balanceBadgeType = badgeType, entryType = SECredit credit} -- | The period issued runs from the previous entry's balanceStartTs to this one's. diff --git a/tests/BadgeTests.hs b/tests/BadgeTests.hs index dd652372e1..c102cc6268 100644 --- a/tests/BadgeTests.hs +++ b/tests/BadgeTests.hs @@ -98,6 +98,8 @@ badgeTests = do it "accepts every row a store charge adds, on each path a subscription renews by" testChargeRowsVerify it "re-runs an upgrade or a transfer debit, and rejects one that leaves months" testDebitRowsVerify it "accepts every row a change of tier adds, and rejects a new tier granted over months still held" testTierChangeRowsVerify + it "keeps the renewal day of a run whose tier changes at renewal" testTierChangeAtRenewalKeepsDay + it "restarts the run of a tier changed before its coverage ends" testTierChangeInCoverageRestarts describe "worker retry" $ do it "repeats a failure that can clear on its own, and no other" testRetryClassification it "backs off to the cap" testRetryBackoff @@ -812,7 +814,7 @@ testDebitRowsVerify = do verdicts t (Just issued) [upgraded {changeMonths = -10, balanceMonths = 1}] `shouldBe` [Just False] -- A charge of another tier ends the old run with an upgrade debit of what it still held and starts --- a new one: every row it writes must re-run on the client, on each path a tier changes by. +-- a new one, or continues it at renewal: every row it writes must re-run on the client, on each path a tier changes by. testTierChangeRowsVerify :: IO () testTierChangeRowsVerify = do k <- newPurchaseKey @@ -824,7 +826,7 @@ testTierChangeRowsVerify = do downgraded = charged k p1 (days 2 p1) BTSupporter 1 legendTip map rowKind downgraded `shouldBe` ["charge", "badge"] map bTier downgraded `shouldBe` [BTSupporter, BTSupporter] - map bAnchor (take 1 downgraded) `shouldBe` [p1] + map bAnchor (take 1 downgraded) `shouldBe` [p0] verdicts (days 2 p1) (Just legendTip) downgraded `shouldBe` [Just True, Just True] -- an annual Supporter subscription upgraded to annual Legend in its third month, every month so -- far issued: the nine left are debited, and the new year starts at the upgrade @@ -870,6 +872,33 @@ testTierChangeRowsVerify = do map rowKind renewed `shouldBe` ["charge", "badge"] allVerify (annual <> yearIssued <> found <> legendIssued <> renewed) +monthlySupporterFrom31Jan :: C.PublicKeyEd25519 -> [StatementEntry] +monthlySupporterFrom31Jan k = charged k p0 (addUTCTime 600 p0) BTSupporter 1 (newBalance p0) + where + p0 = at 2027 1 31 + +testTierChangeAtRenewalKeepsDay :: IO () +testTierChangeAtRenewalKeepsDay = do + k <- newPurchaseKey + let supporter = monthlySupporterFrom31Jan k + supporterTip = last supporter + renewal = at 2027 2 28 + legend = charged k renewal (addUTCTime 600 renewal) BTLegend 1 supporterTip + bStart supporterTip `shouldBe` renewal + map rowKind legend `shouldBe` ["charge", "badge"] + map (\e -> (bStart e, bAnchor e, bTier e)) legend `shouldBe` [(renewal, at 2027 1 31, BTLegend), (at 2027 3 31, at 2027 1 31, BTLegend)] + allVerify (supporter <> legend) + +testTierChangeInCoverageRestarts :: IO () +testTierChangeInCoverageRestarts = do + k <- newPurchaseKey + let supporter = monthlySupporterFrom31Jan k + upgradedAt = at 2027 2 10 + legend = charged k upgradedAt (addUTCTime 600 upgradedAt) BTLegend 1 (last supporter) + map rowKind legend `shouldBe` ["charge", "badge"] + map (\e -> (bStart e, bAnchor e, bTier e)) legend `shouldBe` [(upgradedAt, upgradedAt, BTLegend), (at 2027 3 10, upgradedAt, BTLegend)] + allVerify (supporter <> legend) + -- A failed renewal is otherwise left until the next chat start or activate, which on a desktop -- left running can be days - long enough for a funded badge to lapse. testRetryClassification :: IO () diff --git a/tests/Bots/BadgeService/BotTests.hs b/tests/Bots/BadgeService/BotTests.hs index a3602cbc03..dc1d264545 100644 --- a/tests/Bots/BadgeService/BotTests.hs +++ b/tests/Bots/BadgeService/BotTests.hs @@ -2266,15 +2266,22 @@ subscribedMonthly env = subscribedTo env "subscr-badge-supporter-month-02" 1 -- | The same for the Play plan given, of that many months. subscribedTo :: HasCallStack => BadgeServiceEnv -> Text -> Integer -> IO (C.PublicKeyEd25519, UTCTime, [StatementEntry]) subscribedTo env@BadgeServiceEnv {bsStore} planId months = do - firstStart <- addUTCTime (-3600) <$> serviceNow env + firstStart <- monthEndStart env setSubscription bsStore (SubscriptionGoogle googleSubscriptionToken) $ subscriptionCheck SSRenewing $ Just $ storeCharge planId firstStart months (purchaseKey, masterKey) <- newPurchaseKeys purchased <- serviceCmd env purchaseKey $ purchaseCmd masterKey subscriptionPlay pure (purchaseKey, firstStart, fst $ statementOf purchased) +monthEndStart :: BadgeServiceEnv -> IO UTCTime +monthEndStart env@BadgeServiceEnv {bsClock} = do + (year, _, _) <- toGregorian . utctDay <$> serviceNow env + let start = UTCTime (fromGregorian (year + 1) 1 31) 36000 + setClockAt bsClock $ addUTCTime 3600 start + pure start + -- | The store's charge n months after the first, for the plan given. monthlyCharge :: Text -> UTCTime -> Integer -> StoreCharge -monthlyCharge planId firstStart n = (storeCharge planId (addMonths n firstStart) 1) {chargeRef = "GPA.renewal." <> tshow n} +monthlyCharge planId firstStart n = (storeCharge planId (addMonths n firstStart) 1) {chargeRef = "GPA.renewal." <> tshow n, periodEnd = addMonths (n + 1) firstStart} storeReports :: FakeStore -> SubscriptionCheck -> IO () storeReports store = setSubscription store (SubscriptionGoogle googleSubscriptionToken) @@ -2500,7 +2507,7 @@ testAppleSubscriptionRenews ps = -- | The client buys a monthly Play subscription an hour into its first period: that period's start, and its ledger then. clientSubscribedMonthly :: HasCallStack => BadgeServiceEnv -> TestCC -> IO (UTCTime, [ReplicatedRow]) clientSubscribedMonthly env@BadgeServiceEnv {bsStore} alice = do - firstStart <- addUTCTime (-3600) <$> serviceNow env + firstStart <- monthEndStart env storeReports bsStore $ subscriptionCheck SSRenewing $ Just $ storeCharge "subscr-badge-supporter-month-02" firstStart 1 alice ##> ("/_badge purchase 1 " <> paymentArg subscriptionPlay) inAnyOrder alice [[openPurchase ""], ["1: supporter"]] @@ -2541,7 +2548,7 @@ testSubscriptionRenews ps = alice <## "ok" renewed <- waitLedgerRows (chatController alice) 4 alice <##. "1: supporter" - drop 2 (rowChanges renewed) `shouldBe` [(1, 1, renewalStart, Just "charge"), (-1, 0, addMonths 1 renewalStart, Just "badge")] + drop 2 (rowChanges renewed) `shouldBe` [(1, 1, renewalStart, Just "charge"), (-1, 0, addMonths 2 firstStart, Just "badge")] balanceChecks (chatController alice) `shouldReturn` replicate 4 (Just True) issueErrorRow (chatController alice) `shouldReturn` (Nothing, Nothing) shownBadgeId (chatController alice) >>= (`shouldSatisfy` isJust) @@ -2556,8 +2563,8 @@ testSubscriptionTierChangeAtRenewal :: HasCallStack => TestParams -> IO () testSubscriptionTierChangeAtRenewal ps = withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClock, bsClientCfg, bsController = cc, bsStore = store@FakeStore {appleSubscriptionJWS}} -> do withNewTestChatCfg ps bsClientCfg "alice" aliceProfile $ \alice -> do - firstStart <- addUTCTime (-3600) <$> serviceNow env - let monthly plan n = (storeCharge plan (addMonths n firstStart) 1) {chargeRef = "apple.renewal." <> tshow n} + firstStart <- monthEndStart env + let monthly plan n = (monthlyCharge plan firstStart n) {chargeRef = "apple.renewal." <> tshow n} tiersOf = map (\(_, ch, m, start, tier, t) -> (ch, m, start, tier, t)) renewAs plan n = do rows <- ledgerRows (chatController alice) "badge_ledger" @@ -2572,11 +2579,10 @@ testSubscriptionTierChangeAtRenewal ps = alice ##> ("/_badge purchase 1 " <> paymentArg SPApple {jws = appleSubscriptionJWS}) inAnyOrder alice [[openPurchase ""], ["1: supporter"]] waitWakeArmed (chatController alice) - -- the store charges Legend at the renewal: a new run from its period start, on both sides + -- the store charges Legend at the renewal: the run continues on its renewal day, on both sides upgraded <- renewAs "SUBSCR_BADGE_LEGEND_MONTH_01" 1 alice <##. "1: legend" - let legendStart = addMonths 1 firstStart - tiersOf upgraded `shouldBe` [(1, 1, legendStart, "legend", Just "charge"), (-1, 0, addMonths 1 legendStart, "legend", Just "badge")] + tiersOf upgraded `shouldBe` [(1, 1, addMonths 1 firstStart, "legend", Just "charge"), (-1, 0, addMonths 2 firstStart, "legend", Just "badge")] balanceChecks (chatController alice) `shouldReturn` replicate 4 (Just True) purchaseBadgeTypes (chatController alice) "badge_purchases" `shouldReturn` ["legend"] purchaseBadgeTypes cc "sx_badge_service_badge_purchases" `shouldReturn` ["legend"] @@ -2710,7 +2716,7 @@ testSubscriptionUpgradeLateInMonth ps = testUpgradeCheckGrantsRenewal :: HasCallStack => TestParams -> IO () testUpgradeCheckGrantsRenewal ps = withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClock, bsController = cc, bsStore = store@FakeStore {appleSubscriptionJWS, appleLegendSubscriptionJWS}} -> do - firstStart <- addUTCTime (-3600) <$> serviceNow env + firstStart <- monthEndStart env appleStoreReports store $ subscriptionCheck SSRenewing $ Just $ storeCharge "SUBSCR_BADGE_SUPPORTER_MONTH_01" firstStart 1 (purchaseKey, masterKey) <- newPurchaseKeys purchased <- serviceCmd env purchaseKey $ purchaseCmd masterKey SPApple {jws = appleSubscriptionJWS} @@ -2718,7 +2724,7 @@ testUpgradeCheckGrantsRenewal ps = renewalStart = addMonths 1 firstStart upgradedAt = addUTCTime 600 renewalStart -- coverage has ended and Apple charged the Supporter renewal, while its status still shows Supporter - appleStoreReports store $ subscriptionCheck SSRenewing $ Just (storeCharge "SUBSCR_BADGE_SUPPORTER_MONTH_01" renewalStart 1) {chargeRef = "apple.renewal"} + appleStoreReports store $ subscriptionCheck SSRenewing $ Just (monthlyCharge "SUBSCR_BADGE_SUPPORTER_MONTH_01" firstStart 1) {chargeRef = "apple.renewal"} setClockAt bsClock upgradedAt checks <- subscriptionChecks store refusalOf <$> serviceCmd env purchaseKey (upgradeCmdWith appleLegendSubscriptionJWS tip) `shouldReturn` (BSEPaymentPending, Just 3600) @@ -3497,7 +3503,7 @@ testStoreUnreachableWaitsStall ps = alice <## "ok" renewed <- waitLedgerRows (chatController alice) 4 alice <##. "1: supporter" - drop 2 (rowChanges renewed) `shouldBe` [(1, 1, renewalStart, Just "charge"), (-1, 0, addMonths 1 renewalStart, Just "badge")] + drop 2 (rowChanges renewed) `shouldBe` [(1, 1, renewalStart, Just "charge"), (-1, 0, addMonths 2 firstStart, Just "badge")] waitShownIssued (chatController alice) waitIssueErrorCleared (chatController alice) @@ -3719,7 +3725,7 @@ testIdleSubscriptionKeptPastWindow ps = alice <## "ok" renewed <- waitLedgerRows (chatController alice) 4 alice <##. "1: supporter" - drop 2 (rowChanges renewed) `shouldBe` [(1, 1, addMonths 3 firstStart, Just "charge"), (-1, 0, addMonths 4 firstStart, Just "badge")] + drop 2 (rowChanges renewed) `shouldBe` [(1, 1, addMonths 3 firstStart, Just "charge"), (-1, 0, addMonths 1 (addMonths 3 firstStart), Just "badge")] waitShownIssued (chatController alice) shownBadgeId (chatController alice) >>= (`shouldSatisfy` isJust) unrenewedRuns (chatController alice) `shouldReturn` [(Nothing, Nothing)] @@ -4922,7 +4928,7 @@ testAppleTierChangeLowerWaitsForRenewal ps = renewed <- waitLedgerRows a (length rows + 2) alice <##. "1: supporter" map (\(_, ch, m, start, tier, t) -> (ch, m, start, tier, t)) (drop (length rows) renewed) - `shouldBe` [(1, 1, supporterStart, "supporter", Just "charge"), (-1, 0, addMonths 1 supporterStart, "supporter", Just "badge")] + `shouldBe` [(1, 1, supporterStart, "supporter", Just "charge"), (-1, 0, addMonths 2 legendBoughtAt, "supporter", Just "badge")] purchaseBadgeTypes a "badge_purchases" `shouldReturn` ["supporter"] purchaseBadgeTypes cc "sx_badge_service_badge_purchases" `shouldReturn` ["supporter"] issuedBadgeTypes a `shouldReturn` ["legend", "supporter"] @@ -6002,7 +6008,7 @@ testRenewalHoldsNoOtherRequest ps = do putMVar release () alice <##. "1: supporter" renewed <- waitLedgerRows (chatController alice) 4 - drop 2 (rowChanges renewed) `shouldBe` [(1, 1, renewalStart, Just "charge"), (-1, 0, addMonths 1 renewalStart, Just "badge")] + drop 2 (rowChanges renewed) `shouldBe` [(1, 1, renewalStart, Just "charge"), (-1, 0, addMonths 2 firstStart, Just "badge")] testPurchaseHoldsNoRenewal :: HasCallStack => TestParams -> IO () testPurchaseHoldsNoRenewal ps = do @@ -6025,7 +6031,7 @@ testPurchaseHoldsNoRenewal ps = do alice <## "ok" alice <##. "1: supporter" renewed <- waitLedgerRows (chatController alice) 4 - drop 2 (rowChanges renewed) `shouldBe` [(1, 1, renewalStart, Just "charge"), (-1, 0, addMonths 1 renewalStart, Just "badge")] + drop 2 (rowChanges renewed) `shouldBe` [(1, 1, renewalStart, Just "charge"), (-1, 0, addMonths 2 firstStart, Just "badge")] putMVar release () expectLinesWithin 60 bob ["1: supporter"] []