badge-service: renew a subscription once its paid coverage ends

While a subscription purchase's coverage runs, issueBadge is unchanged
and makes no store call. Once it has ended, the service asks the store at
most once an hour per subscription, stamping every attempt, and answers
from the stored state in between; a failed check is retried after the
whole interval. A grantable charge is planned from the tip at the store's
period start, signed, and written with its issuance and state in one
transaction that re-reads the tip, answering internal if it moved. Any
other charge and the state are recorded without a ledger row. Every answer
for a subscription purchase carries its state.

Run: 001-badge-subscriptions, slice 4

apps/simplex-badge-service/src/BadgeService/Service.hs

@@ -54,7 +54,7 @@ import Data.Int (Int64)
 import qualified Data.Map.Strict as M
 import Data.Maybe (fromMaybe, isJust, maybeToList)
 import qualified Data.Text as T
-import Data.Time.Clock (UTCTime, getCurrentTime)
+import Data.Time.Clock (NominalDiffTime, UTCTime, diffUTCTime, getCurrentTime)
 import Data.Word (Word32)
 import Simplex.Chat.Badges
 import Simplex.Chat.Badges.Code
@@ -357,7 +357,7 @@ badgeServiceResponse key verifier cc trackerQ_ sigKey reqData = case J.fromJSON
               (Just _, Just _) -> pure $ errorResponse BSEBadRequest
               (Nothing, _) -> pure $ errorResponse BSEBadRequest
         BSCIssueBadge {balance} -> case purchaseKey of
-          Just k -> issueBadgeCmd key cc k balance
+          Just k -> issueBadgeCmd key cc verifier k balance
           Nothing -> pure $ errorResponse BSEBadRequest
         -- Every command but redeemBadgeCode and purchaseBadge from a store needs a key the service already knows; those two create the purchase, so their key is unknown on a first purchase.
         _ -> case purchaseKey of
