badge-service: credit a store subscription purchase

The catalog now tells subscription products from one-time ones and maps a
store plan to its tier and months. A subscription receipt is checked with
the store once: with a grantable charge, the service plans the charge's
rows from the store's period start, signs the first month, and writes the
payment, purchase, charge, ledger rows, issuance, state and Play token in
one transaction, answering with the subscription state. Without one, it
answers payment_pending (300 s while the period has not started or the
store is pending, a day otherwise), receipt_invalid for an ended Play
subscription, or test_purchase, and writes nothing. Replays carry the
state. The store verifier interface gains the subscription check, which no
real store implements yet; the fake store does.

Run: 001-badge-subscriptions, slice 3b

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

@@ -13,6 +13,7 @@ module BadgeService.Catalog
     defaultCatalog,
     StoreProduct (..),
     storeProduct,
+    storePlan,
   )
 where
 
@@ -136,19 +137,39 @@ defaultCatalog seededAt = (prices, offers)
           createdAt = seededAt
         }
 
-data StoreProduct = StoreProduct
-  { badgeType :: BadgeType,
-    months :: Int
-  }
+-- | A subscription's badge and months come from each charge's plan, so the product names neither.
+data StoreProduct
+  = StoreOneTime {badgeType :: BadgeType, months :: Int}
+  | StoreSubscription
   deriving (Eq, Show)
 
 -- | A receipt proves only the product paid for, so the badge comes from here, never from the client.
--- Mirrors the one-time SKUs of BadgeStore.swift and .kt; subscriptions wait until renewals add months.
+-- Mirrors the SKUs of BadgeStore.swift and .kt.
 -- Not part of the seeded catalog above, which exists to pin prices this service sets: a store sets its own.
 storeProduct :: PaymentProvider -> Text -> Maybe StoreProduct
 storeProduct provider productId = case (provider, productId) of
-  (PPApple, "BADGE_SUPPORTER_01") -> Just $ StoreProduct BTSupporter 1
-  (PPApple, "BADGE_LEGEND_01") -> Just $ StoreProduct BTLegend 1
-  (PPGoogle, "badge_supporter_01") -> Just $ StoreProduct BTSupporter 1
-  (PPGoogle, "badge_legend_01") -> Just $ StoreProduct BTLegend 1
+  (PPApple, "BADGE_SUPPORTER_01") -> Just $ StoreOneTime BTSupporter 1
+  (PPApple, "BADGE_LEGEND_01") -> Just $ StoreOneTime BTLegend 1
+  (PPGoogle, "badge_supporter_01") -> Just $ StoreOneTime BTSupporter 1
+  (PPGoogle, "badge_legend_01") -> Just $ StoreOneTime BTLegend 1
+  (PPApple, "SUBSCR_BADGE_SUPPORTER_MONTH_01") -> Just StoreSubscription
+  (PPApple, "SUBSCR_BADGE_SUPPORTER_YEAR_01") -> Just StoreSubscription
+  (PPApple, "SUBSCR_BADGE_LEGEND_MONTH_01") -> Just StoreSubscription
+  (PPApple, "SUBSCR_BADGE_LEGEND_YEAR_01") -> Just StoreSubscription
+  (PPGoogle, "subscr_badge_supporter_01") -> Just StoreSubscription
+  (PPGoogle, "subscr_badge_legend_01") -> Just StoreSubscription
+  _ -> Nothing
+
+-- | What a subscription charge grants, from the plan it was for: Apple's product id, or Play's base
+-- plan, which only Play's subscription record names. The months are the plan's, never the period's length.
+storePlan :: PaymentProvider -> Text -> Maybe (BadgeType, Int)
+storePlan provider planId = case (provider, planId) of
+  (PPApple, "SUBSCR_BADGE_SUPPORTER_MONTH_01") -> Just (BTSupporter, 1)
+  (PPApple, "SUBSCR_BADGE_SUPPORTER_YEAR_01") -> Just (BTSupporter, 12)
+  (PPApple, "SUBSCR_BADGE_LEGEND_MONTH_01") -> Just (BTLegend, 1)
+  (PPApple, "SUBSCR_BADGE_LEGEND_YEAR_01") -> Just (BTLegend, 12)
+  (PPGoogle, "subscr-badge-supporter-month-02") -> Just (BTSupporter, 1)
+  (PPGoogle, "subscr-badge-supporter-year-01") -> Just (BTSupporter, 12)
+  (PPGoogle, "subscr-badge-legend-month-01") -> Just (BTLegend, 1)
+  (PPGoogle, "subscr-badge-legend-year-01") -> Just (BTLegend, 12)
   _ -> Nothing

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

@@ -21,7 +21,7 @@ module BadgeService.Service
   )
 where
 
-import BadgeService.Catalog (StoreProduct (..), defaultCatalog, storeProduct)
+import BadgeService.Catalog (StoreProduct (..), defaultCatalog, storePlan, storeProduct)
 import BadgeService.Codes (issueFailedText, issueOneCode, singleUse)
 import BadgeService.Config (AppleStoreConfig (..), BadgeIssuerKey (..), PlayStoreConfig (..), ServiceConfig (..), readServiceConfig)
 import BadgeService.Group (GroupEvent, ensureManagedGroup, groupEvent, hasTracker, refreshTracker, revokeWithTracker, runGroupLane)
