badges: keep the renewal day when the tier changes at renewal (#7965)

* tests: badge renewal dates from the subscription start

* badges: keep the renewal day when the tier changes at renewal

* badges: keep the original ledger comments

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.

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 ()

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"] []