@@ -496,7 +496,7 @@ purchaseWithReceipt key cc verifier purchaseKey masterKey StoreReceipt {txRef =
             chargeId <- randomId cc
             entryIds <- (,,) <$> randomId cc <*> randomId cc <*> randomId cc
             let seed = emptyEntry periodStart badgeType
-            signFirstMonthAfter key cc masterKey now seed (chargeEntries periodStart now months chargeId entryIds seed) >>= \case
+            signMonthAfter key cc masterKey now seed (chargeEntries periodStart now months chargeId entryIds seed) >>= \case
               Left resp -> pure resp
               Right firstMonth ->
                 claimPurchase now (\paymentId -> NewStorePurchase {paymentId, provider, providerRef, paid, purchaseKey, masterKey, badgeType, subscriptionState = Just subscriptionState, providerToken}) $
@@ -591,15 +591,15 @@ signFirstMonth key cc masterKey badgeType months credit now = do
   -- TODO [badges] a top-up grants onto an existing ledger, and must lapse before it or the
   -- months it adds are counted from a start already in the past
   let seed = emptyEntry now badgeType
-  signFirstMonthAfter key cc masterKey now seed [grantEntry now grantUuid months credit seed]
+  signMonthAfter key cc masterKey now seed [grantEntry now grantUuid months credit seed]
 
--- | The rows that fund a new purchase, with the month they fund issued at now and signed.
-signFirstMonthAfter :: BadgeIssuerKey -> ChatController -> BadgeMasterKey -> UTCTime -> StatementEntry -> [StatementEntry] -> IO (Either BadgeServiceResponse ([StatementEntry], (StatementEntry, StatementEntry, BadgeCredential)))
-signFirstMonthAfter key cc masterKey now seed rows = do
+-- | The rows that fund a month, after the entry they follow, with that month issued at now and signed.
+signMonthAfter :: BadgeIssuerKey -> ChatController -> BadgeMasterKey -> UTCTime -> StatementEntry -> [StatementEntry] -> IO (Either BadgeServiceResponse ([StatementEntry], (StatementEntry, StatementEntry, BadgeCredential)))
+signMonthAfter key cc masterKey now previous rows = do
   issueUuid <- randomId cc
-  let funded = last (seed : rows)
+  let funded = last (previous : rows)
   case issueEntry now issueUuid funded of
-    Nothing -> logError "badge service: a new purchase funds no month to issue" $> Left (errorResponse BSEInternal)
+    Nothing -> logError "badge service: the rows written fund no month to issue" $> Left (errorResponse BSEInternal)
     Just issued ->
       credentialForEntry key masterKey issued >>= \case
         Left e -> logError ("badge service signing failed: " <> T.pack e) $> Left (errorResponse BSEInternal)
@@ -612,41 +612,102 @@ firstMonthResponse db purchaseId creditPaymentId_ subscription (rows, issuance@(
   pure $ maybe (errorResponse BSEInternal) (credentialResponse (Just credential) Nothing subscription) entries_
 
 -- | The purchase is reached through the verified signer key and no other way.
-issueBadgeCmd :: BadgeIssuerKey -> ChatController -> C.PublicKeyEd25519 -> BadgeBalance -> IO BadgeServiceResponse
-issueBadgeCmd key cc purchaseKey BadgeBalance {lastEntry} = do
+issueBadgeCmd :: BadgeIssuerKey -> ChatController -> StoreVerifier -> C.PublicKeyEd25519 -> BadgeBalance -> IO BadgeServiceResponse
+issueBadgeCmd key cc verifier purchaseKey BadgeBalance {lastEntry} = do
   now <- badgeNow cc
   purchase_ <- withDB' "getBadgePurchase" cc $ \db -> do
     p_ <- getPurchaseByKey db purchaseKey
-    forM p_ $ \p@ServicePurchase {badgePurchaseId} -> (p,) <$> getLedgerTip db badgePurchaseId
+    forM p_ $ \p@ServicePurchase {badgePurchaseId} -> (p,,) <$> getLedgerTip db badgePurchaseId <*> getPurchaseSubscription db badgePurchaseId
   case purchase_ of
     Left _ -> pure $ errorResponse BSEInternal
     Right Nothing -> pure $ errorResponse BSEUnknownPurchaseKey
-    Right (Just (ServicePurchase {badgePurchaseId, masterKey, badgeType}, tip)) -> do
+    -- once a subscription's paid coverage has ended, only a new store charge funds another month
+    Right (Just (purchase, Just tip, Just subscription))
+      | paidThrough tip <= now -> renewSubscription purchase tip subscription now
+    Right (Just (ServicePurchase {badgePurchaseId, masterKey, badgeType}, tip, subscription_)) -> do
       (lapseUuid, issueUuid) <- (,) <$> randomId cc <*> randomId cc
       let tipEntry = fromMaybe (emptyEntry now badgeType) tip
           lapsed = lapseEntry now lapseUuid tipEntry
           current = fromMaybe tipEntry lapsed
+          state_ = (\PurchaseSubscription {storedState} -> storedState) <$> subscription_
       case issueEntry now issueUuid current of
-        Nothing -> writeIssued badgePurchaseId tip (maybeToList lapsed) now Nothing
+        Nothing -> writeIssued badgePurchaseId tip (maybeToList lapsed) now Nothing state_
         Just e ->
           credentialForEntry key masterKey e >>= \case
             Left err -> logError ("badge service signing failed: " <> T.pack err) $> errorResponse BSEInternal
             Right signed ->
-              writeIssued badgePurchaseId tip (maybeToList lapsed) now $ Just $ issuanceAfter current signed
+              writeIssued badgePurchaseId tip (maybeToList lapsed) now (Just $ issuanceAfter current signed) state_
   where
     -- Write only if the tip has not moved, since another request may have advanced it.
-    writeIssued purchaseId tip rows t issuance_ = do
+    writeIssued purchaseId tip rows t issuance_ state_ = do
       r <- withDB "issueBadge" cc $ \db -> liftIO $ do
         tip' <- getLedgerTip db purchaseId
         when (fmap entryId tip' == fmap entryId tip) $ appendLedgerPlan db purchaseId Nothing rows issuance_
-        issueResponse db purchaseId t
+        issueResponse db purchaseId t state_
       pure $ fromRight (errorResponse BSEInternal) r
+    -- Nothing but the store's answer is written until a charge is granted: a lapse at now would be dated
+    -- after a grant a later check may make at an earlier period start, and the client would read it as a pass that issued.
+    renewSubscription ServicePurchase {badgePurchaseId, masterKey, badgeType} tip PurchaseSubscription {paymentId, provider, subscriptionRef, storedState, checkedAt} now
+      | maybe False (\t -> diffUTCTime now t < subscriptionCheckInterval) checkedAt = answered "answerStoredSubscription" $ \db -> issueResponse db badgePurchaseId now (Just storedState)
+      | otherwise =
+          withDB' "stampSubscriptionCheck" cc (\db -> stampSubscriptionCheck db paymentId now) >>= \case
+            Left _ -> pure $ errorResponse BSEInternal
+            Right () ->
+              checkStoreSubscription verifier subscriptionRef >>= \case
+                Left refusal -> withCheckInterval <$> storeRefusalResponse refusal
+                Right checked@SubscriptionCheck {subscriptionState, latestCharge} -> case grantableCharge provider (Just badgeType) now checked of
+                  Left NGMalformedPeriod -> storeRefusalResponse $ SRVerifierFailed "a charge whose period does not end after its start"
+                  Left reason -> do
+                    forM_ latestCharge $ \_ -> logInfo $ "store subscription charge not granted: " <> tshow reason
+                    recordCheck latestCharge subscriptionState
+                  Right (charge@StoreCharge {chargeRef, periodStart}, (_, months)) ->
+                    withDB' "getSubscriptionCharge" cc (\db -> getSubscriptionCharge db paymentId chargeRef) >>= \case
+                      Left _ -> pure $ errorResponse BSEInternal
+                      -- the store still reports the charge the ledger last granted
+                      Right (Just (_, True)) -> recordCheck (Just charge) subscriptionState
+                      Right recorded -> do
+                        chargeId <- maybe (randomId cc) (pure . fst) recorded
+                        entryIds <- (,,) <$> randomId cc <*> randomId cc <*> randomId cc
+                        signMonthAfter key cc masterKey now tip (chargeEntries periodStart now months chargeId entryIds tip) >>= \case
+                          Left resp -> pure resp
+                          Right (rows, issuance) -> do
+                            r <- withDB "renewSubscription" cc $ \db -> liftIO $ do
+                              tip' <- getLedgerTip db badgePurchaseId
+                              if fmap entryId tip' /= Just (entryId tip)
+                                then pure Nothing
+                                else do
+                                  insertSubscriptionCharge db paymentId chargeId charge now
+                                  appendLedgerPlan db badgePurchaseId Nothing rows $ Just issuance
+                                  setSubscriptionState db paymentId subscriptionState now
+                                  Just <$> issueResponse db badgePurchaseId now (Just subscriptionState)
+                            case r of
+                              Right (Just resp) -> pure resp
+                              Right Nothing -> logError "badge service: a subscription's ledger moved while its renewal was signed" $> errorResponse BSEInternal
+                              Left _ -> pure $ errorResponse BSEInternal
+      where
+        -- the store's answer is kept, and a charge it reports is recorded once, granted or not
+        recordCheck charge_ state = do
+          chargeId <- randomId cc
+          answered "recordSubscriptionCheck" $ \db -> do
+            forM_ charge_ $ \charge -> insertSubscriptionCharge db paymentId chargeId charge now
+            setSubscriptionState db paymentId state now
+            issueResponse db badgePurchaseId now (Just state)
+    answered what action = fromRight (errorResponse BSEInternal) <$> withDB' what cc action
+    -- the next check waits out the interval whatever the client is told, so its retry waits as long
+    withCheckInterval = \case
+      BSPError {code, message, retryAfter = Just _} -> BSPError {code, message, retryAfter = Just $ round subscriptionCheckInterval}
+      resp -> resp
     -- Only the asserted entry's identity is read, never the months it claims.
-    issueResponse db purchaseId t = do
+    issueResponse db purchaseId t subscription = do
       let StatementEntry {entryId = assertedUuid} = lastEntry
       assertedId <- getLedgerEntryId db purchaseId assertedUuid
       -- TODO [badges] when the assertion does not resolve, heal the ledger and restate it as a
       -- single opening credit, rather than resending the whole history
       entries_ <- getLedgerEntries db purchaseId (fromMaybe 0 assertedId)
       credential_ <- getCurrentIssuance db purchaseId t
-      pure $ maybe (errorResponse BSEInternal) (credentialResponse credential_ (assertedUuid <$ assertedId) Nothing) entries_
+      pure $ maybe (errorResponse BSEInternal) (credentialResponse credential_ (assertedUuid <$ assertedId) subscription) entries_
+
+-- | Each subscription asks its store at most this often, failed attempts included, so a client
+-- repeating its requests cannot spend the store quota every subscriber shares.
+subscriptionCheckInterval :: NominalDiffTime
+subscriptionCheckInterval = 3600

apps/simplex-badge-service/src/BadgeService/Store.hs

@@ -32,6 +32,11 @@ module BadgeService.Store
     appendLedgerPlan,
     createCodePurchase,
     createStorePurchase,
+    PurchaseSubscription (..),
+    getPurchaseSubscription,
+    stampSubscriptionCheck,
+    setSubscriptionState,
+    getSubscriptionCharge,
     insertSubscriptionCharge,
     insertBadgeCode,
     setCodeGroupItem,
@@ -44,7 +49,7 @@ module BadgeService.Store
 where
 
 import BadgeService.Store.Invoices (executeChanging, paymentStatusText)
-import BadgeService.StoreReceipts (StoreCharge (..))
+import BadgeService.StoreReceipts (StoreCharge (..), SubscriptionRef (..))
 import qualified Data.Aeson as J
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Lazy.Char8 as LB
@@ -56,7 +61,7 @@ import Simplex.Chat.Badges (BadgeCredential, BadgeMasterKey (..), BadgeType)
 import Simplex.Chat.Badges.Ledger
 import Simplex.Chat.Badges.Service (StatementCreditType (..), StatementEntry (..), StatementEntryType (..), SubscriptionState)
 import Simplex.Chat.Badges.Types (BadgeCodePaymentStatus, BadgePurchaseStatus (..))
-import Simplex.Chat.PaymentService.Types (CurrencyAmount (..), InvoiceId (..), PaymentProvider, PaymentStatus (..))
+import Simplex.Chat.PaymentService.Types (CurrencyAmount (..), InvoiceId (..), PaymentProvider (..), PaymentStatus (..))
 import Simplex.Chat.Store.Shared (insertedRowId)
 import Simplex.Messaging.Agent.Store.DB (Binary (..), BoolInt (..))
 import qualified Simplex.Messaging.Agent.Store.DB as DB
@@ -398,6 +403,60 @@ createStorePurchase db NewStorePurchase {paymentId, provider, providerRef, paid,
         (purchaseKey, Binary mk, badgeType, badgeType, PSIssued, paymentId, now, now)
       Just <$> insertedRowId db
 
+-- | What a renewal asks the store about, for a purchase a subscription funds.
+data PurchaseSubscription = PurchaseSubscription
+  { paymentId :: Text,
+    provider :: PaymentProvider,
+    subscriptionRef :: SubscriptionRef,
+    storedState :: SubscriptionState,
+    checkedAt :: Maybe UTCTime
+  }
+
+-- | Nothing for a purchase no subscription funds.
+getPurchaseSubscription :: DB.Connection -> Int64 -> IO (Maybe PurchaseSubscription)
+getPurchaseSubscription db purchaseId =
+  maybeFirstRow' Nothing toSubscription $
+    DB.query
+      db
+      [sql|
+        SELECT pay.payment_id, pay.provider, pay.provider_ref, pay.provider_token, pay.subscription_state, pay.subscription_checked_at
+        FROM sx_badge_service_badge_purchases p
+        JOIN sx_badge_service_payments pay ON pay.payment_id = p.payment_id
+        WHERE p.badge_purchase_id = ? AND pay.subscription_state IS NOT NULL
+      |]
+      (Only purchaseId)
+  where
+    toSubscription (paymentId, provider_, providerRef, token_, state_, checkedAt) = do
+      provider <- textDecode provider_
+      subscriptionRef <- case provider of
+        PPApple -> Just $ SubscriptionApple providerRef
+        PPGoogle -> SubscriptionGoogle <$> token_
+        _ -> Nothing
+      storedState <- textDecode state_
+      Just PurchaseSubscription {paymentId, provider, subscriptionRef, storedState, checkedAt}
+
+-- | Taken before the store is asked, so a check that fails or never returns still holds the next one off.
+stampSubscriptionCheck :: DB.Connection -> Text -> UTCTime -> IO ()
+stampSubscriptionCheck db paymentId now =
+  DB.execute db "UPDATE sx_badge_service_payments SET subscription_checked_at = ?, updated_at = ? WHERE payment_id = ?" (now, now, paymentId)
+
+setSubscriptionState :: DB.Connection -> Text -> SubscriptionState -> UTCTime -> IO ()
+setSubscriptionState db paymentId state now =
+  DB.execute db "UPDATE sx_badge_service_payments SET subscription_state = ?, updated_at = ? WHERE payment_id = ?" (textEncode state, now, paymentId)
+
+-- | The id a charge was recorded under, and whether a ledger row grants it.
+getSubscriptionCharge :: DB.Connection -> Text -> Text -> IO (Maybe (Text, Bool))
+getSubscriptionCharge db paymentId chargeRef =
+  maybeFirstRow (\(chargeId, granted) -> (chargeId, (granted :: Int) > 0)) $
+    DB.query
+      db
+      [sql|
+        SELECT c.charge_id, CASE WHEN EXISTS (SELECT 1 FROM sx_badge_service_badge_ledger l WHERE l.charge_id = c.charge_id) THEN 1 ELSE 0 END
+        FROM sx_badge_service_subscription_charges c
+        WHERE c.payment_id = ? AND c.provider_charge_ref = ?
+      |]
+      (paymentId, chargeRef)
+
 -- | A charge the store reports again is recorded once, by its own reference.
 insertSubscriptionCharge :: DB.Connection -> Text -> Text -> StoreCharge -> UTCTime -> IO ()
 insertSubscriptionCharge db paymentId chargeId StoreCharge {chargeRef, planId, periodStart, periodEnd, chargePaid = paid} now =

docs/protocol/badges-rpc.md

@@ -59,6 +59,7 @@ The client never states what is signed. The tier is that of whatever funded the
   - Funding by `receipt` is a transfer (post-MVP): the unissued months of the purchase that receipt belongs to move to the signing key, recorded as `debit(transferOut)` on the source and `credit(transferIn)` on the new purchase, and the presented receipt is retired for a fresh one. The transferred period's issuance debits a month like any other. Lifetime badges hold no receipt, so support handles them.
 - `upgradeBadgeSubscription` → `badgeCredential` — the app-led store subscription change, on the same key: verifies the store evidence of the replaced subscription and records the new plan; an immediate upgrade returns the new credential, a deferred change returns none. Its `badgeRequest` is to be dropped (see above).
 - `issueBadge` → `badgeCredential` — issues the next period from the balance, the only source of issuance. It carries `balance` alone: the credential is signed with the purchase's stored master key, for the type the balance funds, expiring at the `sundayAfter` of the period issued. The ledger is advanced first; the credential is signed before the `debit(badge)` and issuance rows are written, in one transaction. An exhausted balance yields no `credential`; the `statement` shows why. Issuing on a paused badge resumes it (model 2.13).
+  - **Subscriptions.** While a store subscription's paid coverage runs, `issueBadge` is answered as above, without asking the store. Once it has ended, the service asks the store, at most once an hour per subscription whether or not the store answers, and answers requests in between from what it last read. A charge it can grant, by the rule `purchaseBadge` applies to a first charge but only for the purchase's own badge type and never twice, is granted at the store's period start, after a lapse of what ran out before it, and the month due is issued. Otherwise no ledger row is written: the charge, if any, and the state are recorded, and the answer carries no new `credential` and the `subscription` the store reported. A store that does not answer is answered `provider_unavailable` with a `retryAfter` of the hour. Every answer for a subscription purchase carries `subscription`.
 - `pauseBadge` (post-MVP) → `badgeCredential` — suspends issuance and lapse (model 2.13).
 
 ## Upgrades

tests/Bots/BadgeService/BotTests.hs

@@ -178,6 +178,10 @@ badgeServiceTests = do
   describe "subscriptions" $ do
     it "should credit a subscription's charge from the store's period start, and answer replays from the record" testSubscriptionPurchase
     it "should credit nothing for a subscription with no charge it can grant, retrying as the charge may still come" testSubscriptionPurchaseNotGrantable
+    it "should grant each store charge once, and answer a repeat inside the issued month without asking the store" testSubscriptionChargeGrantedOnce
+    it "should ask the store only once coverage has ended, and at most once an hour, failed checks included" testSubscriptionStoreChecksBounded
+    it "should record and not grant a revoked, other-tier, offer, unstarted or ended charge" testSubscriptionChargeNotGranted
+    it "should answer an unreachable store with the check interval, writing no charge or ledger row" testSubscriptionStoreUnreachable
 
 badgeBotName :: Text
 badgeBotName = "SimpleX Badges"
@@ -2034,6 +2038,123 @@ testSubscriptionPurchaseNotGrantable ps =
     nothingPurchased cc
     rowCount cc "sx_badge_service_subscription_charges" `shouldReturn` 0
 
+-- | A monthly Play subscription bought an hour into its first period: its key, that period's start and the statement it was answered.
+subscribedMonthly :: HasCallStack => BadgeServiceEnv -> IO (C.PublicKeyEd25519, UTCTime, [StatementEntry])
+subscribedMonthly env@BadgeServiceEnv {bsStore} = do
+  firstStart <- addUTCTime (-3600) <$> serviceNow env
+  setSubscription bsStore (SubscriptionGoogle googleSubscriptionToken) $ subscriptionCheck SSRenewing $ Just $ storeCharge "subscr-badge-supporter-month-02" firstStart 1
+  (purchaseKey, masterKey) <- newPurchaseKeys
+  purchased <- serviceCmd env purchaseKey $ purchaseCmd masterKey subscriptionPlay
+  pure (purchaseKey, firstStart, fst $ statementOf purchased)
+
+-- | 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}
+
+storeReports :: FakeStore -> SubscriptionCheck -> IO ()
+storeReports store = setSubscription store (SubscriptionGoogle googleSubscriptionToken)
+
+subscriptionCheckedAt :: ChatController -> IO [Maybe UTCTime]
+subscriptionCheckedAt ChatController {chatStore} =
+  withTransaction chatStore $ \db ->
+    map fromOnly <$> DB.query_ db "SELECT subscription_checked_at FROM sx_badge_service_payments"
+
+testSubscriptionChargeGrantedOnce :: HasCallStack => TestParams -> IO ()
+testSubscriptionChargeGrantedOnce ps =
+  withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClock, bsController = cc, bsStore = store} -> do
+    (purchaseKey, firstStart, purchased) <- subscribedMonthly env
+    let renewalStart = addMonths 1 firstStart
+        -- the store's period runs past the month granted, so the charge is still current once that month is spent
+        renewal = (monthlyCharge "subscr-badge-supporter-month-02" firstStart 1) {periodEnd = addUTCTime (10 * nominalDay) (addMonths 2 firstStart)}
+    storeReports store $ subscriptionCheck SSRenewing $ Just renewal
+    setClockAt bsClock $ addUTCTime (3 * nominalDay) renewalStart
+    renewed <- assertBalance env purchaseKey (last purchased)
+    map entryTag (fst $ statementOf renewed) `shouldBe` ["charge", "badge"]
+    map createdAtOf (take 1 $ fst $ statementOf renewed) `shouldBe` [renewalStart]
+    subscriptionOf renewed `shouldBe` Just SSRenewing
+    credentialOf renewed `shouldSatisfy` isJust
+    -- inside the issued month a repeat gets the same credential, and the store is not asked
+    checks <- subscriptionChecks store
+    repeated <- assertBalance env purchaseKey (last purchased)
+    credentialOf repeated `shouldBe` credentialOf renewed
+    subscriptionOf repeated `shouldBe` Just SSRenewing
+    subscriptionChecks store `shouldReturn` checks
+    -- the store still reports that charge once the month has run out, and it is not granted again
+    ledger <- ledgerRows cc "sx_badge_service_badge_ledger"
+    setClockAt bsClock $ addUTCTime (3 * nominalDay) (addMonths 2 firstStart)
+    reported <- assertBalance env purchaseKey (last $ fst $ statementOf renewed)
+    subscriptionChecks store `shouldReturn` (checks + 1)
+    map entryTag (fst $ statementOf reported) `shouldBe` []
+    credentialOf reported `shouldBe` Nothing
+    ledgerRows cc "sx_badge_service_badge_ledger" `shouldReturn` ledger
+    rowCount cc "sx_badge_service_subscription_charges" `shouldReturn` 2
+
+testSubscriptionStoreChecksBounded :: HasCallStack => TestParams -> IO ()
+testSubscriptionStoreChecksBounded ps =
+  withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClock, bsStore = store} -> do
+    (purchaseKey, firstStart, purchased) <- subscribedMonthly env
+    let request = assertBalance env purchaseKey (last purchased)
+        ended = addUTCTime (3 * nominalDay) (addMonths 1 firstStart)
+    checks <- subscriptionChecks store
+    setClockAt bsClock $ addUTCTime (10 * nominalDay) firstStart
+    _ <- request
+    subscriptionChecks store `shouldReturn` checks
+    -- once the month has run out the store is asked, and not again within the hour
+    storeReports store $ subscriptionCheck SSBillingRetry Nothing
+    setClockAt bsClock ended
+    waiting <- request
+    subscriptionOf waiting `shouldBe` Just SSBillingRetry
+    credentialOf waiting `shouldBe` Nothing
+    setClockAt bsClock $ addUTCTime 1800 ended
+    subscriptionOf <$> request `shouldReturn` Just SSBillingRetry
+    subscriptionChecks store `shouldReturn` (checks + 1)
+    -- an hour on it is asked again, and a check that fails holds the next one off as long
+    setGoogleDown store True
+    setClockAt bsClock $ addUTCTime 3700 ended
+    refusalOf <$> request `shouldReturn` (BSEProviderUnavailable, Just 3600)
+    setGoogleDown store False
+    setClockAt bsClock $ addUTCTime (3700 + 1800) ended
+    subscriptionOf <$> request `shouldReturn` Just SSBillingRetry
+    subscriptionChecks store `shouldReturn` (checks + 2)
+
+testSubscriptionChargeNotGranted :: HasCallStack => TestParams -> IO ()
+testSubscriptionChargeNotGranted ps =
+  withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClock, bsController = cc, bsStore = store} -> do
+    (purchaseKey, firstStart, purchased) <- subscribedMonthly env
+    ledger <- ledgerRows cc "sx_badge_service_badge_ledger"
+    let monthly = "subscr-badge-supporter-month-02"
+        checkedAt i = addUTCTime (3 * nominalDay + fromIntegral (i :: Int) * 3700) (addMonths 1 firstStart)
+        notGranted =
+          [ (monthlyCharge monthly firstStart 1) {revoked = True},
+            monthlyCharge "subscr-badge-legend-month-01" firstStart 2,
+            (monthlyCharge monthly firstStart 3) {offer = True},
+            (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}
+          ]
+    forM_ (zip [0 ..] notGranted) $ \(i, charge) -> do
+      storeReports store $ subscriptionCheck SSRenewing $ Just charge
+      setClockAt bsClock $ checkedAt i
+      answered <- assertBalance env purchaseKey (last purchased)
+      credentialOf answered `shouldBe` Nothing
+      map entryTag (fst $ statementOf answered) `shouldBe` []
+    -- each charge is recorded, and none funds a month
+    rowCount cc "sx_badge_service_subscription_charges" `shouldReturn` 1 + length notGranted
+    ledgerRows cc "sx_badge_service_badge_ledger" `shouldReturn` ledger
+
+testSubscriptionStoreUnreachable :: HasCallStack => TestParams -> IO ()
+testSubscriptionStoreUnreachable ps =
+  withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsClock, bsController = cc, bsStore = store} -> do
+    (purchaseKey, firstStart, purchased) <- subscribedMonthly env
+    ledger <- ledgerRows cc "sx_badge_service_badge_ledger"
+    let ended = addUTCTime (3 * nominalDay) (addMonths 1 firstStart)
+    storeReports store $ subscriptionCheck SSRenewing $ Just $ monthlyCharge "subscr-badge-supporter-month-02" firstStart 1
+    setGoogleDown store True
+    setClockAt bsClock ended
+    refusalOf <$> assertBalance env purchaseKey (last purchased) `shouldReturn` (BSEProviderUnavailable, Just 3600)
+    subscriptionCheckedAt cc >>= (`shouldSatisfy` \case [Just t] -> abs (diffUTCTime t ended) < 60; _ -> False)
+    ledgerRows cc "sx_badge_service_badge_ledger" `shouldReturn` ledger
+    rowCount cc "sx_badge_service_subscription_charges" `shouldReturn` 1
+
 testPurchaseBadge :: HasCallStack => TestParams -> IO ()
 testPurchaseBadge ps =
   withBadgeServiceEnv ps $ \BadgeServiceEnv {bsClientCfg, bsController = cc} ->

tests/Bots/BadgeService/FakeStore.hs

@@ -95,7 +95,10 @@ newFakeStore = do
       verifyGoogle = googleVerdict pendingSettled googleDown
       checkSubscription ref = do
         modifyIORef' subscriptionCheckCount (+ 1)
-        maybe (Left $ SRUnreachable "the fake store knows no such subscription") Right . M.lookup (subscriptionKey ref) <$> readIORef subscriptions
+        down <- readIORef googleDown
+        case ref of
+          SubscriptionGoogle _ | down -> pure $ Left $ SRUnreachable "fake store is down"
+          _ -> maybe (Left $ SRUnreachable "the fake store knows no such subscription") Right . M.lookup (subscriptionKey ref) <$> readIORef subscriptions
   pure
     FakeStore
       { appleSupporterJWS,