@@ -66,7 +66,7 @@ import Simplex.Chat.Bot.Store (withDB, withDB')
 import Simplex.Chat.Controller
 import Simplex.Chat.Core (sendChatCmd, simplexChatCore)
 import Simplex.Chat.Options (printDbOpts)
-import Simplex.Chat.PaymentService.Types (StoreTransactionRef (..))
+import Simplex.Chat.PaymentService.Types (PaymentProvider (..), StoreTransactionRef (..))
 import Simplex.Chat.Terminal (terminalChatConfig)
 import Simplex.Chat.Terminal.Main (simplexChatCLI')
 import Simplex.Chat.Types (AgentInvId (..), User (..))
@@ -352,7 +352,7 @@ badgeServiceResponse key verifier cc trackerQ_ sigKey reqData = case J.fromJSON
           Nothing -> pure $ errorResponse BSEBadRequest
         BSCPurchaseBadge {masterKey, payment, upgrade}
           | Just receipt_ <- toStoreReceipt verifier payment -> case (purchaseKey, upgrade) of
-              (Just k, Nothing) -> either storeRefusalResponse (purchaseWithReceipt key cc k masterKey) receipt_
+              (Just k, Nothing) -> either storeRefusalResponse (purchaseWithReceipt key cc verifier k masterKey) receipt_
               -- store upgrades are not built, and ignoring one would credit its months at the discounted price
               (Just _, Just _) -> pure $ errorResponse BSEBadRequest
               (Nothing, _) -> pure $ errorResponse BSEBadRequest
@@ -407,7 +407,7 @@ redeemCode key cc trackerQ_ purchaseKey masterKey codeText = case parseBadgeCode
                   readCode now code db >>= \case
                     Left resp -> pure (resp, False)
                     Right _ -> logError "badge service: redeeming a code failed, but the code has uses left and is not revoked" $> (errorResponse BSEInternal, False)
-                Just purchaseId -> liftIO $ (,True) <$> firstMonthResponse db purchaseId Nothing firstMonth
+                Just purchaseId -> liftIO $ (,True) <$> firstMonthResponse db purchaseId Nothing Nothing firstMonth
             let (resp, claimed) = fromRight (errorResponse BSEInternal, False) r
             when (claimed && hasTracker redeemLimit) $ refreshTracker cc trackerQ_ badgeCodeId code
             pure resp
@@ -436,13 +436,15 @@ redeemCode key cc trackerQ_ purchaseKey masterKey codeText = case parseBadgeCode
 
 -- | Every refusal is answered before anything is written, so it leaves the receipt unclaimed; and
 -- nothing is written until the credential is signed.
-purchaseWithReceipt :: BadgeIssuerKey -> ChatController -> C.PublicKeyEd25519 -> BadgeMasterKey -> StoreReceipt -> IO BadgeServiceResponse
-purchaseWithReceipt key cc purchaseKey masterKey StoreReceipt {txRef = StoreTransactionRef {provider, transactionRef = providerRef}, verifyReceipt, acknowledgeReceipt} =
+purchaseWithReceipt :: BadgeIssuerKey -> ChatController -> StoreVerifier -> C.PublicKeyEd25519 -> BadgeMasterKey -> StoreReceipt -> IO BadgeServiceResponse
+purchaseWithReceipt key cc verifier purchaseKey masterKey StoreReceipt {txRef = StoreTransactionRef {provider, transactionRef = providerRef}, receiptProductId, subscriptionRef, verifyReceipt, acknowledgeReceipt} =
   withDB' "getStorePayment" cc (\db -> getStorePaymentCredit db provider providerRef) >>= \case
     Left _ -> pure $ errorResponse BSEInternal
     Right credit
       -- only the key it credited can ask, and it is told only what it was given, so the store is not asked
       | creditedBy credit -> answerCredit credit
+      -- a Play subscription is verified by asking about the subscription itself
+      | Just StoreSubscription <- storeProduct provider =<< receiptProductId -> purchaseSubscription credit
       | otherwise ->
           verifyReceipt >>= \case
             Left refusal -> storeRefusalResponse refusal
@@ -467,24 +469,100 @@ purchaseWithReceipt key cc purchaseKey masterKey StoreReceipt {txRef = StoreTran
     -- the product is read only for a receipt not yet credited, so retiring it leaves its replays answered
     newPurchase VerifiedStoreTransaction {productId, paid} = case storeProduct provider productId of
       Nothing -> pure $ errorResponse BSEProductUnavailable
-      Just StoreProduct {badgeType, months} ->
-        fromMaybe (pure $ Right ()) acknowledgeReceipt >>= \case
-          Left refusal -> storeRefusalResponse refusal
-          Right () -> do
-            now <- badgeNow cc
-            signFirstMonth key cc masterKey badgeType months (SCPayment Nothing) now >>= \case
+      -- an Apple subscription, whose JWS was verified offline
+      Just StoreSubscription -> purchaseSubscription Uncredited
+      Just StoreOneTime {badgeType, months} ->
+        acknowledged $ do
+          now <- badgeNow cc
+          signFirstMonth key cc masterKey badgeType months (SCPayment Nothing) now >>= \case
+            Left resp -> pure resp
+            Right firstMonth ->
+              claimPurchase now (\paymentId -> NewStorePurchase {paymentId, provider, providerRef, paid, purchaseKey, masterKey, badgeType, subscriptionState = Nothing, providerToken = Nothing}) $
+                \db purchaseId paymentId -> firstMonthResponse db purchaseId (Just paymentId) Nothing firstMonth
+    -- another key's credit is told only once the store vouched for the subscription, as for a one-time purchase
+    purchaseSubscription credit =
+      checkStoreSubscription verifier subscriptionRef >>= \case
+        Left refusal -> storeRefusalResponse refusal
+        Right SubscriptionCheck {testSubscription = True} -> storeRefusalResponse SRTestPurchase
+        Right checked -> case credit of
+          Uncredited -> newSubscription checked
+          _ -> answerCredit credit
+    newSubscription checked@SubscriptionCheck {subscriptionState} = do
+      now <- badgeNow cc
+      case grantableCharge provider Nothing now checked of
+        Left notGranted -> firstChargeNotGranted provider notGranted
+        Right (charge@StoreCharge {periodStart, chargePaid = paid}, (badgeType, months)) ->
+          acknowledged $ do
+            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
               Left resp -> pure resp
-              Right firstMonth -> do
-                paymentId <- randomId cc
-                r <- withDB "writeStorePurchase" cc $ \db ->
-                  liftIO (createStorePurchase db NewStorePurchase {paymentId, provider, providerRef, paid, purchaseKey, masterKey, badgeType} now) >>= \case
-                    -- Credited to another key, or to this one by a request that ran alongside it, while signing.
-                    Nothing ->
-                      liftIO (getStorePaymentCredit db provider providerRef >>= creditedResponse db purchaseKey) >>= \case
-                        Left resp -> pure resp
-                        Right () -> logError ("badge service: a payment for " <> providerRef <> " exists but funds no purchase") $> errorResponse BSEInternal
-                    Just purchaseId -> liftIO $ firstMonthResponse db purchaseId (Just paymentId) firstMonth
-                pure $ fromRight (errorResponse BSEInternal) r
+              Right firstMonth ->
+                claimPurchase now (\paymentId -> NewStorePurchase {paymentId, provider, providerRef, paid, purchaseKey, masterKey, badgeType, subscriptionState = Just subscriptionState, providerToken}) $
+                  \db purchaseId paymentId -> do
+                    insertSubscriptionCharge db paymentId chargeId charge now
+                    firstMonthResponse db purchaseId Nothing (Just subscriptionState) firstMonth
+    providerToken = case subscriptionRef of
+      SubscriptionGoogle token -> Just token
+      SubscriptionApple _ -> Nothing
+    acknowledged crediting =
+      fromMaybe (pure $ Right ()) acknowledgeReceipt >>= \case
+        Left refusal -> storeRefusalResponse refusal
+        Right () -> crediting
+    claimPurchase now purchaseFor writeCredit = do
+      paymentId <- randomId cc
+      r <- withDB "writeStorePurchase" cc $ \db ->
+        liftIO (createStorePurchase db (purchaseFor paymentId) now) >>= \case
+          -- Credited to another key, or to this one by a request that ran alongside it, while signing.
+          Nothing ->
+            liftIO (getStorePaymentCredit db provider providerRef >>= creditedResponse db purchaseKey) >>= \case
+              Left resp -> pure resp
+              Right () -> logError ("badge service: a payment for " <> providerRef <> " exists but funds no purchase") $> errorResponse BSEInternal
+          Just purchaseId -> liftIO $ writeCredit db purchaseId paymentId
+      pure $ fromRight (errorResponse BSEInternal) r
+
+-- | Why a store charge grants nothing.
+data NotGranted
+  = NGEnded
+  | NGNoCharge
+  | NGMalformedPeriod
+  | NGRevoked
+  | NGOffer
+  | NGUnknownPlan
+  | NGOtherTier
+  | NGNotStarted
+  | NGPeriodOver
+  deriving (Show)
+
+-- | The grant rule of a first purchase and a renewal alike, but for whether a ledger row already references
+-- the charge, which is the caller's to check. tier is the ledger's; a first purchase may start on any plan.
+grantableCharge :: PaymentProvider -> Maybe BadgeType -> UTCTime -> SubscriptionCheck -> Either NotGranted (StoreCharge, (BadgeType, Int))
+grantableCharge provider tier now SubscriptionCheck {subscriptionState, latestCharge}
+  | subscriptionState == SSEnded = Left NGEnded
+  | otherwise = case latestCharge of
+      Nothing -> Left NGNoCharge
+      Just charge@StoreCharge {planId, periodStart, periodEnd, revoked, offer}
+        | periodEnd <= periodStart -> Left NGMalformedPeriod
+        | revoked -> Left NGRevoked
+        | offer -> Left NGOffer
+        | otherwise -> case storePlan provider planId of
+            Nothing -> Left NGUnknownPlan
+            Just plan@(badgeType, _)
+              | maybe False (/= badgeType) tier -> Left NGOtherTier
+              | now < periodStart -> Left NGNotStarted
+              | now >= periodEnd -> Left NGPeriodOver
+              | otherwise -> Right (charge, plan)
+
+-- | No payment row exists yet to bound the store checks by, so the retryAfter of each answer is what bounds them.
+firstChargeNotGranted :: PaymentProvider -> NotGranted -> IO BadgeServiceResponse
+firstChargeNotGranted provider = \case
+  NGMalformedPeriod -> storeRefusalResponse $ SRVerifierFailed "a charge whose period does not end after its start"
+  -- Play issues a new token when an ended subscription is bought again, so this one can never be credited
+  NGEnded | PPGoogle <- provider -> storeRefusalResponse $ SRInvalid "the subscription ended"
+  NGNotStarted -> storeRefusalResponse SRPending
+  -- a later charge, or an Apple resubscription under the same original id, may yet be credited from this receipt
+  reason -> logInfo ("store subscription not credited yet: " <> tshow reason) $> BSPError {code = BSEPaymentPending, message = Nothing, retryAfter = Just 86400}
 
 -- | A forged receipt and a refunded one are both receipt_invalid, so the client learns nothing a
 -- forger could iterate on. A test purchase is named, since the device that made it already knows.
@@ -501,31 +579,37 @@ creditedResponse :: DB.Connection -> C.PublicKeyEd25519 -> FundingCredit -> IO (
 creditedResponse db purchaseKey = \case
   Uncredited -> pure $ Right ()
   CreditedUnreadable -> pure $ Left $ errorResponse BSEInternal
-  Credited CreditedPurchase {purchaseKey = k, badgePurchaseId, credential}
+  Credited CreditedPurchase {purchaseKey = k, badgePurchaseId, credential, subscription}
     | k /= purchaseKey -> pure $ Left $ errorResponse BSEReceiptUsed
     | otherwise ->
-        maybe (Left $ errorResponse BSEInternal) (Left . credentialResponse (Just credential) Nothing Nothing)
+        maybe (Left $ errorResponse BSEInternal) (Left . credentialResponse (Just credential) Nothing subscription)
           <$> getLedgerEntries db badgePurchaseId 0
 
-signFirstMonth :: BadgeIssuerKey -> ChatController -> BadgeMasterKey -> BadgeType -> Int -> StatementCreditType -> UTCTime -> IO (Either BadgeServiceResponse (StatementEntry, (StatementEntry, BadgeCredential)))
+signFirstMonth :: BadgeIssuerKey -> ChatController -> BadgeMasterKey -> BadgeType -> Int -> StatementCreditType -> UTCTime -> IO (Either BadgeServiceResponse ([StatementEntry], (StatementEntry, StatementEntry, BadgeCredential)))
 signFirstMonth key cc masterKey badgeType months credit now = do
-  (grantUuid, issueUuid) <- (,) <$> randomId cc <*> randomId cc
+  grantUuid <- randomId cc
   -- 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 granted = grantEntry now grantUuid months credit $ emptyEntry now badgeType
-  -- A grant of at least one month starting now always has a month to issue.
-  case issueEntry now issueUuid granted of
-    Nothing -> pure $ Left $ errorResponse BSEInternal
+  let seed = emptyEntry now badgeType
+  signFirstMonthAfter 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
+  issueUuid <- randomId cc
+  let funded = last (seed : rows)
+  case issueEntry now issueUuid funded of
+    Nothing -> logError "badge service: a new purchase funds 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)
-        Right signed -> pure $ Right (granted, signed)
+        Right signed -> pure $ Right (rows, issuanceAfter funded signed)
 
-firstMonthResponse :: DB.Connection -> Int64 -> Maybe T.Text -> (StatementEntry, (StatementEntry, BadgeCredential)) -> IO BadgeServiceResponse
-firstMonthResponse db purchaseId creditPaymentId_ (granted, signed) = do
-  appendLedgerPlan db purchaseId creditPaymentId_ [granted] $ Just $ issuanceAfter granted signed
+firstMonthResponse :: DB.Connection -> Int64 -> Maybe T.Text -> Maybe SubscriptionState -> ([StatementEntry], (StatementEntry, StatementEntry, BadgeCredential)) -> IO BadgeServiceResponse
+firstMonthResponse db purchaseId creditPaymentId_ subscription (rows, issuance@(_, _, credential)) = do
+  appendLedgerPlan db purchaseId creditPaymentId_ rows $ Just issuance
   entries_ <- getLedgerEntries db purchaseId 0
-  pure $ maybe (errorResponse BSEInternal) (credentialResponse (Just $ snd signed) Nothing Nothing) entries_
+  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

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

@@ -32,6 +32,7 @@ module BadgeService.Store
     appendLedgerPlan,
     createCodePurchase,
     createStorePurchase,
+    insertSubscriptionCharge,
     insertBadgeCode,
     setCodeGroupItem,
     CodeTracker (..),
@@ -43,6 +44,7 @@ module BadgeService.Store
 where
 
 import BadgeService.Store.Invoices (executeChanging, paymentStatusText)
+import BadgeService.StoreReceipts (StoreCharge (..))
 import qualified Data.Aeson as J
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Lazy.Char8 as LB
@@ -52,14 +54,14 @@ import Data.Text (Text)
 import Data.Time.Clock (UTCTime)
 import Simplex.Chat.Badges (BadgeCredential, BadgeMasterKey (..), BadgeType)
 import Simplex.Chat.Badges.Ledger
-import Simplex.Chat.Badges.Service (StatementCreditType (..), StatementEntry (..), StatementEntryType (..))
+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.Store.Shared (insertedRowId)
 import Simplex.Messaging.Agent.Store.DB (Binary (..), BoolInt (..))
 import qualified Simplex.Messaging.Agent.Store.DB as DB
 import qualified Simplex.Messaging.Crypto as C
-import Simplex.Messaging.Encoding.String (textEncode)
+import Simplex.Messaging.Encoding.String (textDecode, textEncode)
 import Simplex.Messaging.Util (maybeFirstRow, maybeFirstRow')
 
 #if defined(dbPostgres)
@@ -99,7 +101,8 @@ data FundingCredit
 data CreditedPurchase = CreditedPurchase
   { badgePurchaseId :: Int64,
     purchaseKey :: C.PublicKeyEd25519,
-    credential :: BadgeCredential
+    credential :: BadgeCredential,
+    subscription :: Maybe SubscriptionState
   }
 
 data NewCodePurchase = NewCodePurchase
@@ -116,7 +119,9 @@ data NewStorePurchase = NewStorePurchase
     paid :: Maybe (CurrencyAmount, Text),
     purchaseKey :: C.PublicKeyEd25519,
     masterKey :: BadgeMasterKey,
-    badgeType :: BadgeType
+    badgeType :: BadgeType,
+    subscriptionState :: Maybe SubscriptionState,
+    providerToken :: Maybe Text -- Play's token of a subscription, which every renewal check asks by; never logged or returned
   }
 
 data ServicePurchase = ServicePurchase
@@ -207,7 +212,7 @@ getStorePaymentCredit db provider providerRef =
     DB.query
       db
       [sql|
-        SELECT p.badge_purchase_id, p.purchase_key, i.credential
+        SELECT p.badge_purchase_id, p.purchase_key, i.credential, pay.subscription_state
         FROM sx_badge_service_payments pay
         JOIN sx_badge_service_badge_purchases p ON p.payment_id = pay.payment_id
         LEFT JOIN sx_badge_service_badge_issuances i ON i.badge_purchase_id = p.badge_purchase_id
@@ -217,8 +222,8 @@ getStorePaymentCredit db provider providerRef =
       |]
       (textEncode provider, providerRef)
   where
-    toCredit (badgePurchaseId, purchaseKey, credential_) = case decodeCredential =<< credential_ of
-      Just credential -> Credited CreditedPurchase {badgePurchaseId, purchaseKey, credential}
+    toCredit (badgePurchaseId, purchaseKey, credential_, state_) = case decodeCredential =<< credential_ of
+      Just credential -> Credited CreditedPurchase {badgePurchaseId, purchaseKey, credential, subscription = textDecode =<< state_}
       Nothing -> CreditedUnreadable
 
 decodeCredential :: Binary ByteString -> Maybe BadgeCredential
@@ -367,16 +372,19 @@ createCodePurchase db NewCodePurchase {badgeCodeId, purchaseKey, masterKey = Bad
 -- | In the transaction of the credential rows. The payment's unique (provider, provider_ref) is the
 -- claim: a transaction presented twice at once, or under another key, inserts nothing the second time.
 createStorePurchase :: DB.Connection -> NewStorePurchase -> UTCTime -> IO (Maybe Int64)
-createStorePurchase db NewStorePurchase {paymentId, provider, providerRef, paid, purchaseKey, masterKey = BadgeMasterKey mk, badgeType} now = do
+createStorePurchase db NewStorePurchase {paymentId, provider, providerRef, paid, purchaseKey, masterKey = BadgeMasterKey mk, badgeType, subscriptionState, providerToken} now = do
   claimed <-
     executeChanging
       db
       [sql|
-        INSERT INTO sx_badge_service_payments (payment_id, provider, provider_ref, amount, currency, status, created_at, updated_at)
-        VALUES (?,?,?,?,?,?,?,?)
+        INSERT INTO sx_badge_service_payments
+          (payment_id, provider, provider_ref, amount, currency, status, subscription_state, subscription_checked_at, provider_token, created_at, updated_at)
+        VALUES (?,?,?,?,?,?,?,?,?,?,?)
         ON CONFLICT (provider, provider_ref) DO NOTHING
       |]
-      (paymentId, textEncode provider, providerRef, (\(CurrencyAmount a) -> a) . fst <$> paid, snd <$> paid, paymentStatusText PSSettled, now, now)
+      ( (paymentId, textEncode provider, providerRef, (\(CurrencyAmount a) -> a) . fst <$> paid, snd <$> paid, paymentStatusText PSSettled)
+          :. (textEncode <$> subscriptionState, now <$ subscriptionState, providerToken, now, now)
+      )
   if claimed == 0
     then pure Nothing
     else do
@@ -390,6 +398,19 @@ createStorePurchase db NewStorePurchase {paymentId, provider, providerRef, paid,
         (purchaseKey, Binary mk, badgeType, badgeType, PSIssued, paymentId, now, now)
       Just <$> insertedRowId db
 
+-- | 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 =
+  DB.execute
+    db
+    [sql|
+      INSERT INTO sx_badge_service_subscription_charges
+        (charge_id, payment_id, provider_charge_ref, plan_id, period_start, period_end, amount, currency, created_at)
+      VALUES (?,?,?,?,?,?,?,?,?)
+      ON CONFLICT (payment_id, provider_charge_ref) DO NOTHING
+    |]
+    ((chargeId, paymentId, chargeRef, planId, periodStart, periodEnd) :. ((\(CurrencyAmount a) -> a) . fst <$> paid, snd <$> paid, now))
+
 -- | Revoked and AlreadyRevoked carry the code id, so the caller can retire the code's group tracker,
 -- or repair one an earlier revoke left live.
 data RevokeResult = Revoked Int64 | AlreadyRevoked Int64 | AlreadyRedeemed | NoSuchCode

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

@@ -8,8 +8,12 @@ module BadgeService.StoreReceipts
     StoreRefusal (..),
     StoreVerifier (..),
     StoreReceipt (..),
+    SubscriptionRef (..),
+    SubscriptionCheck (..),
+    StoreCharge (..),
     noStoreVerifier,
     toStoreReceipt,
+    checkStoreSubscription,
   )
 where
 
@@ -18,6 +22,8 @@ import Data.Char (isAlphaNum, isAscii, isAsciiLower, isAsciiUpper, isControl, is
 import Data.Maybe (fromMaybe)
 import Data.Text (Text)
 import qualified Data.Text as T
+import Data.Time.Clock (UTCTime)
+import Simplex.Chat.Badges.Service (SubscriptionState)
 import Simplex.Chat.PaymentService (ServicePayment (..), appleTransactionRef, googlePurchaseRef)
 import Simplex.Chat.PaymentService.Types (CurrencyAmount, PaymentProvider (..), StoreTransactionRef (..))
 import Simplex.Messaging.Util (catchOwn', tshow)
@@ -55,6 +61,7 @@ data StoreVerifier = StoreVerifier
     verifyApple :: Maybe (Text -> Either StoreRefusal VerifiedStoreTransaction),
     verifyGoogle :: Maybe (Text -> Text -> IO (Either StoreRefusal VerifiedStoreTransaction)), -- the product id and the token
     acknowledgeGoogle :: Maybe (Text -> Text -> IO (Either StoreRefusal ())),
+    checkSubscription :: Maybe (SubscriptionRef -> IO (Either StoreRefusal SubscriptionCheck)),
     -- microseconds; requests are answered one at a time, so a verifier that does not finish holds up every other one
     verifyTimeout :: Int
   }
@@ -62,12 +69,36 @@ data StoreVerifier = StoreVerifier
 -- | A store payment, named by the store's own reference before anything is verified.
 data StoreReceipt = StoreReceipt
   { txRef :: StoreTransactionRef,
+    receiptProductId :: Maybe Text, -- named by a Play receipt; Apple's is known only once its JWS is verified
+    subscriptionRef :: SubscriptionRef,
     verifyReceipt :: IO (Either StoreRefusal VerifiedStoreTransaction),
     acknowledgeReceipt :: Maybe (IO (Either StoreRefusal ()))
   }
 
+-- | What a store is asked about a subscription by: Apple's original transaction id, or Play's token.
+-- The token is a bearer secret, so this has no Show.
+data SubscriptionRef = SubscriptionApple Text | SubscriptionGoogle Text
+
+data SubscriptionCheck = SubscriptionCheck
+  { subscriptionState :: SubscriptionState,
+    testSubscription :: Bool, -- costs the buyer nothing, as a testPurchase does
+    latestCharge :: Maybe StoreCharge -- the latest paid period, if the store charged at all
+  }
+  deriving (Show)
+
+data StoreCharge = StoreCharge
+  { chargeRef :: Text, -- Apple's transactionId, Play's order id
+    planId :: Text, -- Apple's product id, Play's base plan
+    periodStart :: UTCTime,
+    periodEnd :: UTCTime,
+    chargePaid :: Maybe (CurrencyAmount, Text), -- in minor units; Play reports no price
+    revoked :: Bool, -- refunded or revoked
+    offer :: Bool -- in a free trial or an introductory price
+  }
+  deriving (Show)
+
 noStoreVerifier :: StoreVerifier
-noStoreVerifier = StoreVerifier {verifyApple = Nothing, verifyGoogle = Nothing, acknowledgeGoogle = Nothing, verifyTimeout = 10000000}
+noStoreVerifier = StoreVerifier {verifyApple = Nothing, verifyGoogle = Nothing, acknowledgeGoogle = Nothing, checkSubscription = Nothing, verifyTimeout = 10000000}
 
 -- | Nothing for a payment no store made. Exceptions are not logged, since they can quote the receipt
 -- or, from Google, a URL holding the token.
@@ -75,7 +106,15 @@ toStoreReceipt :: StoreVerifier -> ServicePayment -> Maybe (Either StoreRefusal
 toStoreReceipt StoreVerifier {verifyApple, verifyGoogle, acknowledgeGoogle, verifyTimeout} = \case
   SPApple {jws} -> Just $ case appleTransactionRef jws of
     Nothing -> Left $ SRInvalid "names no transaction"
-    Just ref -> Right $ StoreReceipt (StoreTransactionRef PPApple ref) (maybe unconfigured (\verify -> offline $ verify jws) verifyApple) Nothing
+    Just ref ->
+      Right
+        StoreReceipt
+          { txRef = StoreTransactionRef PPApple ref,
+            receiptProductId = Nothing,
+            subscriptionRef = SubscriptionApple ref,
+            verifyReceipt = maybe unconfigured (\verify -> offline $ verify jws) verifyApple,
+            acknowledgeReceipt = Nothing
+          }
   SPGoogle {productId, token}
     -- the claim is the token's hash, so neither string may name any purchase but the one it claims,
     -- whatever path a verifier builds from them
@@ -83,11 +122,15 @@ toStoreReceipt StoreVerifier {verifyApple, verifyGoogle, acknowledgeGoogle, veri
     -- Play documents no token grammar, so this is our guess, and refusing to ask Play is not its verdict
     | not (googleToken token) -> Just $ Left $ SRUnreachable $ "a Play token this service will not send: " <> tokenShape token
     | otherwise ->
-        Just $ Right $
-          StoreReceipt
-            (StoreTransactionRef PPGoogle (googlePurchaseRef token))
-            (maybe unconfigured (\verify -> online "google verifier" $ verify productId token) verifyGoogle)
-            ((\acknowledge -> online "acknowledging: google" $ acknowledge productId token) <$> acknowledgeGoogle)
+        Just $
+          Right
+            StoreReceipt
+              { txRef = StoreTransactionRef PPGoogle (googlePurchaseRef token),
+                receiptProductId = Just productId,
+                subscriptionRef = SubscriptionGoogle token,
+                verifyReceipt = maybe unconfigured (\verify -> online "google verifier" $ verify productId token) verifyGoogle,
+                acknowledgeReceipt = (\acknowledge -> online "acknowledging: google" $ acknowledge productId token) <$> acknowledgeGoogle
+              }
   SPInvoice {} -> Nothing
   SPReceipt {} -> Nothing
   where
@@ -96,11 +139,21 @@ toStoreReceipt StoreVerifier {verifyApple, verifyGoogle, acknowledgeGoogle, veri
     offline verdict =
       (fromMaybe (Left $ SRVerifierFailed "apple verifier timed out") <$> timeout verifyTimeout (forced verdict))
         `catchOwn'` \_ -> pure $ Left $ SRVerifierFailed "apple verifier threw"
-    online what call =
-      (fromMaybe (Left $ SRUnreachable $ what <> " timed out") <$> timeout verifyTimeout (call >>= forced))
-        `catchOwn'` \_ -> pure $ Left $ SRUnreachable $ what <> " threw"
-    -- a verdict holding a thunk that throws would otherwise throw later, outside these handlers
-    forced = either (fmap Left . evaluate) (fmap Right . evaluate)
+    online = askStore verifyTimeout
+
+-- | Both stores are asked online about a subscription, so a throw or an overrun is no verdict.
+checkStoreSubscription :: StoreVerifier -> SubscriptionRef -> IO (Either StoreRefusal SubscriptionCheck)
+checkStoreSubscription StoreVerifier {checkSubscription, verifyTimeout} ref =
+  maybe (pure $ Left SRNotConfigured) (\check -> askStore verifyTimeout "subscription check" $ check ref) checkSubscription
+
+askStore :: Int -> Text -> IO (Either StoreRefusal a) -> IO (Either StoreRefusal a)
+askStore limit what call =
+  (fromMaybe (Left $ SRUnreachable $ what <> " timed out") <$> timeout limit (call >>= forced))
+    `catchOwn'` \_ -> pure $ Left $ SRUnreachable $ what <> " threw"
+
+-- | A verdict holding a thunk that throws would otherwise throw later, outside the handlers.
+forced :: Either StoreRefusal a -> IO (Either StoreRefusal a)
+forced = either (fmap Left . evaluate) (fmap Right . evaluate)
 
 googleProductId :: Text -> Bool
 googleProductId pid = case T.uncons pid of

docs/protocol/badges-rpc.md

@@ -33,7 +33,8 @@ The client never states what is signed. The tier is that of whatever funded the
 - `getBadgeInvoice` → `badgeInvoice` — prices the purchase for `badgeInfo` and `paymentVia` (`card` — Stripe; `crypto` — btc, xmr). The response holds the generic `invoice` — `invoiceId`, `price`, `discount`, the upgrade `credit`, `amount` = price − discount − credit, `currency`, `expiresAt`, and `paymentTo` (`url` for card; `address` and `cryptoAmount` for crypto) — beside the badge part, `badgeType` and `months`. `priceId` pins the price the client displayed; `offerId` selects a discounted duration, and its absence buys one month at that price. Price and offer status is checked here only: `deprecated` is still accepted, `disabled` is rejected; a badge type with no active price yields `product_unavailable`.
 - `redeemBadgeCode` → `badgeCredential` — redeems a code, records the credit, and issues the first credential, in one round trip. It carries `masterKey` and `code` and no `badgeRequest`: a code states no tier and no expiry, so the credential is what reports them. Errors: `code_invalid` for an unknown or malformed code, `code_used` when other keys have taken all its uses (a code has one use unless issued with more), `code_expired` past a redemption deadline.
 - `purchaseBadge` → `badgeCredential` — verifies the funding (`apple` JWS offline; `google` product id and token via the Publisher API; `invoice` against webhook-confirmed settlement, `payment_pending` until it lands; `receipt`), records the credit, and issues the first credential, in one round trip. It carries `masterKey` and no `badgeRequest`. The response `receipt` is the recovery bearer secret (model § recovery); the service stores its hash; lifetime badges receive none.
-  - A store transaction is claimed by its own id, read from the evidence before verification, and credited only when the verified transaction carries that same id. A receipt already credited to the signing key is answered from the record, without asking the store.
+  - A store transaction is claimed by its own id, read from the evidence before verification, and credited only when the verified transaction carries that same id. An App Store auto-renewable subscription is claimed by its `originalTransactionId`, which every renewal keeps, so all its charges fund one purchase; a Play subscription keeps its token across renewals already. A receipt already credited to the signing key is answered from the record, without asking the store.
+  - **Subscriptions.** A Play subscription is verified by reading the subscription itself, not by the one-time purchase read; an App Store one by its JWS offline, as any transaction, and then by reading the subscription's status. The latest charge the store reports is credited as a `charge` credit for the months of the plan it was for, dated to the store's billing period start, and the response carries `subscription`. A charge is credited only while its period runs, if it is not revoked, not in a free trial or introductory price, for a plan this service sells, and while the subscription has not ended. Otherwise nothing is written, and, since no record yet bounds how often the store is asked, `retryAfter` does: `payment_pending` with the usual 300 seconds for a period that has not started yet or a store that reports the payment pending; `receipt_invalid` for a Play subscription that has ended, since Play issues a new token when it is bought again; `payment_pending` with a day for everything a later charge on the same receipt could still change — a revoked charge, one in an offer, no charge yet, a period over while the store still retries, a plan this service does not sell, and an App Store subscription that has ended, which a resubscription under the same original id would continue. A charge whose period does not end after it starts is answered `internal`, and a deployment that cannot read a store's subscriptions answers `provider_not_configured`.
   - Errors: `receipt_invalid`, `test_purchase`, `payment_pending`, `provider_unavailable` — see the classes below; `receipt_used` when another key was credited with it; `product_unavailable` for a product this service does not price; `provider_not_configured` when this deployment has no verifier for the store. `receipt_invalid`, `test_purchase` and `receipt_used` are the only answers on which the client drops the keys it signed with and finishes the store transaction. Every other answer records nothing and leaves the purchase with its keys, to be presented again at the next trigger.
   - **Which class an answer belongs to.** The two mistakes do not cost the same, so when it is not certain, answer unreachable. `receipt_invalid` tells the client the purchase is dead: it drops the keys it signed with and finishes the store transaction — consumed on Play, finished on StoreKit — and nothing can present it again, so a buyer answered this by mistake has paid for a badge they can never receive. Answering unreachable by mistake costs one more verification request each time the app presents the purchase again, and a Play purchase left unacknowledged for three days is refunded to the buyer. It also locks the buyer out: the app offers no Buy while a purchase is open, so until that receipt settles the profile holding it cannot buy any badge, and an answer that never changes leaves it that way for good.
     - **Terminal**, `receipt_invalid` — only a verdict no later attempt could change: the store answered about this purchase and cannot change its mind, or the evidence can never verify. Anything that might answer differently later — the store's lag, an outage, this service's own misconfiguration or bug, a shape of evidence this service does not know yet — is one of the other classes.
@@ -42,7 +43,7 @@ The client never states what is signed. The tier is that of whatever funded the
     - **Unreachable**, `provider_unavailable` — the store was not asked or did not answer.
     - **Internal**, `internal` — this service's own failure, never the store's answer.
     - **App Store.** Apple is verified offline, so it has no "not yet".
-      - `receipt_invalid`: a JWS that is not three base64url parts or names no `transactionId`; an `x5c` certificate that is not base64; a JWS signature that is not 64 bytes; a leaf whose signature does not verify against the intermediate; a JWS signature that does not verify against the leaf; a transaction with a `revocationDate`, refunded or revoked.
+      - `receipt_invalid`: a JWS that is not three base64url parts or names no `transactionId`, or, for an auto-renewable subscription, no `originalTransactionId`; an `x5c` certificate that is not base64; a JWS signature that is not 64 bytes; a leaf whose signature does not verify against the intermediate; a JWS signature that does not verify against the leaf; a transaction with a `revocationDate`, refunded or revoked.
       - `test_purchase`: refused by the service after the verifier vouched for it, a `Sandbox` transaction.
       - `internal`: whatever this service's own configuration decides — an intermediate whose signature does not verify against the configured root, and another app's `bundleId`, since the configured root or bundle id may be the wrong one as likely as the receipt forged; a transaction from Xcode's StoreKit testing, which Xcode signs and not the App Store, so the configured root does not verify it; evidence in a shape this service does not know — a header that does not name `ES256` or carries no `x5c` of exactly three certificates, a certificate that does not decode, a leaf signature the intermediate's key cannot check, an algorithm or key type the library does not support, a chain without Apple's receipt-signing marker extensions, a leaf key that is not P-256, a payload with a missing or mistyped field or an unknown `environment`; the verifier's own failure or overrun; and, refused by the service, a verified transaction other than the one claimed, or a quantity other than 1.
       - `product_unavailable`: a product this service does not price — the verifier vouched for the transaction either way.
@@ -67,7 +68,7 @@ Always a new purchase under a new key, except store subscriptions, where the sto
 - Non-store: `getBadgeInvoice.upgrade` — `fromPurchaseKey`, the old purchase's `receipt`, `receiptSignature` binding the old key to the new, and the asserted old `balance`. The invoice returns the conversion `credit`; settlement records `debit(upgrade)` on the old purchase and the credit on the new.
 - Store one-time: an upgrade SKU at a fixed discounted price; `purchaseBadge.upgrade` — `fromPurchaseKey`, `receipt`, `receiptSignature` — proves eligibility (an unexpired cheaper badge), because the store cannot gate who buys the SKU.
 - Store subscription, app-led: the native subscription-group flow (Apple — immediate, with the store's prorated refund; Google — per replacement mode), then `upgradeBadgeSubscription` with the new evidence.
-- Store subscription, sheet-led, and every downgrade: the client sends nothing — the service discovers the change from provider state and notifications, and each renewal credits months of the charged badge type.
+- Store subscription, sheet-led, and every downgrade: the client sends nothing — the service discovers the change from provider state and notifications. Until tier changes are supported, a charge for another badge type is recorded and not granted.
 
 ## Catalog
 
@@ -77,7 +78,9 @@ Always a new purchase under a new key, except store subscriptions, where the sto
 
 The ledger is written by the service alone (model §3); the client keeps a verbatim replica and computes the effective balance from its last entry and the time. Month boundaries are counted from `balanceAnchorTs`, the start of the current run of months, and not from `balanceStartTs` — counting from the moving start would compound the day-of-month clipping of a short month, so a run beginning 31 January would reach 28 February and never return to the 31st. The service sets a new anchor only where a lapsed run restarts; months granted while coverage still runs extend it on its existing anchor.
 
-`statement` — `entries`, and `previousEntryId` when they attach after an entry the client holds; its absence marks entries that attach to nothing. Each entry states `entryId`, the signed `changeMonths`, the resulting `balanceMonths`, `balanceStartTs`, `balanceAnchorTs`, and `balanceBadgeType`, `wasPausedSince` on the entry ending a pause, `createdAt`, and `entryType` — `credit`: `payment {invoiceId?}`, `code`, `charge {chargeId}`, `support`, `transferIn {fromPurchaseKey}`, `opening`; `debit`: `refund`, `upgrade {toPurchaseKey}`, `transferOut {toPurchaseKey}`, `support`, `badge`, `lapse`. A code grant is `code` rather than `payment` with no `invoiceId`: the invoice of a code belongs to whoever bought it, and the redeemer's ledger must never reference it. An unknown type is stored as received and decoded after an app upgrade.
+`statement` — `entries`, and `previousEntryId` when they attach after an entry the client holds; its absence marks entries that attach to nothing. Each entry states `entryId`, the signed `changeMonths`, the resulting `balanceMonths`, `balanceStartTs`, `balanceAnchorTs`, and `balanceBadgeType`, `wasPausedSince` on the entry ending a pause, `createdAt`, and `entryType` — `credit`: `payment {invoiceId?}`, `code`, `charge {chargeId}`, `support`, `transferIn {fromPurchaseKey}`, `opening`; `debit`: `refund`, `upgrade {toPurchaseKey}`, `transferOut {toPurchaseKey}`, `support`, `badge`, `lapse`. A code grant is `code` rather than `payment` with no `invoiceId`: the invoice of a code belongs to whoever bought it, and the redeemer's ledger must never reference it. A `charge` credit is dated to the store's billing period start, its `createdAt`, so coverage follows the store's periods and the entry is its grant re-run at that time. An unknown type is stored as received and decoded after an app upgrade.
+
+`subscription` — present exactly when a store subscription funds the purchase, as the service last read the store: `renewing`; `cancelled`, auto-renewal is off and the paid period still runs; `billingRetry`, a charge failed and the store is retrying it; `ended`, no charge will come. A client reads any other value as not ended.
 
 `balance` — `lastEntry`, the client's last entry, asserting the position and the months it believes it holds.
 

docs/protocol/badges-rpc.schema.json

@@ -230,7 +230,8 @@
           "metadata": {"comment": "a redeemed code; its invoice belongs to the buyer, not the redeemer"}
         },
         "charge": {
-          "properties": {"chargeId": {"type": "string"}}
+          "properties": {"chargeId": {"type": "string"}},
+          "metadata": {"comment": "a store subscription's charge, dated (createdAt) to the store's billing period start"}
         },
         "support": {
           "optionalProperties": {}
@@ -375,6 +376,10 @@
             "receipt": {
               "type": "string",
               "metadata": {"comment": "not provided for lifetime badges"}
+            },
+            "subscription": {
+              "type": "string",
+              "metadata": {"comment": "SubscriptionState: renewing, cancelled, billingRetry, ended; any other value is read as not ended. Present exactly when a store subscription funds the purchase"}
             }
           }
         },

tests/BadgeTests.hs

@@ -1008,7 +1008,7 @@ testGoogleTokenPath = do
   mapM_ (\t -> unsent t `shouldBe` True) ["a/b", "../x", "t?x", "t#x", "t x", ""]
 
 uncalledVerifier :: StoreVerifier
-uncalledVerifier = StoreVerifier {verifyApple = Nothing, verifyGoogle = Just $ \_ _ -> error "verifier called", acknowledgeGoogle = Nothing, verifyTimeout = 500000}
+uncalledVerifier = StoreVerifier {verifyApple = Nothing, verifyGoogle = Just $ \_ _ -> error "verifier called", acknowledgeGoogle = Nothing, checkSubscription = Nothing, verifyTimeout = 500000}
 
 validPlayToken :: T.Text
 validPlayToken = "fake-play-token.AO-J1Oz9x2kqE7wYt3"

tests/Bots/BadgeService/BotTests.hs

@@ -19,8 +19,8 @@ import Bots.BadgeService.FakeStore
 import BadgeService.Options
 import BadgeService.Service
 import BadgeService.Store (IssuedCode (..), getBadgeCode)
-import BadgeService.Store.Invoices (markCodePaid)
-import BadgeService.StoreReceipts (StoreRefusal (..), StoreVerifier (..), noStoreVerifier)
+import BadgeService.Store.Invoices (markCodePaid, truncateToSecond)
+import BadgeService.StoreReceipts (StoreCharge (..), StoreRefusal (..), StoreVerifier (..), SubscriptionCheck (..), SubscriptionRef (..), noStoreVerifier)
 import Simplex.Messaging.Agent.Store.DB (Binary (..))
 import qualified Simplex.Messaging.Agent.Store.DB as DB
 import ChatClient
@@ -59,7 +59,7 @@ import Simplex.Chat.Controller (ChatConfig (..), ChatController (..), ChatError
 import Simplex.Chat.Core (sendChatCmdStr)
 import Simplex.Chat.Options (ChatOpts (..), CoreChatOpts (..))
 import Simplex.Chat.Options.DB
-import Simplex.Chat.PaymentService (ServicePayment (..))
+import Simplex.Chat.PaymentService (ServicePayment (..), googlePurchaseRef)
 import Simplex.Chat.PaymentService.Types (InvoiceId (..))
 import Simplex.Chat.Store.Badges (getNextHeldStoreReceipt)
 import Simplex.Messaging.Agent (disposeAgentClient)
@@ -175,6 +175,9 @@ badgeServiceTests = do
       it "should delete a month-old record that will fund no badge, and keep held and credited ones" testStoreReceiptCleanup
       it "should keep a receipt whose attempt throws" testStoreReceiptAttemptThrows
       it "should credit a held receipt after the app restarts" testStoreReceiptAfterRestart
+  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
 
 badgeBotName :: Text
 badgeBotName = "SimpleX Badges"
@@ -1755,7 +1758,7 @@ testStoreAcknowledgesBeforeCrediting ps = do
     let purchase payment = serviceCmd env purchaseKey $ purchaseCmd masterKey payment
     unsettled <- purchase $ googlePayment "badge_supporter_01" googlePendingToken
     fst (refusalOf unsettled) `shouldBe` BSEPaymentPending
-    unpriced <- purchase $ googlePayment "subscr_badge_supporter_01" googleSubscriptionToken
+    unpriced <- purchase $ googlePayment "badge_unknown_01" googleUnknownProductToken
     refusalOf unpriced `shouldBe` (BSEProductUnavailable, Nothing)
     readIORef acknowledged `shouldReturn` []
     writeIORef acknowledgement $ Left $ SRUnreachable "acknowledging: fake store is down"
@@ -1777,9 +1780,9 @@ testStoreUnknownProduct :: HasCallStack => TestParams -> IO ()
 testStoreUnknownProduct ps =
   withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsController = cc} -> do
     (purchaseKey, masterKey) <- newPurchaseKeys
-    -- a real purchase of a subscription, whose renewals nothing adds to a badge yet
-    subscription <- serviceCmd env purchaseKey $ purchaseCmd masterKey $ googlePayment "subscr_badge_supporter_01" googleSubscriptionToken
-    refusalOf subscription `shouldBe` (BSEProductUnavailable, Nothing)
+    -- a real purchase the store vouches for, of a product this service does not price
+    unpriced <- serviceCmd env purchaseKey $ purchaseCmd masterKey $ googlePayment "badge_unknown_01" googleUnknownProductToken
+    refusalOf unpriced `shouldBe` (BSEProductUnavailable, Nothing)
     nothingPurchased cc
 
 testStoreUpgradeRefused :: HasCallStack => TestParams -> IO ()
@@ -1934,6 +1937,103 @@ testStoreUnsentProductId ps = do
     verifications `shouldReturn` 0
     nothingPurchased cc
 
+subscriptionPlay :: ServicePayment
+subscriptionPlay = googlePayment "subscr_badge_supporter_01" googleSubscriptionToken
+
+subscriptionCheck :: SubscriptionState -> Maybe StoreCharge -> SubscriptionCheck
+subscriptionCheck subscriptionState latestCharge = SubscriptionCheck {subscriptionState, testSubscription = False, latestCharge}
+
+storeCharge :: Text -> UTCTime -> Integer -> StoreCharge
+storeCharge planId periodStart months =
+  StoreCharge {chargeRef = "GPA.3301-1234-5678-90123", planId, periodStart, periodEnd = addMonths months periodStart, chargePaid = Nothing, revoked = False, offer = False}
+
+subscriptionOf :: HasCallStack => BadgeServiceResponse -> Maybe SubscriptionState
+subscriptionOf = \case
+  BSPBadgeCredential {subscription} -> subscription
+  r -> error $ "expected badgeCredential, got " <> show (J.toJSON r)
+
+createdAtOf :: StatementEntry -> UTCTime
+createdAtOf StatementEntry {createdAt} = createdAt
+
+-- | The ledger stores whole seconds.
+serviceNow :: BadgeServiceEnv -> IO UTCTime
+serviceNow BadgeServiceEnv {bsClock} = truncateToSecond <$> testClockTime bsClock
+
+subscriptionPayments :: ChatController -> IO [(Text, Text, Maybe Text, Maybe Text)]
+subscriptionPayments ChatController {chatStore} =
+  withTransaction chatStore $ \db ->
+    DB.query_ db "SELECT provider, provider_ref, subscription_state, provider_token FROM sx_badge_service_payments ORDER BY provider"
+
+testSubscriptionPurchase :: HasCallStack => TestParams -> IO ()
+testSubscriptionPurchase ps =
+  withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsController = cc, bsStore = store@FakeStore {appleSubscriptionJWS, appleSandboxSubscriptionJWS}} -> do
+    now <- serviceNow env
+    let periodStart = addUTCTime (-3600) now
+        changes = map (\e -> let (c, m, _) = entryOf e in (c, m)) . fst . statementOf
+    setSubscription store (SubscriptionGoogle googleSubscriptionToken) $ subscriptionCheck SSRenewing $ Just $ storeCharge "subscr-badge-supporter-month-02" periodStart 1
+    (purchaseKey, masterKey) <- newPurchaseKeys
+    purchased <- serviceCmd env purchaseKey $ purchaseCmd masterKey subscriptionPlay
+    map entryTag (fst $ statementOf purchased) `shouldBe` ["charge", "badge"]
+    changes purchased `shouldBe` [(1, 1), (-1, 0)]
+    -- the month is granted at the store's period start, not when the receipt arrived
+    map createdAtOf (take 1 $ fst $ statementOf purchased) `shouldBe` [periodStart]
+    badgeTypeOf purchased `shouldBe` Just BTSupporter
+    subscriptionOf purchased `shouldBe` Just SSRenewing
+    rowCount cc "sx_badge_service_subscription_charges" `shouldReturn` 1
+    rowCount cc "sx_badge_service_badge_ledger WHERE charge_id IS NOT NULL" `shouldReturn` 1
+    subscriptionPayments cc `shouldReturn` [("google", googlePurchaseRef googleSubscriptionToken, Just "renewing", Just googleSubscriptionToken)]
+    checks <- subscriptionChecks store
+    replayed <- serviceCmd env purchaseKey $ purchaseCmd masterKey subscriptionPlay
+    credentialOf replayed `shouldBe` credentialOf purchased
+    subscriptionOf replayed `shouldBe` Just SSRenewing
+    subscriptionChecks store `shouldReturn` checks
+    (otherKey, otherMasterKey) <- newPurchaseKeys
+    refusalOf <$> serviceCmd env otherKey (purchaseCmd otherMasterKey subscriptionPlay) `shouldReturn` (BSEReceiptUsed, Nothing)
+    -- an annual Apple subscription is claimed by its original id, which the store is asked about
+    setSubscription store (SubscriptionApple appleSubscriptionOriginalId) $ subscriptionCheck SSRenewing $ Just $ storeCharge "SUBSCR_BADGE_SUPPORTER_YEAR_01" periodStart 12
+    (appleKey, appleMasterKey) <- newPurchaseKeys
+    apple <- serviceCmd env appleKey $ purchaseCmd appleMasterKey SPApple {jws = appleSubscriptionJWS}
+    changes apple `shouldBe` [(12, 12), (-1, 11)]
+    subscriptionOf apple `shouldBe` Just SSRenewing
+    take 1 <$> subscriptionPayments cc `shouldReturn` [("apple", appleSubscriptionOriginalId, Just "renewing", Nothing)]
+    -- a test purchase is named, on the store's word for Play, and before the store is asked for Apple
+    let testToken = "fake-play-token-subscription-test.AO-J1Os2q5djX0pRm6"
+    setSubscription store (SubscriptionGoogle testToken) SubscriptionCheck {subscriptionState = SSRenewing, testSubscription = True, latestCharge = Just $ storeCharge "subscr-badge-supporter-month-02" periodStart 1}
+    (testKey, testMasterKey) <- newPurchaseKeys
+    refusalOf <$> serviceCmd env testKey (purchaseCmd testMasterKey $ googlePayment "subscr_badge_supporter_01" testToken) `shouldReturn` (BSETestPurchase, Nothing)
+    sandboxChecks <- subscriptionChecks store
+    refusalOf <$> serviceCmd env testKey (purchaseCmd testMasterKey SPApple {jws = appleSandboxSubscriptionJWS}) `shouldReturn` (BSETestPurchase, Nothing)
+    subscriptionChecks store `shouldReturn` sandboxChecks
+    rowCount cc "sx_badge_service_badge_purchases" `shouldReturn` 2
+
+testSubscriptionPurchaseNotGrantable :: HasCallStack => TestParams -> IO ()
+testSubscriptionPurchaseNotGrantable ps =
+  withBadgeServiceEnv ps $ \env@BadgeServiceEnv {bsController = cc, bsStore = store@FakeStore {appleSubscriptionJWS}} -> do
+    now <- serviceNow env
+    (purchaseKey, masterKey) <- newPurchaseKeys
+    let monthlyFrom start = storeCharge "subscr-badge-supporter-month-02" start 1
+        monthly = monthlyFrom (addUTCTime (-3600) now)
+        answer ref payment checked = do
+          setSubscription store ref checked
+          refusalOf <$> serviceCmd env purchaseKey (purchaseCmd masterKey payment)
+        play = answer (SubscriptionGoogle googleSubscriptionToken) subscriptionPlay
+        aDay = Just 86400
+    play (subscriptionCheck SSRenewing $ Just $ monthlyFrom $ addUTCTime 3600 now) `shouldReturn` (BSEPaymentPending, Just 300)
+    -- Play gives a subscription bought again a new token, so this one can never be credited
+    play (subscriptionCheck SSEnded $ Just monthly) `shouldReturn` (BSEReceiptInvalid, Nothing)
+    -- a later charge could still credit this receipt
+    play (subscriptionCheck SSRenewing $ Just monthly {revoked = True}) `shouldReturn` (BSEPaymentPending, aDay)
+    play (subscriptionCheck SSRenewing $ Just monthly {offer = True}) `shouldReturn` (BSEPaymentPending, aDay)
+    play (subscriptionCheck SSBillingRetry Nothing) `shouldReturn` (BSEPaymentPending, aDay)
+    play (subscriptionCheck SSBillingRetry $ Just $ monthlyFrom $ addMonths (-2) now) `shouldReturn` (BSEPaymentPending, aDay)
+    play (subscriptionCheck SSRenewing $ Just $ storeCharge "subscr-badge-supporter-month-99" (addUTCTime (-3600) now) 1) `shouldReturn` (BSEPaymentPending, aDay)
+    -- an Apple resubscription keeps the original id, so an ended subscription may yet be credited
+    answer (SubscriptionApple appleSubscriptionOriginalId) SPApple {jws = appleSubscriptionJWS} (subscriptionCheck SSEnded $ Just $ storeCharge "SUBSCR_BADGE_SUPPORTER_MONTH_01" (addUTCTime (-3600) now) 1)
+      `shouldReturn` (BSEPaymentPending, aDay)
+    play (subscriptionCheck SSRenewing $ Just monthly {periodEnd = addUTCTime (-7200) now}) `shouldReturn` (BSEInternal, Nothing)
+    nothingPurchased cc
+    rowCount cc "sx_badge_service_subscription_charges" `shouldReturn` 0
+
 testPurchaseBadge :: HasCallStack => TestParams -> IO ()
 testPurchaseBadge ps =
   withBadgeServiceEnv ps $ \BadgeServiceEnv {bsClientCfg, bsController = cc} ->

tests/Bots/BadgeService/FakeStore.hs

@@ -16,6 +16,10 @@ module Bots.BadgeService.FakeStore
     googleThrowingToken,
     googleHangingToken,
     googleSubscriptionToken,
+    googleUnknownProductToken,
+    appleSubscriptionOriginalId,
+    setSubscription,
+    subscriptionChecks,
     googlePayment,
     unsignedJWS,
   )
@@ -28,9 +32,11 @@ import qualified Data.Aeson as J
 import qualified Data.ByteString.Base64.URL as B64U
 import qualified Data.ByteString.Char8 as B
 import qualified Data.ByteString.Lazy as LB
-import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef, writeIORef)
+import Data.IORef (IORef, atomicModifyIORef', modifyIORef', newIORef, readIORef, writeIORef)
+import qualified Data.Map.Strict as M
+import Data.Maybe (fromMaybe)
 import Data.Text (Text)
-import Simplex.Chat.PaymentService (ServicePayment (..), googlePurchaseRef)
+import Simplex.Chat.PaymentService (ServicePayment (..), appleTransactionRef, googlePurchaseRef)
 import Simplex.Chat.PaymentService.Types (CurrencyAmount (..))
 import Simplex.Messaging.Util (safeDecodeUtf8)
 import System.FilePath ((</>))
@@ -47,8 +53,14 @@ data FakeStore = FakeStore
     appleThrowingJWS :: Text,
     appleMisnamedJWS :: Text,
     appleQuantityJWS :: Text,
+    -- a renewal of the subscription appleSubscriptionOriginalId names, and the same from Apple's Sandbox
+    appleSubscriptionJWS :: Text,
+    appleSandboxSubscriptionJWS :: Text,
     pendingSettled :: IORef Bool,
     googleDown :: IORef Bool,
+    -- what the store answers about each subscription: Apple's by original id, Google's by token
+    subscriptions :: IORef (M.Map (Either Text Text) SubscriptionCheck),
+    subscriptionCheckCount :: IORef Int,
     fakeVerifier :: StoreVerifier
   }
 
@@ -60,20 +72,30 @@ newFakeStore = do
   let appleThrowingJWS = unsignedJWS "{\"transactionId\":\"2000000812345679\",\"productId\":\"BADGE_SUPPORTER_01\"}"
       appleMisnamedJWS = unsignedJWS "{\"transactionId\":\"2000000812345698\",\"productId\":\"BADGE_SUPPORTER_01\"}"
       appleQuantityJWS = unsignedJWS "{\"transactionId\":\"2000000812345697\",\"productId\":\"BADGE_SUPPORTER_01\"}"
+      appleSubscriptionJWS = subscriptionJWS "2000000812345681"
+      appleSandboxSubscriptionJWS = subscriptionJWS "2000000812345682"
   pendingSettled <- newIORef False
   googleDown <- newIORef False
+  subscriptions <- newIORef M.empty
+  subscriptionCheckCount <- newIORef 0
   let appleReceipts =
         [ (appleSupporterJWS, appleTransaction "2000000812345671" "BADGE_SUPPORTER_01" False 700),
           (appleLegendJWS, appleTransaction "2000000812345672" "BADGE_LEGEND_01" False 7000),
           (appleSandboxJWS, appleTransaction "2000000812345673" "BADGE_LEGEND_01" True 7000),
           -- a verifier vouching for another transaction than the one the evidence names
           (appleMisnamedJWS, appleTransaction "2000000812345671" "BADGE_SUPPORTER_01" False 700),
-          (appleQuantityJWS, (appleTransaction "2000000812345697" "BADGE_SUPPORTER_01" False 1400) {quantity = 2})
+          (appleQuantityJWS, (appleTransaction "2000000812345697" "BADGE_SUPPORTER_01" False 1400) {quantity = 2}),
+          -- vouched by the ref the claim reads, the subscription's original id
+          (appleSubscriptionJWS, appleSubscription appleSubscriptionJWS False),
+          (appleSandboxSubscriptionJWS, appleSubscription appleSandboxSubscriptionJWS True)
         ]
       verifyApple jws
         | jws == appleThrowingJWS = error "fake verifier bug"
         | otherwise = maybe (Left $ SRInvalid "not a fake receipt") Right $ lookup jws appleReceipts
       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
   pure
     FakeStore
       { appleSupporterJWS,
@@ -82,14 +104,41 @@ newFakeStore = do
         appleThrowingJWS,
         appleMisnamedJWS,
         appleQuantityJWS,
+        appleSubscriptionJWS,
+        appleSandboxSubscriptionJWS,
         pendingSettled,
         googleDown,
-        fakeVerifier = StoreVerifier {verifyApple = Just verifyApple, verifyGoogle = Just verifyGoogle, acknowledgeGoogle = Nothing, verifyTimeout = 500000}
+        subscriptions,
+        subscriptionCheckCount,
+        fakeVerifier = StoreVerifier {verifyApple = Just verifyApple, verifyGoogle = Just verifyGoogle, acknowledgeGoogle = Nothing, checkSubscription = Just checkSubscription, verifyTimeout = 500000}
       }
   where
     fixtureJWS name = unsignedJWS <$> B.readFile (fixtureDir </> name)
     appleTransaction transactionRef productId testPurchase cents =
       VerifiedStoreTransaction {transactionRef, productId, quantity = 1, testPurchase, paid = Just (CurrencyAmount cents, "USD")}
+    subscriptionJWS transactionId =
+      unsignedJWS $
+        LB.toStrict $
+          J.encode $
+            J.object
+              [ "transactionId" J..= (transactionId :: Text),
+                "originalTransactionId" J..= appleSubscriptionOriginalId,
+                "type" J..= ("Auto-Renewable Subscription" :: Text),
+                "productId" J..= ("SUBSCR_BADGE_SUPPORTER_MONTH_01" :: Text)
+              ]
+    appleSubscription jws testPurchase =
+      VerifiedStoreTransaction {transactionRef = fromMaybe "" (appleTransactionRef jws), productId = "SUBSCR_BADGE_SUPPORTER_MONTH_01", quantity = 1, testPurchase, paid = Just (CurrencyAmount 700, "USD")}
+
+subscriptionKey :: SubscriptionRef -> Either Text Text
+subscriptionKey = \case
+  SubscriptionApple originalId -> Left originalId
+  SubscriptionGoogle token -> Right token
+
+setSubscription :: FakeStore -> SubscriptionRef -> SubscriptionCheck -> IO ()
+setSubscription FakeStore {subscriptions} ref checked = modifyIORef' subscriptions $ M.insert (subscriptionKey ref) checked
+
+subscriptionChecks :: FakeStore -> IO Int
+subscriptionChecks FakeStore {subscriptionCheckCount} = readIORef subscriptionCheckCount
 
 googleVerdict :: IORef Bool -> IORef Bool -> Text -> Text -> IO (Either StoreRefusal VerifiedStoreTransaction)
 googleVerdict pendingSettled googleDown productId token =
@@ -97,7 +146,7 @@ googleVerdict pendingSettled googleDown productId token =
     True -> pure $ Left $ SRUnreachable "fake store is down"
     False
       | (productId, token) == ("badge_supporter_01", googleSupporterToken) -> pure $ Right purchased
-      | (productId, token) == ("subscr_badge_supporter_01", googleSubscriptionToken) -> pure $ Right purchased
+      | (productId, token) == ("badge_unknown_01", googleUnknownProductToken) -> pure $ Right purchased
       | (productId, token) == ("badge_supporter_01", googlePendingToken) -> do
           settled <- readIORef pendingSettled
           pure $ if settled then Right purchased else Left SRPending
@@ -124,13 +173,17 @@ settlePending FakeStore {pendingSettled} = writeIORef pendingSettled True
 setGoogleDown :: FakeStore -> Bool -> IO ()
 setGoogleDown FakeStore {googleDown} = writeIORef googleDown
 
-googleSupporterToken, googlePendingToken, googleUnreachableToken, googleThrowingToken, googleHangingToken, googleSubscriptionToken :: Text
+googleSupporterToken, googlePendingToken, googleUnreachableToken, googleThrowingToken, googleHangingToken, googleSubscriptionToken, googleUnknownProductToken :: Text
 googleSupporterToken = "fake-play-token-supporter.AO-J1Oz9x2kqE7wYt3"
 googlePendingToken = "fake-play-token-pending.AO-J1Oy8w1jpD6vXs2"
 googleUnreachableToken = "fake-play-token-unreachable.AO-J1Ox7v0ioC5uWr1"
 googleThrowingToken = "fake-play-token-throwing.AO-J1Ov5t8gmA3sUp9"
 googleHangingToken = "fake-play-token-hanging.AO-J1Ou4s7flZ2rTo8"
 googleSubscriptionToken = "fake-play-token-subscription.AO-J1Ow6u9hnB4tVq0"
+googleUnknownProductToken = "fake-play-token-unknown-product.AO-J1Ot3r6ekY1qSn7"
+
+appleSubscriptionOriginalId :: Text
+appleSubscriptionOriginalId = "2000000812345680"
 
 googlePayment :: Text -> Text -> ServicePayment
 googlePayment productId token = SPGoogle {productId, token}

tests/Bots/BadgeService/WebTests.hs

@@ -14,7 +14,8 @@ import BadgeService.Poller
 import BadgeService.Providers
 import BadgeService.Providers.BTCPay (btcpayProvider, listPageSize, maxListPages)
 import BadgeService.Providers.Stripe (stripeProvider)
-import BadgeService.Store (KeyPurchase (..), KeyRedemption (..), ManagedGroup (..), NewCodePurchase (..), NewStorePurchase (..), RevokeResult (..), appendLedgerPlan, createCodePurchase, createStorePurchase, getCodePurchaseForKey, getLedgerEntries, getLedgerTip, getManagedGroup, insertBadgeCode, insertManagedGroup, markOwnerBootstrapped, revokeCode)
+import BadgeService.Store (KeyPurchase (..), KeyRedemption (..), ManagedGroup (..), NewCodePurchase (..), NewStorePurchase (..), RevokeResult (..), appendLedgerPlan, createCodePurchase, createStorePurchase, getCodePurchaseForKey, getLedgerEntries, getLedgerTip, getManagedGroup, insertBadgeCode, insertManagedGroup, insertSubscriptionCharge, markOwnerBootstrapped, revokeCode)
+import BadgeService.StoreReceipts (StoreCharge (..))
 import BadgeService.Store.Invoices
 import BadgeService.Waiters (awaitStatus, newWaiters, publish, waitingCount)
 import BadgeService.Web.Server
@@ -60,7 +61,7 @@ import Network.HTTP.Types.Status (statusCode)
 import qualified Network.Wai.Handler.Warp as Warp
 import Simplex.Chat.Badges (BadgeCredential (..), BadgeInfo (..), BadgeMasterKey (..), BadgeType (..))
 import Simplex.Chat.Badges.Ledger (addMonths, emptyEntry, grantEntry)
-import Simplex.Chat.Badges.Service (BadgeOffer (..), BadgePrice (..), StatementCreditType (..))
+import Simplex.Chat.Badges.Service (BadgeOffer (..), BadgePrice (..), StatementCreditType (..), SubscriptionState (..))
 import Simplex.Chat.Badges.Types (BadgeCodePaymentStatus (..), BadgeItemStatus (..), BadgeOfferId (..), BadgePriceId (..), OfferDiscount (..))
 import Simplex.Chat.PaymentService.Types (CryptoCurrency (..), CurrencyAmount (..), InvoiceId (..), InvoiceStatus (..), PaymentProvider (..), PaymentStatus (..), ServicePaymentDestination (..), ServicePaymentMethod (..))
 import Simplex.Messaging.Agent.Store.Common (DBStore (..), withConnection, withTransaction)
@@ -729,12 +730,9 @@ testChargeCreditRoundTrip = withServiceStore $ \st -> do
   now <- truncateToSecond <$> getCurrentTime
   (purchaseKey, masterKey) <- newPurchaseKeys
   Just purchaseId <- withTransaction st $ \db ->
-    createStorePurchase db NewStorePurchase {paymentId = "pay1", provider = PPApple, providerRef = "2000000812345671", paid = Nothing, purchaseKey, masterKey, badgeType = BTSupporter} now
-  withConnection st $ \db ->
-    DB.execute
-      db
-      "INSERT INTO sx_badge_service_subscription_charges (charge_id, payment_id, provider_charge_ref, plan_id, period_start, period_end, created_at) VALUES (?,?,?,?,?,?,?)"
-      ("ch1" :: Text, "pay1" :: Text, "2000000812345672" :: Text, "SUBSCR_BADGE_SUPPORTER_MONTH_01" :: Text, now, addMonths 1 now, now)
+    createStorePurchase db NewStorePurchase {paymentId = "pay1", provider = PPApple, providerRef = "2000000812345671", paid = Nothing, purchaseKey, masterKey, badgeType = BTSupporter, subscriptionState = Just SSRenewing, providerToken = Nothing} now
+  withTransaction st $ \db ->
+    insertSubscriptionCharge db "pay1" "ch1" StoreCharge {chargeRef = "2000000812345672", planId = "SUBSCR_BADGE_SUPPORTER_MONTH_01", periodStart = now, periodEnd = addMonths 1 now, chargePaid = Nothing, revoked = False, offer = False} now
   let charge = grantEntry now "e1" 1 (SCCharge "ch1") (emptyEntry now BTSupporter)
   withTransaction st $ \db -> appendLedgerPlan db purchaseId Nothing [charge] Nothing
   withTransaction st (\db -> getLedgerEntries db purchaseId 0) >>= (`shouldBe` Just [J.toJSON charge]) . fmap (map J.toJSON)