Merge branch 'master' into names

# Conflicts:
#	cabal.project
#	scripts/nix/sha256map.nix
#	simplex-chat.cabal
#	src/Simplex/Chat/Store/Postgres/Migrations.hs
#	src/Simplex/Chat/Store/SQLite/Migrations.hs
#	src/Simplex/Chat/Store/SQLite/Migrations/chat_query_plans.txt

src/Simplex/Chat.hs

@@ -75,6 +75,8 @@ defaultChatConfig =
       badgeCurrentTime = getCurrentTime,
       badgeRetryInterval = RetryInterval {initialInterval = 30_000000, increaseAfter = 0, maxInterval = 3600_000000},
       badgeConsecutiveRetries = 3,
+      badgeDevRequests = False,
+      badgeDevRequestInterval = Nothing,
       confirmMigrations = MCConsole,
       -- this property should NOT use operator = Nothing
       -- non-operator servers can be passed via options

src/Simplex/Chat/Badges.hs

@@ -29,6 +29,7 @@ module Simplex.Chat.Badges
     defaultFileSizeLimits,
     maxXFTPFileSize,
     maxSndXFTPFileSize,
+    badgeGraceInterval,
     badgeSndGraceInterval,
     badgeServerCredential,
     maxFileSizeSupporter,

src/Simplex/Chat/Badges/Ledger.hs

@@ -8,18 +8,22 @@ module Simplex.Chat.Badges.Ledger
     lapseEntry,
     grantEntry,
     issueEntry,
+    debitEntry,
+    chargeEntries,
     paidThrough,
     balanceChecked,
     addMonths,
     endOfMondayAfter,
     entryTypeColumns,
+    EntryReferences (..),
+    noEntryReferences,
     entryTypeFromColumns,
     creditTypeTag,
     debitTypeTag,
   )
 where
 
-import Data.Maybe (fromMaybe)
+import Data.Maybe (fromMaybe, maybeToList)
 import Data.Text (Text)
 import Data.Time.Calendar (addDays, addGregorianMonthsClip, toGregorian)
 import Data.Time.Calendar.WeekDate (toWeekDate)
@@ -27,6 +31,7 @@ import Data.Time.Clock (NominalDiffTime, UTCTime (..), addUTCTime)
 import Simplex.Chat.Badges (BadgeType)
 import Simplex.Chat.Badges.Service (StatementCreditType (..), StatementDebitType (..), StatementEntry (..), StatementEntryType (..))
 import Simplex.Chat.PaymentService.Types (InvoiceId)
+import qualified Simplex.Messaging.Crypto as C
 
 -- The calendar difference overshoots by at most one month, so one comparison settles it.
 monthsBetween :: UTCTime -> UTCTime -> Integer
@@ -89,16 +94,17 @@ lapseEntry t entryId e@StatementEntry {balanceMonths}
     k = elapsedMonths t e
 
 -- | New months start where the current coverage ends, or at t if it has already lapsed - so they
--- are neither spent on the month still running nor backdated over a gap.
-grantEntry :: UTCTime -> Text -> Int -> StatementCreditType -> StatementEntry -> StatementEntry
-grantEntry t entryId n credit e@StatementEntry {balanceMonths, balanceStartTs}
-  -- only a lapsed run restarts; topping up before coverage ends continues the run on its anchor,
-  -- so buying a month at a time keeps the same day of month as buying a year at once
-  | lapsed = credited {balanceMonths = n, balanceStartTs = t, balanceAnchorTs = t}
+-- are neither spent on the month still running nor backdated over a gap. Months of another tier
+-- replace the balance, so they are granted only onto an empty one.
+grantEntry :: UTCTime -> Text -> BadgeType -> Int -> StatementCreditType -> StatementEntry -> StatementEntry
+grantEntry t entryId badgeType n credit e@StatementEntry {balanceMonths, balanceStartTs, balanceBadgeType}
+  -- only a lapsed run, or one of another tier, restarts; topping up before coverage ends continues the
+  -- run on its anchor, so buying a month at a time keeps the same day of month as buying a year at once
+  | lapsed || badgeType /= balanceBadgeType = credited {balanceMonths = n, balanceStartTs = t, balanceAnchorTs = t}
   | otherwise = credited {balanceMonths = balanceMonths + n}
   where
     lapsed = balanceMonths == 0 && t > balanceStartTs
-    credited = e {entryId, createdAt = t, changeMonths = n, entryType = SECredit credit}
+    credited = e {entryId, createdAt = t, changeMonths = n, balanceBadgeType = badgeType, entryType = SECredit credit}
 
 -- | The period issued runs from the previous entry's balanceStartTs to this one's.
 issueEntry :: UTCTime -> Text -> StatementEntry -> Maybe StatementEntry
@@ -115,6 +121,31 @@ issueEntry t entryId e@StatementEntry {balanceMonths, balanceStartTs}
             entryType = SEDebit SDBadge
           }
 
+-- | Takes every remaining month, even none; the balance start and anchor stay, so coverage ends where the issued months end.
+debitEntry :: UTCTime -> Text -> StatementDebitType -> StatementEntry -> StatementEntry
+debitEntry t entryId debit e@StatementEntry {balanceMonths} =
+  e {entryId, createdAt = t, changeMonths = negate balanceMonths, balanceMonths = 0, entryType = SEDebit debit}
+
+-- | A store charge's rows, dated to its billing period start so coverage follows the store's periods, or to
+-- the tip when the period started before it was written, so createdAt never decreases: a lapse to that date,
+-- the grant, and a lapse to now; the caller issues at now.
+-- A charge of another tier ends the run with an upgrade debit naming ownKey before its grant restarts it.
+chargeEntries :: UTCTime -> UTCTime -> BadgeType -> Int -> C.PublicKeyEd25519 -> Text -> (Text, Text, Text, Text) -> StatementEntry -> [StatementEntry]
+chargeEntries periodStart now badgeType months ownKey chargeId (lapseBeforeId, debitId, grantId, lapseSinceId) tip@StatementEntry {balanceBadgeType, createdAt} =
+  maybeToList lapsedBefore <> maybeToList debited <> [granted] <> maybeToList lapsedSince
+  where
+    otherTier = badgeType /= balanceBadgeType
+    -- while the run continues on its anchor, dating the grant at the tip moves only the row's date;
+    -- a run that has lapsed restarts at t
+    t = max periodStart createdAt
+    lapsedBefore = lapseEntry t lapseBeforeId tip
+    current = fromMaybe tip lapsedBefore
+    debited
+      | otherTier && balanceMonths current /= 0 = Just $ debitEntry t debitId (SDUpgrade ownKey) current
+      | otherwise = Nothing
+    granted = grantEntry t grantId badgeType months (SCCharge chargeId) $ fromMaybe current debited
+    lapsedSince = lapseEntry now lapseSinceId granted
+
 -- Generous because postdating only writes off a month by crossing a month boundary, which takes
 -- days, while a device clock a few minutes slow would otherwise leave every row unverified.
 maxCreatedAtSkew :: NominalDiffTime
@@ -142,8 +173,8 @@ entryChecked now badgeType prev e
       SEDebit SDLapse -> maybe (Just False) matches $ lapseEntry t "" prev
       SEDebit SDBadge -> maybe (Just False) matches $ issueEntry t "" prev
       SEDebit SDRefund -> uncontradicted
-      SEDebit SDUpgrade {} -> uncontradicted
-      SEDebit SDTransferOut {} -> uncontradicted
+      SEDebit d@SDUpgrade {} -> matches $ debitEntry t "" d prev
+      SEDebit d@SDTransferOut {} -> matches $ debitEntry t "" d prev
       SEDebit SDSupport -> uncontradicted
       SEDebit SDUnknown {} -> uncontradicted
       -- an opening credit resets the ledger to the amount it states, with no relation to the entry
@@ -155,7 +186,9 @@ entryChecked now badgeType prev e
         -- including a negative count, which shortens what the user paid for.
         -- TODO [badges] a purchase made in the app knows the months it bought; check them here.
         | changeMonths e < 0 -> Just False
-        | otherwise -> matches $ grantEntry t "" (changeMonths e) c prev
+        -- the recompute would agree, as a grant of another tier replaces the balance
+        | tierSwitched -> Just False
+        | otherwise -> matches $ grantEntry t "" (balanceBadgeType e) (changeMonths e) c prev
   where
     t = createdAt e
     postdated = t > addUTCTime maxCreatedAtSkew now
@@ -163,11 +196,17 @@ entryChecked now badgeType prev e
     -- Equal is not behind: a service pass writes its lapse and its issue with one clock reading
     backdated = t < createdAt prev
     matches = Just . sameBalance e
+    -- only a debit that emptied the old run may be followed by another tier, which the seed of a purchase with no ledger is not
+    tierSwitched = balanceBadgeType e /= balanceBadgeType prev && not (emptiedByDebit prev)
+    emptiedByDebit StatementEntry {balanceMonths, entryType} = case entryType of
+      SEDebit _ -> balanceMonths == 0
+      SECredit _ -> False
     restated = balanceMonths e == changeMonths e && balanceMonths e >= 0 && balanceBadgeType e == badgeType
     uncontradicted
       | balanceMonths e /= balanceMonths prev + changeMonths e = Just False
       | balanceMonths e < 0 = Just False
       | balanceStartTs e < balanceStartTs prev = Just False
+      | tierSwitched = Just False
       | otherwise = Nothing
 
 sameBalance :: StatementEntry -> StatementEntry -> Bool
@@ -205,16 +244,30 @@ debitTypeTag = \case
   SDLapse -> "lapse"
   SDUnknown {tag} -> tag
 
--- | Rebuilds only what the columns determine: constructors with no fields, and a payment credit.
--- payment_ is Nothing when the row references no payment, and Just Nothing when that payment had no
--- invoice, as a store purchase has none. The rest answer Nothing rather than invent a payload.
+-- | What a ledger row's reference columns name. refPayment is Nothing when the row references no payment,
+-- and Just Nothing when that payment had no invoice, as a store purchase has none.
+data EntryReferences = EntryReferences
+  { refPayment :: Maybe (Maybe InvoiceId),
+    refChargeId :: Maybe Text,
+    refFromPurchaseKey :: Maybe C.PublicKeyEd25519,
+    refToPurchaseKey :: Maybe C.PublicKeyEd25519
+  }
+
+noEntryReferences :: EntryReferences
+noEntryReferences = EntryReferences {refPayment = Nothing, refChargeId = Nothing, refFromPurchaseKey = Nothing, refToPurchaseKey = Nothing}
+
+-- | Rebuilds only what the columns determine: constructors with no fields, and the types that name a
+-- payment, a charge or a purchase, through the reference their row holds. The rest answer Nothing
+-- rather than invent a payload.
 -- The client stores each type's JSON and reads that first, so this is its fallback; the service has none.
--- TODO [badges] rebuild charge, transferIn, upgrade and transferOut from their reference columns,
--- without which the service cannot re-emit a statement carrying one.
-entryTypeFromColumns :: Maybe (Maybe InvoiceId) -> Text -> Maybe Text -> Maybe Text -> Maybe StatementEntryType
-entryTypeFromColumns payment_ entryType credit_ debit_ = case (entryType, credit_, debit_) of
-  ("credit", Just "payment", _) -> SECredit . SCPayment <$> payment_
+entryTypeFromColumns :: EntryReferences -> Text -> Maybe Text -> Maybe Text -> Maybe StatementEntryType
+entryTypeFromColumns EntryReferences {refPayment, refChargeId, refFromPurchaseKey, refToPurchaseKey} entryType credit_ debit_ = case (entryType, credit_, debit_) of
+  ("credit", Just "payment", _) -> SECredit . SCPayment <$> refPayment
+  ("credit", Just "charge", _) -> SECredit . SCCharge <$> refChargeId
+  ("credit", Just "transferIn", _) -> SECredit . SCTransferIn <$> refFromPurchaseKey
   ("credit", Just t, _) -> SECredit <$> creditType t
+  ("debit", _, Just "upgrade") -> SEDebit . SDUpgrade <$> refToPurchaseKey
+  ("debit", _, Just "transferOut") -> SEDebit . SDTransferOut <$> refToPurchaseKey
   ("debit", _, Just t) -> SEDebit <$> debitType t
   _ -> Nothing
   where

src/Simplex/Chat/Badges/Service.hs

@@ -18,6 +18,7 @@ module Simplex.Chat.Badges.Service
     BadgeUpgrade (..),
     BadgeServiceResponse (..),
     BadgeServiceErrorCode (..),
+    SubscriptionState (..),
     BadgeCatalog (..),
     BadgePrice (..),
     BadgeOffer (..),
@@ -92,10 +93,13 @@ data BadgeServiceCommand
         upgrade :: Maybe BadgeUpgrade -- upgrade store 1-time badge
       }
   | BSCUpgradeBadgeSubscription
-      { badgeRequest :: BadgeRequest, -- TODO [badges] drop when implemented: a client-stated expiry leaves the week's anonymity set
-        payment :: ServicePayment, -- store payments only
+      { payment :: ServicePayment, -- names the subscription and the tier to wait for; the store's answer is what is granted
         balance :: BadgeBalance
       }
+  | BSCTransferBadge
+      { masterKey :: BadgeMasterKey,
+        payment :: ServicePayment -- the store receipt of the subscription to move to the signing key
+      }
   | BSCIssueBadge
       { balance :: BadgeBalance -- no badgeRequest: the service holds the key, the tier and the expiry
       }
@@ -121,7 +125,8 @@ data BadgeServiceResponse
   | BSPBadgeCredential
       { credential :: Maybe BadgeCredential, -- Nothing when no balance to issueBadge or no current credential for pause
         receipt :: Maybe Text, -- not provided for lifetime badges
-        statement :: BadgeStatement
+        statement :: BadgeStatement,
+        subscription :: Maybe SubscriptionState -- present exactly when a store subscription funds the purchase
       }
   | BSPError
       { code :: BadgeServiceErrorCode,

src/Simplex/Chat/Badges/StorePlan.hs

@@ -0,0 +1,29 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Simplex.Chat.Badges.StorePlan (storePlan, playBasePlan) where
+
+import Data.Text (Text)
+import Simplex.Chat.Badges (BadgeType (..))
+import Simplex.Chat.PaymentService.Types (PaymentProvider (..))
+
+-- | 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, _) -> snd <$> playBasePlan planId
+  _ -> Nothing
+
+-- | A Play base plan's subscription product, and what the plan grants. Play keeps a base plan id unique
+-- only within its subscription, so a plan is one of these only under its own product.
+playBasePlan :: Text -> Maybe (Text, (BadgeType, Int))
+playBasePlan = \case
+  "subscr-badge-supporter-month-02" -> Just ("subscr_badge_supporter_01", (BTSupporter, 1))
+  "subscr-badge-supporter-year-01" -> Just ("subscr_badge_supporter_01", (BTSupporter, 12))
+  "subscr-badge-legend-month-01" -> Just ("subscr_badge_legend_01", (BTLegend, 1))
+  "subscr-badge-legend-year-01" -> Just ("subscr_badge_legend_01", (BTLegend, 12))
+  _ -> Nothing

src/Simplex/Chat/Badges/Types.hs

@@ -20,6 +20,7 @@ module Simplex.Chat.Badges.Types
     LedgerDebitType (..),
     BadgeAlertKind (..),
     BadgeServiceErrorCode (..),
+    SubscriptionState (..),
     BadgeIssueFailure (..),
     BadgeIssueError (..),
     BadgeFunding (..),
@@ -29,8 +30,10 @@ module Simplex.Chat.Badges.Types
     BadgeIssuance (..),
     BadgeAlert (..),
     BadgeAlertPrice (..),
+    BadgeSubscription (..),
     BadgeState (..),
     OpenStorePurchase (..),
+    StoreReceiptOrigin (..),
   ) where
 
 import Control.Applicative ((<|>))
@@ -117,13 +120,14 @@ data LedgerDebitType
   deriving (Eq, Show)
 
 -- unconfirmed draft
-data BadgeAlertKind = BARenewalApproaching | BAPaymentIssue | BASubscriptionEnded | BAPrepaidEnding | BASupportEnded | BAIssueFailed
+data BadgeAlertKind = BARenewalApproaching | BAPaymentIssue | BASubscriptionCancelled | BASubscriptionEnded | BAPrepaidEnding | BASupportEnded | BAIssueFailed
   deriving (Eq, Show)
 
 instance TextEncoding BadgeAlertKind where
   textEncode = \case
     BARenewalApproaching -> "renewal_approaching"
     BAPaymentIssue -> "payment_issue"
+    BASubscriptionCancelled -> "subscription_cancelled"
     BASubscriptionEnded -> "subscription_ended"
     BAPrepaidEnding -> "prepaid_ending"
     BASupportEnded -> "support_ended"
@@ -131,6 +135,7 @@ instance TextEncoding BadgeAlertKind where
   textDecode = \case
     "renewal_approaching" -> Just BARenewalApproaching
     "payment_issue" -> Just BAPaymentIssue
+    "subscription_cancelled" -> Just BASubscriptionCancelled
     "subscription_ended" -> Just BASubscriptionEnded
     "prepaid_ending" -> Just BAPrepaidEnding
     "support_ended" -> Just BASupportEnded
@@ -244,11 +249,21 @@ data BadgeServiceErrorCode
   | BSECodeExpired
   | BSEReceiptInvalid
   | BSEReceiptUsed
+  | BSETransferLimited -- the subscription moved from another key whose credential has not expired yet
   | BSETestPurchase -- the store vouched for a purchase that cost nothing: Apple's sandbox, a Play license tester
   | BSEInternal
   | BSEUnknown Text -- forwards-compatible: service is deployed ahead of clients
   deriving (Eq, Show)
 
+-- | The store's answer as the service last read it. A client reads a state it does not know as not ended.
+data SubscriptionState
+  = SSRenewing
+  | SSCancelled -- auto-renew is off, and the paid period still runs
+  | SSBillingRetry -- a charge failed and the store is retrying it: grace, retry or hold
+  | SSEnded -- no charge will come: expired, revoked or refunded
+  | SSUnknown Text -- forwards-compatible: service is deployed ahead of clients
+  deriving (Eq, Show)
+
 -- | Why a renewal request ended without a credential stored. retryable is the service's own view of
 -- transience: it gave retryAfter, which holds for codes this version does not know.
 data BadgeIssueFailure
@@ -280,14 +295,23 @@ data BadgeState = BadgeState
     willRenew :: Bool,
     alert :: Maybe BadgeAlert,
     issueError :: Maybe BadgeIssueError,
-    nextWakeAt :: Maybe UTCTime
+    nextWakeAt :: Maybe UTCTime,
+    subscription :: Maybe BadgeSubscription
   }
   deriving (Show)
 
+-- | A store subscription funding the purchase: the latest charge's plan, and the store's state as last observed.
+data BadgeSubscription = BadgeSubscription
+  { planMonths :: Int,
+    status :: Maybe SubscriptionState,
+    transactionRef :: Maybe Text -- the store receipt's: Apple's original transaction id, or a hash of Play's token
+  }
+  deriving (Eq, Show)
+
 -- | One of a profile's store purchases that no receipt has reached yet, or whose receipt is held until
 -- the service credits it; transactionRef is set once a receipt arrived. Neither reference is a secret:
--- Apple's is the transaction id, Google's is a hash of the token. creditError is set only while the
--- held receipt's last attempt failed in a way that cannot clear on its own.
+-- Apple's is the transaction id, or a subscription's original one; Google's is a hash of the token.
+-- creditError is set only while the held receipt's last attempt failed in a way that cannot clear on its own.
 data OpenStorePurchase = OpenStorePurchase
   { invoiceId :: Maybe Text,
     transactionRef :: Maybe Text,
@@ -295,6 +319,14 @@ data OpenStorePurchase = OpenStorePurchase
   }
   deriving (Show)
 
+-- | Where the app found a store transaction it hands over. The store lists an account's purchases on every
+-- device signed into it, so a listed one is claimed only by a core that already has a record for it.
+data StoreReceiptOrigin
+  = SROPurchased -- the app's own purchase call
+  | SROListed -- the store's list of unfinished transactions, or its updates
+  | SRORestored -- Restore's hand-over of what the store lists as this account's, moved to this profile
+  deriving (Eq, Show)
+
 instance TextEncoding BadgePurchaseStatus where
   textEncode = \case
     PSAcquiring -> "acquiring"
@@ -346,6 +378,7 @@ instance TextEncoding BadgeServiceErrorCode where
     BSECodeExpired -> "code_expired"
     BSEReceiptInvalid -> "receipt_invalid"
     BSEReceiptUsed -> "receipt_used"
+    BSETransferLimited -> "transfer_limited"
     BSETestPurchase -> "test_purchase"
     BSEInternal -> "internal"
     BSEUnknown t -> t
@@ -367,6 +400,7 @@ instance TextEncoding BadgeServiceErrorCode where
     "code_expired" -> BSECodeExpired
     "receipt_invalid" -> BSEReceiptInvalid
     "receipt_used" -> BSEReceiptUsed
+    "transfer_limited" -> BSETransferLimited
     "test_purchase" -> BSETestPurchase
     "internal" -> BSEInternal
     t -> BSEUnknown t
@@ -378,6 +412,31 @@ instance ToJSON BadgeServiceErrorCode where
 instance FromJSON BadgeServiceErrorCode where
   parseJSON = textParseJSON "BadgeServiceErrorCode"
 
+instance TextEncoding SubscriptionState where
+  textEncode = \case
+    SSRenewing -> "renewing"
+    SSCancelled -> "cancelled"
+    SSBillingRetry -> "billingRetry"
+    SSEnded -> "ended"
+    SSUnknown t -> t
+  textDecode s = Just $ case s of
+    "renewing" -> SSRenewing
+    "cancelled" -> SSCancelled
+    "billingRetry" -> SSBillingRetry
+    "ended" -> SSEnded
+    t -> SSUnknown t
+
+instance ToJSON SubscriptionState where
+  toJSON = textToJSON
+  toEncoding = textToEncoding
+
+instance FromJSON SubscriptionState where
+  parseJSON = textParseJSON "SubscriptionState"
+
+instance FromField SubscriptionState where fromField = fromTextField_ textDecode
+
+instance ToField SubscriptionState where toField = toField . textEncode
+
 instance StrEncoding BadgeIssueFailure where
   strEncode = \case
     BIFServiceError {code, retryable} -> "service_error " <> (if retryable then "retry " else "final ") <> encodeUtf8 (textEncode code)
@@ -427,6 +486,8 @@ $(JQ.deriveJSON (sumTypeJSON $ dropPrefix "BIF") ''BadgeIssueFailure)
 
 $(JQ.deriveJSON defaultJSON ''BadgeIssueError)
 
+$(JQ.deriveJSON defaultJSON ''BadgeSubscription)
+
 $(JQ.deriveJSON defaultJSON ''BadgeState)
 
 $(JQ.deriveJSON defaultJSON ''OpenStorePurchase)

src/Simplex/Chat/Controller.hs

@@ -86,7 +86,7 @@ import Simplex.Messaging.Client (HostMode (..), SMPProxyFallback (..), SMPProxyM
 import qualified Simplex.Messaging.Crypto as C
 import Simplex.Chat.Badges (BadgeCredential, FileSizeLimits, LocalBadge)
 import Simplex.Chat.Badges.Service (BadgeServiceErrorCode, StatementEntry)
-import Simplex.Chat.Badges.Types (BadgeAlert (..), BadgeAlertKind, BadgeIssueFailure, BadgeState (..), OpenStorePurchase (..))
+import Simplex.Chat.Badges.Types (BadgeAlert (..), BadgeAlertKind, BadgeIssueFailure, BadgeState (..), OpenStorePurchase (..), StoreReceiptOrigin, SubscriptionState)
 import Simplex.Chat.PaymentService (ServicePayment)
 import Simplex.Messaging.Crypto.BBS (BBSPublicKey)
 import Simplex.Messaging.Crypto.File (CryptoFile (..))
@@ -157,6 +157,11 @@ data ChatConfig = ChatConfig
     badgeRetryInterval :: RetryInterval,
     -- attempts a store receipt gets in one turn before its next one waits for the stored schedule
     badgeConsecutiveRetries :: Int,
+    -- set only by builds for a dev badge service: allows /_badge request, sent off the shared schedule
+    badgeDevRequests :: Bool,
+    -- Local testing only: the badge worker treats a request as due this often, instead of near the
+    -- credential's expiry, so a renewal can be watched without waiting weeks.
+    badgeDevRequestInterval :: Maybe NominalDiffTime,
     confirmMigrations :: MigrationConfirmation,
     presetServers :: PresetServers,
     shortLinkPresetServers :: NonEmpty SMPServer,
@@ -672,13 +677,15 @@ data ChatCommand
   | UpdateProfileImageFromFile FilePath -- set profile image from a .png/.jpg/.jpeg file
   | AddBadge BadgeCredential -- attach an issued badge credential (testing; credential from `simplex-chat badge sign`)
   | APIRedeemBadgeCode {userId :: UserId, code :: Text} -- redeem a badge code with the configured badge service
-  | APIPurchaseBadge {userId :: UserId, echoedInvoiceId :: Maybe Text, payment :: ServicePayment} -- hand over an App Store or Google Play receipt, held until a worker credits it; answers from the record and sends nothing
+  | APIPurchaseBadge {userId :: UserId, echoedInvoiceId :: Maybe Text, origin :: StoreReceiptOrigin, payment :: ServicePayment} -- hand over an App Store or Google Play receipt, held until a worker credits it; answers from the record and sends nothing
+  | APISetBadgeSubscriptionStatus {status :: SubscriptionState, payment :: ServicePayment} -- the device store's view of a credited subscription, which changes what is shown and alerted, and retires its badge once ended
   | APICreateBadgeInvoice {userId :: UserId} -- the record of a store purchase, created before the store charges; answers the id the store echoes
   | APIGetBadgeState {userId :: UserId} -- the user's badges, their balances and any current alert
   | APIGetBadgeLedger {userId :: UserId, badgePurchaseId :: Int64} -- the purchase's ledger, oldest first
   -- episode is last because it is free text: it is the value that makes one occurrence of an
   -- alert distinct from the next, and the app returns whatever it was given
   | APIAckBadgeAlert {userId :: UserId, badgePurchaseId :: Int64, alertKind :: BadgeAlertKind, snooze :: Bool, episode :: Text}
+  | APIRequestBadge {userId :: UserId}
   | ShowProfileImage
   | SetUserFeature AChatFeature FeatureAllowed -- UserId (not used in UI)
   | SetContactFeature AChatFeature ContactName (Maybe FeatureAllowed)
@@ -786,6 +793,7 @@ allowRemoteCommand = \case
   DeleteRemoteCtrl _ -> False
   ExecChatStoreSQL _ -> False
   ExecAgentStoreSQL _ -> False
+  APIRequestBadge {} -> False
   _ -> True
 
 data RelayConnectionResult = RelayConnectionResult
@@ -889,6 +897,7 @@ data ChatResponse
   | CRServiceReplyAccepted {user :: User, connectionId :: AgentConnId}
   | CRBadgeRedeemed {user :: User, redeemedBadge :: LocalBadge, newBadge :: Bool, badgeState :: Maybe BadgeState}
   | CRBadgeInvoice {user :: User, invoiceId :: Text}
+  | CRStoreReceiptNotRecorded {user :: User}
   | CRBadgeState {user :: User, badgeState :: Maybe BadgeState, storePurchases :: [OpenStorePurchase]}
   | CRBadgeLedger {user :: User, badgeLedger :: [StatementEntry]}
   | CRWallet {user :: User, walletInfo :: WalletInfo}
@@ -1538,6 +1547,7 @@ data BadgeRedeemError
   | BREInvalidReceipt -- names no transaction, or is not a store payment
   | BREServiceNotConfigured
   | BREBadgeActive
+  | BREStorePurchaseOpen -- a store receipt held for this profile may still be credited
   | BREServiceError {serviceError :: BadgeServiceErrorCode}
   | BREInvalidResponse {message :: String}
   | BREUnknownKeyIndex

src/Simplex/Chat/Library/Commands.hs

@@ -53,17 +53,19 @@ import Data.Text.Encoding (decodeLatin1, encodeUtf8)
 import Data.Time (NominalDiffTime, addUTCTime, defaultTimeLocale, formatTime)
 import Data.Word (Word32)
 import Data.Time.Clock (UTCTime, diffUTCTime, getCurrentTime, nominalDay)
+import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
 import Data.Type.Equality
 import qualified Data.UUID as UUID
 import qualified Data.UUID.V4 as V4
 import Simplex.Chat.Library.Subscriber
 import Crypto.Random (ChaChaDRG)
 import Simplex.Messaging.Session (SessionVar (..), withGetSessVar')
-import Simplex.Chat.Badges (BadgeCredential (..), BadgeInfo (..), BadgeMasterKey, BadgeType, LocalBadge (..), ProofPresHeader (..), badgeServerCredential, mkBadgeStatus, maxSndXFTPFileSize, verifyCredential)
+import Simplex.Chat.Badges (BadgeCredential (..), BadgeInfo (..), BadgeMasterKey, BadgeType (..), LocalBadge (..), ProofPresHeader (..), badgeGraceInterval, badgeServerCredential, mkBadgeStatus, maxSndXFTPFileSize, verifyCredential)
 import qualified Simplex.Chat.Badges.Ledger as L
-import Simplex.Chat.Badges.Types (BadgeAlert (..), BadgeAlertKind (..), BadgeIssueError (..), BadgeIssueFailure (..), BadgeState (..), OpenStorePurchase (..))
+import Simplex.Chat.Badges.Types (BadgeAlert (..), BadgeAlertKind (..), BadgeIssueError (..), BadgeIssueFailure (..), BadgeState (..), BadgeSubscription (..), OpenStorePurchase (..), StoreReceiptOrigin (..))
 import Simplex.Chat.Badges.Code (badgeCodeText, parseBadgeCode)
-import Simplex.Chat.Badges.Service (BadgeBalance (..), BadgeServiceCommand (..), BadgeServiceErrorCode (..), BadgeServiceRequest (..), BadgeServiceResponse (..), BadgeStatement (..), StatementDebitType (..), StatementEntry (..), StatementEntryType (..), currentBadgeServiceVersion)
+import Simplex.Chat.Badges.Service (BadgeBalance (..), BadgeServiceCommand (..), BadgeServiceErrorCode (..), BadgeServiceRequest (..), BadgeServiceResponse (..), BadgeStatement (..), StatementDebitType (..), StatementEntry (..), StatementEntryType (..), SubscriptionState (..), currentBadgeServiceVersion)
+import Simplex.Chat.Badges.StorePlan (storePlan)
 import Simplex.Chat.Names (SimplexDomainProof (..), SimplexDomainClaim (..), claimDomain, mkDomainClaim)
 import Simplex.Chat.Wallet (deriveAccount, masterMnemonic, newEntropy)
 import Simplex.Chat.Call
@@ -77,7 +79,7 @@ import Simplex.Chat.Messages.CIContent
 import Simplex.Chat.Messages.CIContent.Events
 import Simplex.Chat.Operators
 import Simplex.Chat.Options
-import Simplex.Chat.PaymentService (ServicePayment (..), appleTransactionId, googlePurchaseRef)
+import Simplex.Chat.PaymentService (AppleTransactionFacts (..), ServicePayment (..), appleTransactionFacts, appleTransactionRef, googlePurchaseRef)
 import Simplex.Chat.PaymentService.Types (PaymentProvider (..), StoreTransactionRef (..))
 import Simplex.Chat.ProfileGenerator (generateRandomProfile)
 import Simplex.Chat.Protocol
@@ -3660,10 +3662,12 @@ processChatCommand cxt nm = \case
   ShowProfile -> withUser $ \user@User {profile} -> pure $ CRUserProfile user (fromLocalProfile profile)
   AddBadge cred -> withUser $ \user -> addUserBadge user cred >> ok user
   APIRedeemBadgeCode userId codeText -> withUserId userId $ \user -> redeemBadgeCode nm user codeText
-  APIPurchaseBadge userId echoedInvoiceId payment -> withUserId userId $ \user -> handOverStoreReceipt user echoedInvoiceId payment
+  APIPurchaseBadge userId echoedInvoiceId origin payment -> withUserId userId $ \user -> handOverStoreReceipt user echoedInvoiceId origin payment
+  APISetBadgeSubscriptionStatus status payment -> recordStoreSubscriptionStatus status payment >> ok_
   APICreateBadgeInvoice userId -> withUserId userId $ \user -> do
     void requireBadgeService
     refuseWhileBadgeHeld user
+    refuseWhileStoreReceiptPending user Nothing
     g <- asks random
     now <- badgeNow
     invoiceId <- UUID.toText <$> liftIO V4.nextRandom
@@ -3679,9 +3683,10 @@ processChatCommand cxt nm = \case
     now <- badgeNow
     let snoozeUntil = if snooze then Just (addUTCTime nominalDay now) else Nothing
     withStore' $ \db -> setBadgeAlertAcked db user badgePurchaseId alertKind episode snoozeUntil
-    -- after the write, so the pass it signals arms a wake for the snooze rather than raising again
+    -- after the write, so the pass it signals reads the ack rather than raising the alert again
     lift $ startBadgeWork user
     badgeStateResponse user
+  APIRequestBadge userId -> withUserId userId requestBadgeNow
   SetBotCommands commands -> withUserProfileLock "updateProfile" $ withUser $ \user@User {profile} -> do
     let LocalProfile {preferences} = profile
         prefs = Just (fromMaybe emptyChatPrefs preferences :: Preferences) {commands = Just commands}
@@ -5484,37 +5489,173 @@ redeemBadgeCode nm user@User {userId} codeText = do
 
 -- | The app hands a receipt over until it is answered credited or refused, under whichever profile is
 -- active; the answer is the owner's, read from the record. Nothing is sent: the owner's receipt worker is.
-handOverStoreReceipt :: User -> Maybe Text -> ServicePayment -> CM ChatResponse
-handOverStoreReceipt presentingUser echoedInvoiceId payment = do
+handOverStoreReceipt :: User -> Maybe Text -> StoreReceiptOrigin -> ServicePayment -> CM ChatResponse
+handOverStoreReceipt presentingUser echoedInvoiceId origin payment = do
   txRef <- maybe (throwRedeemError BREInvalidReceipt) pure $ storeTransactionRef payment
   void requireBadgeService
   g <- asks random
   now <- badgeNow
-  BadgeReceiptRecord {ownerId, status} <-
-    withStore' (\db -> holdStoreReceipt db g presentingUser echoedInvoiceId txRef payment now)
-      >>= maybe (throwChatError $ CEInternalError "store receipt was not recorded") pure
-  owner <- withStore $ \db -> getUser db ownerId
-  case status of
-    RSHeld {} -> lift (resumeStoreReceiptWork ownerId) >> badgeStateResponse owner
-    RSCredited {badgePurchaseId} -> do
-      cred_ <- withStore' (`getLatestIssuedCredential` badgePurchaseId)
-      cred@(BadgeCredential _ _ _ info) <- maybe (throwChatError $ CEInternalError "credited store purchase has no credential") pure cred_
-      CRBadgeRedeemed owner (OwnBadge cred (mkBadgeStatus now (Just True) info)) False <$> getUserBadgeState owner
-    RSRefused {refusal = Just BIFServiceError {code}} -> throwRedeemError $ BREServiceError code
-    RSRefused {} -> throwChatError $ CEInternalError "store purchase refused for no recorded reason"
+  limited <- case origin of
+    -- a move would retire the shown badge's own payment elsewhere, or wait behind it or behind another receipt held here,
+    -- so one Restore claims one transaction
+    SRORestored -> do
+      refuseWhileBadgeHeld presentingUser
+      refuseWhileStoreReceiptPending presentingUser (Just txRef)
+      withStore' (\db -> holdStoreTransfer db g presentingUser txRef payment now)
+    _ -> pure False
+  withStore' (\db -> holdStoreReceipt db g presentingUser origin echoedInvoiceId txRef payment now) >>= \case
+    Nothing -> case origin of
+      SROListed -> pure $ CRStoreReceiptNotRecorded presentingUser
+      _ -> throwChatError $ CEInternalError "store receipt was not recorded"
+    Just BadgeReceiptRecord {receiptId, ownerId, status} -> do
+      owner <- withStore $ \db -> getUser db ownerId
+      when limited $ lift (resumeStoreReceiptWork ownerId) >> throwRedeemError (BREServiceError BSETransferLimited)
+      case status of
+        RSHeld {} -> lift (resumeStoreReceiptWork ownerId) >> badgeStateResponse owner
+        RSCredited {badgePurchaseId, refusalRecorded} -> do
+          let rehold kind = withStore' $ \db -> reholdStoreReceipt db owner receiptId badgePurchaseId kind payment now
+              -- a resubscription no resume reaches moves to fresh keys of its owner, as Restore moves it, once the owner shows
+              -- no badge; until then it is answered held, so the app keeps it unfinished
+              holdAppleResume =
+                withStore' (\db -> purchaseUnreached db owner badgePurchaseId) >>= \case
+                  False -> rehold SHKPurchase
+                  True -> do
+                    unlessM (withStore' (`userHasBadge` owner)) $
+                      whenM (withStore' $ \db -> holdStoreTransfer db g owner txRef payment now) $
+                        lift (resumeStoreReceiptWork ownerId) >> throwRedeemError (BREServiceError BSETransferLimited)
+                    pure True
+          movedOut <- withStore' (`purchaseMovedOut` badgePurchaseId)
+          answeredHeld <- case resumeHold now payment of
+            _ | movedOut -> pure False
+            -- a charge refused after its hold is answered from the record, or the app's sweep would hold it again at every launch
+            Just (RHPurchasedAt purchasedAt) | not (refusalRecorded && resumeHoldEnded now purchasedAt) -> holdAppleResume
+            -- a refused Play resume is held again: the service's hourly check bounds what the sweep can ask of Play
+            Just RHAttempts -> rehold SHKPurchase
+            _ -> pure False
+          lastChargeAt_ <- withStore' (`getLastChargeCreditAt` badgePurchaseId)
+          -- a refused tier change is answered from the record once, on which the app finishes it, or every sweep would hold it
+          -- and send it again; the record keeps no transaction id, so the refusal is then cleared and a later charge is held
+          tierChangeHeld <- case tierChangeCharge now lastChargeAt_ payment of
+            Just tier
+              | not answeredHeld ->
+                  withStore' (`getBadgePurchase` badgePurchaseId) >>= \case
+                    Just UserBadgePurchase {badgeType, shown}
+                      | raisesTier badgeType tier ->
+                          if refusalRecorded
+                            then False <$ when shown (withStore' (`clearStoreReceiptRefusal` receiptId))
+                            else rehold SHKTierChange
+                    _ -> pure False
+            _ -> pure False
+          if answeredHeld || tierChangeHeld
+            then lift (resumeStoreReceiptWork ownerId) >> badgeStateResponse owner
+            else do
+              cred_ <- withStore' (`getLatestIssuedCredential` badgePurchaseId)
+              cred@(BadgeCredential _ _ _ info) <- maybe (throwChatError $ CEInternalError "credited store purchase has no credential") pure cred_
+              CRBadgeRedeemed owner (OwnBadge cred (mkBadgeStatus now (Just True) info)) False <$> getUserBadgeState owner
+        RSRefused {refusal = Just BIFServiceError {code}} -> throwRedeemError $ BREServiceError code
+        RSRefused {} -> throwChatError $ CEInternalError "store purchase refused for no recorded reason"
+
+-- | Renewing does not replace billing retry: Play lists a subscription in its grace period as renewing,
+-- and the service's answer clears billing retry once the store charges. It replaces ended only while the badge is shown:
+-- the service's ended answer retires the badge in the same pass, so an ended still shown is a device's report, which a
+-- resubscription corrects, while a retired purchase resumes only by its charge.
+recordStoreSubscriptionStatus :: SubscriptionState -> ServicePayment -> CM ()
+recordStoreSubscriptionStatus reported payment = do
+  txRef <- maybe (throwRedeemError BREInvalidReceipt) pure $ storeTransactionRef payment
+  changedOwner_ <- withStore' $ \db ->
+    getReceiptRecord db txRef >>= \case
+      Just BadgeReceiptRecord {ownerId, status = RSCredited {badgePurchaseId}} ->
+        getBadgePurchase db badgePurchaseId >>= \case
+          Just UserBadgePurchase {shown, purchaseKind = PKSubscription BadgeSubscription {status}}
+            | replaces shown status -> Just ownerId <$ setBadgeSubscriptionStatus db badgePurchaseId reported
+          _ -> pure Nothing
+      _ -> pure Nothing
+  forM_ changedOwner_ $ \ownerId -> do
+    owner <- withStore (`getUser` ownerId)
+    toView . CEvtBadgeChanged owner =<< getUserBadgeState owner
+    lift $ startBadgeWork owner
+  where
+    replaces shown = \case
+      Just stored | stored == reported -> False
+      Just SSBillingRetry -> reported /= SSRenewing
+      Just SSEnded -> shown || reported /= SSRenewing
+      _ -> True
 
 -- | The receipt will never be credited to its key; any other refusal may pass on a retry.
 storeReceiptRefused :: BadgeServiceErrorCode -> Bool
 storeReceiptRefused = \case
   BSEReceiptInvalid -> True
   BSEReceiptUsed -> True
+  -- a badge moves only on the user's Restore, never by a retry once the limit has passed
+  BSETransferLimited -> True
   BSETestPurchase -> True
   _ -> False
 
+-- | How far ahead of this device's clock a charge's purchase date may be: a payload dated further ahead is never held.
+resumeClockSkew :: NominalDiffTime
+resumeClockSkew = nominalDay
+
+-- | How long after a charge's purchase date a resume the service answers without crediting keeps holding the profile.
+resumeHoldLimit :: NominalDiffTime
+resumeHoldLimit = nominalDay
+
+-- | The purchase date of an Apple subscription charge that may resume a retired purchase: not revoked, and bought
+-- for a paid period that has not ended. Read from the unverified payload, which decides only whether to ask the service.
+resumableCharge :: UTCTime -> ServicePayment -> Maybe UTCTime
+resumableCharge now = \case
+  SPApple {jws}
+    | Just AppleTransactionFacts {purchaseDate = Just purchased, expiresDate = Just expires, revoked = False, autoRenewable = True} <- appleTransactionFacts jws,
+      let purchasedAt = millisTime purchased,
+      purchasedAt < resumeClockSkew `addUTCTime` now,
+      now < millisTime expires ->
+        Just purchasedAt
+  _ -> Nothing
+  where
+    millisTime ms = posixSecondsToUTCTime $ fromIntegral ms / 1000
+
+resumeHoldEnded :: UTCTime -> UTCTime -> Bool
+resumeHoldEnded now purchasedAt = resumeHoldLimit `addUTCTime` purchasedAt <= now
+
+-- | How long a resume the service answers without crediting keeps holding the profile: an Apple charge until
+-- resumeHoldLimit after its purchase date, a Play token, which carries no date, for heldChargeAttempts attempts per hand-over.
+data ResumeHold = RHPurchasedAt UTCTime | RHAttempts
+
+-- | Any Play token may resume, as reholdStoreReceipt and the worker's resume take only a subscription purchase.
+resumeHold :: UTCTime -> ServicePayment -> Maybe ResumeHold
+resumeHold now = \case
+  SPGoogle {} -> Just RHAttempts
+  payment -> RHPurchasedAt <$> resumableCharge now payment
+
+-- | The attempts, thrown and failed ones included, that one hand-over of a Play resume or an App Store tier change is held
+-- for; then the record is set aside, and the next hand-over holds it again. The service still asks its store at most hourly.
+heldChargeAttempts :: Int64
+heldChargeAttempts = 24
+
+-- | The tier of an Apple subscription charge that may change the tier of a shown purchase: not revoked, not expired, and
+-- bought after the purchase's last charge credit, which the service dates no earlier than its charge, so a credited change
+-- is never newer. Read from the unverified payload, which decides only what to ask the service and wait for.
+tierChangeCharge :: UTCTime -> Maybe UTCTime -> ServicePayment -> Maybe BadgeType
+tierChangeCharge now lastChargeAt_ = \case
+  SPApple {jws}
+    | Just AppleTransactionFacts {productId = Just planId, purchaseDate = Just purchased, expiresDate, revoked = False, autoRenewable = True} <- appleTransactionFacts jws,
+      Just (tier, _) <- storePlan PPApple planId,
+      Just lastChargeAt <- lastChargeAt_,
+      lastChargeAt < millisTime purchased,
+      maybe True ((now <) . millisTime) expiresDate ->
+        Just tier
+  _ -> Nothing
+  where
+    millisTime ms = posixSecondsToUTCTime $ fromIntegral ms / 1000
+
+-- | Whether a charge of the second tier raises a purchase of the first: any other change waits for the renewal check.
+raisesTier :: BadgeType -> BadgeType -> Bool
+raisesTier BTSupporter BTLegend = True
+raisesTier _ _ = False
+
 -- | The same reference the service claims a transaction by, read without verifying anything.
 storeTransactionRef :: ServicePayment -> Maybe StoreTransactionRef
 storeTransactionRef = \case
-  SPApple {jws} -> StoreTransactionRef PPApple <$> appleTransactionId jws
+  SPApple {jws} -> StoreTransactionRef PPApple <$> appleTransactionRef jws
   SPGoogle {token} -> Just $ StoreTransactionRef PPGoogle $ googlePurchaseRef token
   SPInvoice {} -> Nothing
   SPReceipt {} -> Nothing
@@ -5524,7 +5665,7 @@ storeTransactionRef = \case
 stashBadgeKeys :: User -> Maybe BadgeStash -> (DB.Connection -> IO BadgeStash) -> CM BadgeStash
 stashBadgeKeys user stash_ createStash = do
   replaying <- maybe (pure False) (\s -> withStore' $ \db -> isJust <$> getStashBadgePurchase db s) stash_
-  unless replaying $ refuseWhileBadgeHeld user
+  unless replaying $ refuseWhileBadgeHeld user >> refuseWhileStoreReceiptPending user Nothing
   maybe (withStore' createStash) pure stash_
 
 requireBadgeService :: CM (ConnectTarget 'CMContact)
@@ -5533,6 +5674,21 @@ requireBadgeService = asks (badgeServiceAddress . config) >>= maybe (throwRedeem
 refuseWhileBadgeHeld :: User -> CM ()
 refuseWhileBadgeHeld user = whenM (withStore' (`userHasBadge` user)) $ throwRedeemError BREBadgeActive
 
+-- | A new badge would leave a held receipt waiting behind it. An Apple subscription blocks until its charge lapses, as Apple
+-- keeps charging it; any other only while its last failure, if any, can clear, since one that failed for good waits anyway.
+-- The record of the transaction presented, if any, is not another receipt.
+refuseWhileStoreReceiptPending :: User -> Maybe StoreTransactionRef -> CM ()
+refuseWhileStoreReceiptPending user presented_ = do
+  now <- badgeNow
+  pending <- withStore' $ \db -> getPendingStoreReceipts db user now
+  when (any blocks $ filter (not . presented . fst) pending) $ throwRedeemError BREStorePurchaseOpen
+  where
+    presented payment = isJust presented_ && (storeTransactionRef =<< decodeJSON payment) == presented_
+    blocks (payment, failure_) = appleSubscription payment || maybe True badgeFailureTransient failure_
+    appleSubscription payment = case decodeJSON payment of
+      Just SPApple {jws} | Just AppleTransactionFacts {autoRenewable} <- appleTransactionFacts jws -> autoRenewable
+      _ -> False
+
 -- | One attempt to turn a stash into a badge. A refusal is answered rather than thrown, with the
 -- service's retryAfter.
 requestBadgeStash :: NetworkRequestMode -> User -> ConnectTarget 'CMContact -> BadgeStash -> BadgeServiceCommand -> CM (Either (BadgeServiceErrorCode, Maybe Word32) (Maybe User, ChatResponse))
@@ -5543,7 +5699,7 @@ requestBadgeStash nm user sendTarget stash@BadgeStash {purchaseKey, purchasePriv
   case J.fromJSON (J.Object respData) of
     J.Error _ -> throwRedeemError $ BREInvalidResponse "not a badge service response"
     J.Success BSPError {code, retryAfter} -> pure $ Left (code, retryAfter)
-    J.Success BSPBadgeCredential {credential = Just cred, statement} -> Right <$> storeRedeemedBadge user stash cred statement
+    J.Success BSPBadgeCredential {credential = Just cred, statement, subscription} -> Right <$> storeRedeemedBadge user stash cred statement (boundedSubscriptionState <$> subscription)
     J.Success _ -> throwRedeemError $ BREInvalidResponse "unexpected response type"
 
 throwRedeemError :: BadgeRedeemError -> CM a
@@ -5557,13 +5713,25 @@ badgeServiceErrorText = textEncode . boundedServiceErrorCode
 -- on controls, or a sentence the app shows the user as its own.
 boundedServiceErrorCode :: BadgeServiceErrorCode -> BadgeServiceErrorCode
 boundedServiceErrorCode = \case
-  BSEUnknown t -> BSEUnknown $ case T.filter errorCodeChar (T.take 32 t) of
-    "" -> "unknown"
-    t' -> t'
+  BSEUnknown t -> boundedServiceText BSEUnknown errorCodeChar t
   code -> code
   where
     errorCodeChar c = isAsciiLower c || isDigit c || c == '_'
 
+-- | A state this version does not know is stored and shown as the service named it, so it is bounded likewise.
+boundedSubscriptionState :: SubscriptionState -> SubscriptionState
+boundedSubscriptionState = \case
+  SSUnknown t -> boundedServiceText SSUnknown stateChar t
+  state -> state
+  where
+    stateChar c = isAsciiLower c || isAsciiUpper c || isDigit c
+
+-- | Kept only if it reads back as unknown: a text that filters down to a known name would be stored, and read, as that value.
+boundedServiceText :: (Eq a, TextEncoding a) => (Text -> a) -> (Char -> Bool) -> Text -> a
+boundedServiceText unknown allowed t = case T.filter allowed (T.take 32 t) of
+  t' | not (T.null t') && textDecode t' == Just (unknown t') -> unknown t'
+  _ -> unknown "unknown"
+
 -- | The only clock badge code reads, so a test can move the client and the service together.
 badgeNow :: CM UTCTime
 badgeNow = asks (badgeCurrentTime . config) >>= liftIO
@@ -5573,6 +5741,19 @@ badgeNow = asks (badgeCurrentTime . config) >>= liftIO
 startBadgeWork :: User -> CM' ()
 startBadgeWork user = whenM (isJust <$> asks (badgeServiceAddress . config)) $ void $ getBadgeWorker user
 
+-- | Sent off the shared request moment, so only a build for a dev badge service may send it.
+requestBadgeNow :: User -> CM ChatResponse
+requestBadgeNow user@User {userId} = do
+  unlessM (asks $ badgeDevRequests . config) $ throwCmdError "/_badge request is only available in builds for a dev badge service"
+  withStore' (`getUserBadgePurchase` user) >>= \case
+    Just p@UserBadgePurchase {shown = True} -> do
+      badgeNow >>= requestBadgeIssue userId p >>= \case
+        Right (_, Just SSEnded) -> void $ retireBadge user p
+        _ -> pure ()
+      lift $ startBadgeWork user
+      badgeStateResponse user
+    _ -> throwCmdError "no badge is shown"
+
 -- | Exactly one caller starts the thread and the rest wait for it: the lookup and the create cannot
 -- be one transaction, because starting a thread is not STM.
 getBadgeWorker :: User -> CM' BadgeWorker
@@ -5656,7 +5837,8 @@ badgeMaxWake = 100 * 365 * nominalDay
 
 startStoreReceiptWork :: User -> CM ()
 startStoreReceiptWork User {userId} = do
-  held <- withStore' $ \db -> getNextHeldStoreReceipt db userId
+  now <- badgeNow
+  held <- withStore' $ \db -> getNextHeldStoreReceipt db userId now
   when (either (const False) isJust held) $ lift $ resumeStoreReceiptWork userId
 
 resumeStoreReceiptWork :: UserId -> CM' ()
@@ -5671,13 +5853,13 @@ runStoreReceiptWorker a userId Worker {doWork} = do
   forever $ do
     lift $ waitForWork doWork
     withWork_ a doWork (getDueReceipt scheduled) $ \case
-      BadgeReceiptRecord {receiptId, status = RSHeld {stash, invoiceId, payment, retryDelay}} -> creditStoreReceipt a userId receiptId stash invoiceId payment retryDelay
+      BadgeReceiptRecord {receiptId, status = RSHeld {stash, invoiceId, payment, retryDelay, holdKind}} -> creditStoreReceipt a userId receiptId stash invoiceId payment retryDelay holdKind
       BadgeReceiptRecord {receiptId} -> notHeld receiptId
   where
-    getDueReceipt scheduled =
-      withStore' (`getNextHeldStoreReceipt` userId) >>= \case
-        Right (Just r@BadgeReceiptRecord {receiptId, status = RSHeld {nextAttemptAt}}) -> do
-          now <- badgeNow
+    getDueReceipt scheduled = do
+      now <- badgeNow
+      withStore' (\db -> getNextHeldStoreReceipt db userId now) >>= \case
+        Right (Just r@BadgeReceiptRecord {receiptId, status = RSHeld {nextAttemptAt}}) ->
           if nextAttemptAt <= now
             then pure $ Right (Just r)
             else Right Nothing <$ scheduleReceipt scheduled receiptId (diffUTCTime nextAttemptAt now)
@@ -5695,22 +5877,25 @@ runStoreReceiptWorker a userId Worker {doWork} = do
 data StoreReceiptOutcome = SROCredited (Maybe User) | SRORefused BadgeIssueFailure | SRORetry | SRODeferred
 
 -- | Under the owner's badge lock, which keeps a profile's requests to the service serial.
-creditStoreReceipt :: AgentClient -> UserId -> Int64 -> BadgeStash -> Maybe Text -> Text -> Maybe Int64 -> CM ()
-creditStoreReceipt a userId receiptId stash@BadgeStash {masterKey} invoiceId_ payment retryDelay = do
+creditStoreReceipt :: AgentClient -> UserId -> Int64 -> BadgeStash -> Maybe Text -> Text -> Maybe Int64 -> StoreHoldKind -> CM ()
+creditStoreReceipt a userId receiptId stash@BadgeStash {masterKey} invoiceId_ payment retryDelay holdKind = do
   ChatConfig {badgeRetryInterval = ri, badgeConsecutiveRetries} <- asks config
   withRetryIntervalCount (maybe ri (\d -> ri {initialInterval = d, increaseAfter = 0}) retryDelay) $ \n delay loop -> do
     liftIO $ waitWhileSuspended a
     liftIO $ waitForUserNetwork a
     -- decided under the lock and acted on outside it: the retry sleeps, and announcing takes the chat lock
     outcome <- withEntityLock "badgePurchase" (CLBadgeUser userId) $
-      tryAllErrors attempt >>= \case
-        Right (Right (present_, _)) -> pure $ SROCredited present_
-        Right (Left (code, retryAfter))
-          | storeReceiptRefused code -> do
-              let failure = serviceFailure code retryAfter
-              SRORefused failure <$ withStore' (\db -> refuseStoreReceipt db receiptId failure)
-          | otherwise -> failed ri delay (serviceFailure code retryAfter) retryAfter
-        Left e -> failed ri delay (badgeIssueFailure e) Nothing
+      -- a Restore takes a held record without this lock, so one it took since it was read is left to its new owner's worker
+      ifM (not <$> withStore' (\db -> storeReceiptHeldFor db receiptId userId holdKind)) (pure SRODeferred) $
+        if holdKind == SHKTransfer
+          -- before the stash lookup: the record still links the purchase its payment moves from
+          then credit ri delay transferCmd
+          else
+            withStore' (`getStashBadgePurchase` stash) >>= \case
+              -- before the resume, which settles any record whose purchase is shown
+              Just purchaseId | holdKind == SHKTierChange -> changeTier ri delay purchaseId
+              Just purchaseId -> resume ri delay purchaseId
+              Nothing -> credit ri delay purchaseCmd
     -- the invoice id is the app's only key to the store transaction, so without one nothing is emitted and its sweep finishes it
     case outcome of
       SROCredited present_ -> do
@@ -5725,12 +5910,104 @@ creditStoreReceipt a userId receiptId stash@BadgeStash {masterKey} invoiceId_ pa
       SRORetry | n + 1 < badgeConsecutiveRetries -> loop
       _ -> pure ()
   where
-    attempt = do
+    credit ri delay cmd =
+      tryAllErrors (attempt cmd) >>= \answer -> serviceAnswered ri delay refuse (failed ri delay) answer $ \(present_, _) -> pure $ SROCredited present_
+    -- retried takes only a service error that is not a refusal: a thrown error is recorded as a failure as it is
+    serviceAnswered :: RetryInterval -> Int64 -> (BadgeIssueFailure -> CM StoreReceiptOutcome) -> (BadgeIssueFailure -> Maybe Word32 -> CM StoreReceiptOutcome) -> Either ChatError (Either (BadgeServiceErrorCode, Maybe Word32) r) -> (r -> CM StoreReceiptOutcome) -> CM StoreReceiptOutcome
+    serviceAnswered ri delay refused retried answer answered = case answer of
+      Left e -> failed ri delay (badgeIssueFailure e) Nothing
+      Right (Left (code, retryAfter))
+        | storeReceiptRefused code -> refused $ serviceFailure code retryAfter
+        | otherwise -> retried (serviceFailure code retryAfter) retryAfter
+      Right (Right r) -> answered r
+    purchaseCmd payment' = BSCPurchaseBadge {masterKey, payment = payment', upgrade = Nothing}
+    transferCmd payment' = BSCTransferBadge {masterKey, payment = payment'}
+    attempt cmd = do
       user <- withStore $ \db -> getUser db userId
       refuseWhileBadgeHeld user
       sendTarget <- requireBadgeService
       payment' <- maybe (throwChatError $ CEInternalError "held store payment does not decode") pure $ decodeJSON payment
-      requestBadgeStash NRMBackground user sendTarget stash BSCPurchaseBadge {masterKey, payment = payment', upgrade = Nothing}
+      requestBadgeStash NRMBackground user sendTarget stash (cmd payment')
+    -- a held record whose keys already fund a purchase is a resume of that retired subscription, checked before every send
+    resume ri delay purchaseId = do
+      user <- withStore $ \db -> getUser db userId
+      p_ <- withStore' (`getBadgePurchase` purchaseId)
+      newest_ <- withStore' (`getUserBadgePurchase` user)
+      movedOut <- withStore' (`purchaseMovedOut` purchaseId)
+      now <- badgeNow
+      let isNewest = maybe False (\UserBadgePurchase {badgePurchaseId} -> badgePurchaseId == purchaseId) newest_
+      case p_ of
+        Just UserBadgePurchase {shown = True} -> SROCredited Nothing <$ withStore' (`settleStoreReceipt` receiptId)
+        -- the service answers a payment moved to another key ended, so a resume of it never succeeds
+        _ | movedOut -> setAside
+        Just p@UserBadgePurchase {purchaseKind = PKSubscription _}
+          | isNewest, Just hold <- resumeHold now =<< decodeJSON payment -> resumeIssue ri delay user p hold now
+        _ -> refuse receiptInvalid
+    resumeIssue ri delay user p@UserBadgePurchase {badgePurchaseId} hold now = do
+      answer <- tryAllErrors $ requireBadgeService >>= \sendTarget -> sendBadgeIssue sendTarget userId p BSCIssueBadge (recordBadgeIssueFailure p) now
+      answeredAt <- badgeNow
+      -- a charge the service does not grant, as a revoked one, stops holding the profile once its hold ends
+      let notCredited failure retryAfter = case hold of
+            RHPurchasedAt purchasedAt | resumeHoldEnded answeredAt purchasedAt -> refuse receiptInvalid
+            RHAttempts -> failedHeld ri delay failure retryAfter
+            _ -> failed ri delay failure retryAfter
+      serviceAnswered ri delay refuse notCredited answer $ \(balance, stored) ->
+        withStore' (`getLatestIssuedCredential` badgePurchaseId) >>= \case
+          -- the answer told this device of a move elsewhere, which no later attempt undoes
+          _ | paymentMovedOut balance -> setAside
+          Just cred@(BadgeCredential _ _ _ info)
+            | L.paidThrough balance > answeredAt && credentialExpiry cred > answeredAt && stored /= Just SSEnded -> do
+                user' <- withStore $ \db -> do
+                  liftIO $ showChargedPurchase db user receiptId badgePurchaseId stored
+                  setUserBadge db user (Just $ OwnBadge cred (mkBadgeStatus answeredAt (Just True) info))
+                lift $ startBadgeWork user'
+                pure $ SROCredited (Just user')
+          -- the service's own check interval
+          _ -> notCredited BIFServiceError {code = BSEPaymentPending, retryable = True} (Just 3600)
+    -- Settles with nothing to announce: a charge expired or no newer than the last one credited, or to a tier that is not
+    -- higher, the renewal check grants the change, and a badge no longer shown is resumed by the charge's next hand-over.
+    changeTier ri delay purchaseId = do
+      user <- withStore $ \db -> getUser db userId
+      p_ <- withStore' (`getBadgePurchase` purchaseId)
+      lastChargeAt_ <- withStore' (`getLastChargeCreditAt` purchaseId)
+      now <- badgeNow
+      case (p_, decodeJSON payment) of
+        (Just p@UserBadgePurchase {badgeType, shown = True}, Just payment')
+          | Just tier <- tierChangeCharge now lastChargeAt_ payment', raisesTier badgeType tier -> upgradeIssue ri delay user p payment' tier now
+        _ -> setAside
+    -- the receipt's failures are recorded on the record, not as the purchase's failed renewal, as the badge shown still covers
+    upgradeIssue ri delay user p@UserBadgePurchase {badgePurchaseId} payment' tier now = do
+      failure_ <- newTVarIO Nothing
+      let upgradeCmd balance = BSCUpgradeBadgeSubscription {payment = payment', balance}
+      answer <- tryAllErrors $ requireBadgeService >>= \sendTarget -> sendBadgeIssue sendTarget userId p upgradeCmd (atomically . writeTVar failure_ . Just) now
+      answeredAt <- badgeNow
+      recorded_ <- readTVarIO failure_
+      let refusedInSilence failure = SRODeferred <$ withStore' (\db -> refuseStoreReceipt db receiptId payment failure)
+      serviceAnswered ri delay refusedInSilence (failedHeld ri delay) answer $ \case
+        _ | Just failure <- recorded_ -> failedHeld ri delay failure Nothing
+        (_, stored) ->
+          withStore' (`getLatestIssuedCredential` badgePurchaseId) >>= \case
+            Just cred@(BadgeCredential _ _ _ info@BadgeInfo {badgeType = issuedType})
+              | issuedType == tier && credentialExpiry cred > answeredAt && stored /= Just SSEnded -> do
+                  user' <- withStore $ \db -> do
+                    liftIO $ showChargedPurchase db user receiptId badgePurchaseId stored
+                    setUserBadge db user (Just $ OwnBadge cred (mkBadgeStatus answeredAt (Just True) info))
+                  lift $ startBadgeWork user'
+                  pure $ SROCredited (Just user')
+            _ -> failedHeld ri delay BIFServiceError {code = BSEPaymentPending, retryable = True} (Just 3600)
+    -- out of attempts, the record is set aside without a refusal, so the next hand-over holds it again;
+    -- this attempt's failure is not recorded yet, so it is counted here
+    failedHeld ri delay failure retryAfter = do
+      attempts <- withStore' (`getStoreReceiptFailures` receiptId)
+      if attempts + 1 >= heldChargeAttempts
+        then setAside
+        else failed ri delay failure retryAfter
+    setAside = SRODeferred <$ withStore' (`settleStoreReceipt` receiptId)
+    receiptInvalid = BIFServiceError {code = BSEReceiptInvalid, retryable = False}
+    -- a payment adopted while this one was with the service stays held and is sent next, so nothing is announced
+    refuse failure = do
+      refused <- withStore' $ \db -> refuseStoreReceipt db receiptId payment failure
+      pure $ if refused then SRORefused failure else SRODeferred
     serviceFailure code retryAfter = BIFServiceError {code = boundedServiceErrorCode code, retryable = isJust retryAfter}
     failed ri delay failure retryAfter = do
       now <- badgeNow
@@ -5739,7 +6016,7 @@ creditStoreReceipt a userId receiptId stash@BadgeStash {masterKey} invoiceId_ pa
             -- a buyer is waiting, so unlike a renewal a failure that can clear on its own never waits the day
             | badgeFailureTransient failure = (fromIntegral delay / 1000000, SRORetry)
             | otherwise = (badgeStalledInterval, SRODeferred)
-      withStore' $ \db -> recordStoreReceiptFailure db receiptId (nextRetryDelay 0 delay ri) (retryIn `addUTCTime` now) failure
+      withStore' $ \db -> recordStoreReceiptFailure db receiptId payment (nextRetryDelay 0 delay ri) (retryIn `addUTCTime` now) failure
       pure outcome
 
 -- | Retire what has ended, renew what is due, then report the next wake. Waking early, late or not
@@ -5749,18 +6026,51 @@ updateUserBadge userId emitted now = do
   user <- withStore $ \db -> getUser db userId
   withStore' (`getUserBadgePurchase` user) >>= \case
     Nothing -> pure Nothing
-    Just p@UserBadgePurchase {badgePurchaseId} ->
+    Just p@UserBadgePurchase {badgePurchaseId, purchaseKind, nextWakeAt, unrenewedRun} ->
       withStore' (`getBadgeLedgerLastEntry` badgePurchaseId) >>= \case
         Nothing -> pure Nothing
         Just balance -> do
-          -- retirement needs no service and an unbounded retry would not return before it
-          retired <- retireExpiredBadge user p now balance
+          -- No months come after a prepaid purchase's paidThrough, so it is retired before asking, as
+          -- retirement needs no service and an unbounded retry would not return before it. A subscription's come
+          -- from the store, so it is asked about first, and retired once its store says it ended: at once by the service's answer,
+          -- by the stored state (the device's report) only past paidThrough, as StoreKit can report expired during a billing retry
+          -- that still recovers; or once the window has passed since the first answer after which nothing was covered.
+          retiredBefore <- case purchaseKind of
+            PKPrepaid | L.paidThrough balance <= now -> retireBadge user p
+            _ -> pure False
           latest <- withStore' (`getLatestIssuedCredential` badgePurchaseId)
-          let requestDue = not retired && badgeRequestDue now (shownBadgeCredential user p) latest balance
-          (balance', serviceAt) <-
+          devRequestInterval <- asks $ badgeDevRequestInterval . config
+          let due = not retiredBefore && (isJust devRequestInterval && isJust (shownBadgeCredential user p) || badgeRequestDue now purchaseKind (shownBadgeCredential user p) latest balance)
+              -- a due month waits for the wake the last pass set, so a request that issued nothing is not repeated at every activation;
+              -- a wake further than this was not set by such a request, but by a device clock set back since.
+              -- A dev interval reuses the same guard, as it needs the same thing: no second request within it.
+              askNoSoonerThan = fromMaybe badgeStalledInterval devRequestInterval
+              heldUntil = if due then find (\w -> w > now && w <= addUTCTime askNoSoonerThan now) nextWakeAt else Nothing
+              requestDue = due && isNothing heldUntil
+          (balance', subscription_) <-
             if requestDue
-              then either ((balance,) . Just) (,Nothing) <$> requestBadgeIssue userId p now
+              then fromRight (balance, Nothing) <$> requestBadgeIssue userId p now
               else pure (balance, Nothing)
+          let -- the answers after which nothing was covered, each within a window of the one before: an absence or an outage that
+              -- long may hide a renewal, so the next such answer starts a new run
+              unrenewedRun'
+                | L.paidThrough balance' > now = Nothing
+                | requestDue = Just $ case unrenewedRun of
+                    Just run@UnrenewedRun {lastUnrenewedAt} | not (windowPassedSince lastUnrenewedAt) -> run {lastUnrenewedAt = now}
+                    _ -> UnrenewedRun {unrenewedSince = now, lastUnrenewedAt = now}
+                | otherwise = unrenewedRun
+              windowPassedSince t = subscriptionRecoveryWindow `addUTCTime` t <= now
+              ended = case purchaseKind of
+                PKSubscription BadgeSubscription {status} -> case subscription_ of
+                  Just answered -> answered == SSEnded
+                  Nothing -> status == Just SSEnded && L.paidThrough balance' <= now
+                PKPrepaid -> False
+          when (unrenewedRun' /= unrenewedRun) $ withStore' $ \db -> setBadgeUnrenewedRun db badgePurchaseId unrenewedRun'
+          retired <-
+            -- the window only after an answer: a renewal since the run started is known only from an answer
+            if ended || requestDue && maybe False (windowPassedSince . unrenewedSince) unrenewedRun'
+              then retireBadge user p
+              else pure retiredBefore
           -- presenting broadcasts the record it is handed, and the request above can block for the
           -- whole service timeout, so this read belongs after it and not at the top of the pass
           user' <- withStore $ \db -> getUser db userId
@@ -5772,30 +6082,56 @@ updateUserBadge userId emitted now = do
           -- retiring and presenting both replace the badge on the record read above, so it is read again
           user'' <- withStore $ \db -> getUser db userId
           emitBadgeAlert user'' emitted p' (shownBadgeCredential user'' p') now balance'
-          -- a snooze is the one wake that is not in the ledger: nothing else brings the alert back,
-          -- since support having ended leaves both ledger boundaries in the past
           let UserBadgePurchase {issueError = failureBefore} = p
-              UserBadgePurchase {alertSnoozeUntil, issueError = failureAfter} = p'
-              snoozeAt = find (> now) alertSnoozeUntil
-              stalledAt = if requestDue && not issued then Just $ badgeStalledInterval `addUTCTime` now else Nothing
-              wakeAt = earliestTime [serviceAt, snoozeAt, stalledAt, badgeBoundary now (shownBadgeCredential user'' p') balance']
+              UserBadgePurchase {alertSnoozeUntil, issueError = failureAfter, purchaseKind = kindAfter} = p'
+              -- a snooze is a wake only while no request waits: support having ended leaves no ledger moment ahead,
+              -- and a waiting request's own wake brings the alert back
+              snoozeAt = if isJust (stalledAt <|> heldUntil) then Nothing else find (> now) alertSnoozeUntil
+              stalledAt = if requestDue && not issued then badgeStallUntil now <$> shownBadgeCredential user'' p' else Nothing
+              reminderAt = case kindAfter of
+                PKSubscription s -> find (> now) $ renewalReminderAt s balance'
+                PKPrepaid -> Nothing
+              devWakeAt = (`addUTCTime` now) <$> devRequestInterval
+              wakeAt = earliestTime [devWakeAt, snoozeAt, stalledAt, heldUntil, reminderAt, badgeBoundary now (shownBadgeCredential user'' p') balance']
               failed = failureAfter /= failureBefore
+              subscriptionChanged = kindAfter /= purchaseKind
+              balanceMoved = entryId balance' /= entryId balance
           -- written before the event, so the state it reports carries the attempt it leads to
           withStore' $ \db -> setBadgeNextWake db badgePurchaseId wakeAt
-          when (retired || issued || failed) $ toView . CEvtBadgeChanged user'' =<< getUserBadgeState user''
+          when (retired || balanceMoved || failed || subscriptionChanged) $ toView . CEvtBadgeChanged user'' =<< getUserBadgeState user''
           pure wakeAt
 
--- | The other kinds need subscriptions, and warning before a prepaid badge ends is not actionable
--- while topping up cannot credit months without issuing.
+-- | Warning before a prepaid badge ends is not actionable while topping up cannot credit months without issuing.
 -- TODO [badges] BAPrepaidEnding belongs here, three days before paidThrough, once that exists.
 derivedBadgeAlert :: UTCTime -> UserBadgePurchase -> Maybe BadgeCredential -> StatementEntry -> Maybe BadgeAlert
-derivedBadgeAlert now p shownCred b
-  | endsAt <= now = Just $ alertOf BASupportEnded endsAt
-  | otherwise = (\BadgeIssueError {failedSince} -> alertOf BAIssueFailed failedSince) <$> shownIssueError now p shownCred
+-- Restore moved its payment to another key, so nothing of this purchase ended, lapsed or failed
+derivedBadgeAlert _ _ _ b | paymentMovedOut b = Nothing
+derivedBadgeAlert now p@UserBadgePurchase {purchaseKind, shown} shownCred b = case purchaseKind of
+  PKPrepaid
+    | endsAt <= now -> Just $ alertOf BASupportEnded endsAt
+    | otherwise -> issueFailed
+  PKSubscription s@BadgeSubscription {status}
+    -- a subscription still shown past paidThrough is waiting for its store to charge, not ended
+    | endsAt <= now && not shown -> Just $ alertOf BASubscriptionEnded endsAt
+    | status == Just SSBillingRetry -> Just $ alertOf BAPaymentIssue endsAt
+    | isJust issueFailed -> issueFailed
+    | now < endsAt && status == Just SSCancelled -> Just $ alertOf BASubscriptionCancelled endsAt
+    | now < endsAt && maybe False (<= now) (renewalReminderAt s b) -> Just $ alertOf BARenewalApproaching endsAt
+    | otherwise -> Nothing
   where
     endsAt = L.paidThrough b
+    issueFailed = (\BadgeIssueError {failedSince} -> alertOf BAIssueFailed failedSince) <$> shownIssueError now p shownCred
     alertOf kind date = BadgeAlert {kind, episode = safeDecodeUtf8 $ strEncode date, date, price = Nothing}
 
+-- | Only an annual plan is reminded of: with no way to turn reminders off, a monthly one would come every month.
+renewalReminderAt :: BadgeSubscription -> StatementEntry -> Maybe UTCTime
+renewalReminderAt BadgeSubscription {planMonths, status} b
+  | planMonths == 12 && status == Just SSRenewing = Just $ negate renewalReminderLead `addUTCTime` L.paidThrough b
+  | otherwise = Nothing
+
+renewalReminderLead :: NominalDiffTime
+renewalReminderLead = 3 * nominalDay
+
 -- | A failure that can clear on its own is only shown once the credential lapses and contacts see it.
 shownIssueError :: UTCTime -> UserBadgePurchase -> Maybe BadgeCredential -> Maybe BadgeIssueError
 shownIssueError now UserBadgePurchase {issueError} shownCred = case issueError of
@@ -5823,7 +6159,8 @@ emitBadgeAlert user emitted p@UserBadgePurchase {alertSnoozeUntil} shownCred now
 badgeStateResponse :: User -> CM ChatResponse
 badgeStateResponse user = do
   badgeState <- getUserBadgeState user
-  CRBadgeState user badgeState . map finalError <$> withStore' (`getOpenStorePurchases` user)
+  now <- badgeNow
+  CRBadgeState user badgeState . map finalError <$> withStore' (\db -> getOpenStorePurchases db user now)
   where
     -- like a renewal's, only a failure that cannot clear on its own is the user's to know about
     finalError p@OpenStorePurchase {creditError} = p {creditError = find (not . badgeFailureTransient) creditError}
@@ -5837,8 +6174,12 @@ getUserBadgeState user = do
     Just p@UserBadgePurchase {badgePurchaseId} ->
       fmap (badgeStateOf now p) <$> withStore' (`getBadgeLedgerLastEntry` badgePurchaseId)
   where
-    badgeStateOf now p@UserBadgePurchase {badgePurchaseId, purchaseKey, badgeType, shown, nextWakeAt} balance =
+    badgeStateOf now p@UserBadgePurchase {badgePurchaseId, purchaseKey, badgeType, shown, nextWakeAt, purchaseKind} balance =
       let shownCred = shownBadgeCredential user p
+          subscription = case purchaseKind of
+            PKSubscription s -> Just s
+            PKPrepaid -> Nothing
+          (renewsAt, willRenew) = badgeRenewal (L.paidThrough balance) subscription
        in BadgeState
             { badgePurchaseId,
               purchaseKey,
@@ -5846,18 +6187,32 @@ getUserBadgeState user = do
               shown = BoolDef shown,
               monthsLeft = balanceMonths balance,
               paidThrough = L.paidThrough balance,
-              renewsAt = Nothing,
-              willRenew = False,
+              renewsAt,
+              willRenew,
               alert = unansweredBadgeAlert now p shownCred balance,
               issueError = shownIssueError now p shownCred,
-              nextWakeAt
+              nextWakeAt,
+              subscription
             }
 
--- | How long a month that did not issue waits before it is tried again, whatever stopped it. Not
--- derived from the failure, so a misclassified one cannot leave a funded badge to expire.
+-- | renewsAt and willRenew predate the subscription's state, and say only whether it was last seen renewing.
+badgeRenewal :: UTCTime -> Maybe BadgeSubscription -> (Maybe UTCTime, Bool)
+badgeRenewal paidThrough = \case
+  Just BadgeSubscription {status = Just SSRenewing} -> (Just paidThrough, True)
+  _ -> (Nothing, False)
+
+-- | The longest a month that did not issue waits before it is tried again, whatever stopped it: until the next
+-- daily moment of the shown expiry, or this long after a thrown error. Not derived from the failure, so a
+-- misclassified one cannot leave a funded badge to expire.
 badgeStalledInterval :: NominalDiffTime
 badgeStalledInterval = nominalDay
 
+-- | Counted from the first answer after which the ledger covered nothing. Apple retries a failed renewal for up to 60 days, the
+-- longest either store recovers one with Play's pause off (its grace and hold default to 60 days together); a week more, the grace
+-- contacts give an expired credential, covers Play's period ending days after the ledger's and the daily request that finds a charge.
+subscriptionRecoveryWindow :: NominalDiffTime
+subscriptionRecoveryWindow = 60 * nominalDay + badgeGraceInterval
+
 -- | The wait after a service refusal, floored at initialInterval so answering 0 cannot spin the
 -- worker, and uncapped above it.
 badgeRetryAfter :: RetryInterval -> Maybe Word32 -> NominalDiffTime
@@ -5885,10 +6240,14 @@ credentialExpiry (BadgeCredential _ _ _ BadgeInfo {badgeExpiry}) = badgeExpiry
 
 -- | Timed off the shown credential, not the period end: renewing around its shared expiry is what
 -- joins the anonymity set. Latest still equal to shown means this month has not been asked for.
-badgeRequestDue :: UTCTime -> Maybe BadgeCredential -> Maybe BadgeCredential -> StatementEntry -> Bool
-badgeRequestDue now shownCred latestCred balance =
-  balanceMonths balance > 0 && latestCred == shownCred && maybe False lapsingSoon shownCred
+-- A subscription is asked about at zero months too: its next month comes from a store charge.
+badgeRequestDue :: UTCTime -> PurchaseKind -> Maybe BadgeCredential -> Maybe BadgeCredential -> StatementEntry -> Bool
+badgeRequestDue now purchaseKind shownCred latestCred balance =
+  (balanceMonths balance > 0 || subscribed) && latestCred == shownCred && maybe False lapsingSoon shownCred
   where
+    subscribed = case purchaseKind of
+      PKSubscription _ -> True
+      PKPrepaid -> False
     lapsingSoon cred = credentialExpiry cred <= badgeRequestLead `addUTCTime` now
 
 -- | The request and the presentation, a day apart, both read off the credential the profile shows,
@@ -5907,6 +6266,14 @@ badgeBoundary now shownCred balance = case filter (> now) moments of
       let expiry = credentialExpiry cred
        in [negate badgeRequestLead `addUTCTime` expiry, expiry]
 
+-- | The first moment after now a whole number of stall intervals from the shown credential's expiry. Every client whose
+-- credential shares that expiry asks at these moments, so a request an activation sent late is followed by one among them.
+badgeStallUntil :: UTCTime -> BadgeCredential -> UTCTime
+badgeStallUntil now cred = (fromInteger (stalls + 1) * badgeStalledInterval) `addUTCTime` expiry
+  where
+    expiry = credentialExpiry cred
+    stalls = floor $ diffUTCTime now expiry / badgeStalledInterval
+
 earliestTime :: [Maybe UTCTime] -> Maybe UTCTime
 earliestTime ts = case catMaybes ts of
   [] -> Nothing
@@ -5938,64 +6305,78 @@ badgeFailureTransient = \case
   BIFUnexpected {} -> False
 
 -- | Only a failure that can clear on its own is repeated; every other throw is terminal, and
--- repeating it would spin. Service errors are classified by retryAfter in requestBadgeIssue.
+-- repeating it would spin. Service errors are classified by retryAfter in sendBadgeIssue.
 badgeErrorRetry :: ChatError -> Bool
 badgeErrorRetry = badgeFailureTransient . badgeIssueFailure
 
 -- | Ask the service for the month that is due and apply the response. A timeout stores no ledger row,
--- so the same request is sent again on the next pass. 'Left' is a service error, already reported, and
--- carries when to try again, since a service error is answered rather than thrown. Any request that
+-- so the same request is sent again on the next pass. 'Left' is a service error, already reported,
+-- since a service error is answered rather than thrown. Any request that
 -- ends without a credential the ledger still owes is recorded on the purchase as a failed renewal;
 -- nothing else records one.
-requestBadgeIssue :: UserId -> UserBadgePurchase -> UTCTime -> CM (Either UTCTime StatementEntry)
-requestBadgeIssue userId UserBadgePurchase {badgePurchaseId, badgeType, purchaseKey, purchasePrivKey, masterKey} now = do
+requestBadgeIssue :: UserId -> UserBadgePurchase -> UTCTime -> CM (Either (BadgeServiceErrorCode, Maybe Word32) (StatementEntry, Maybe SubscriptionState))
+requestBadgeIssue userId p now = do
   sendTarget <- asks (badgeServiceAddress . config) >>= maybe (throwCmdError "badge service not configured") pure
-  withEntityLock "badgeIssue" (CLBadgeUser userId) $ do
-    user <- withStore $ \db -> getUser db userId
-    lastEntry <- withStore' (`getBadgeLedgerLastEntry` badgePurchaseId) >>= maybe (throwCmdError "badge ledger has no entry to assert") pure
-    let req =
-          BadgeServiceRequest
-            { version = currentBadgeServiceVersion,
-              purchaseKey = Just purchaseKey,
-              request = BSCIssueBadge {balance = BadgeBalance {lastEntry}}
-            }
-    respData <-
-      sendServiceRequestTo NRMBackground user sendTarget Nothing (Just purchasePrivKey) req
-        `catchAllErrors` \e -> recordFailure (badgeIssueFailure e) >> throwError e
-    case J.fromJSON (J.Object respData) of
-      J.Success BSPBadgeCredential {credential = sentCred_, statement} -> do
-        verifiedCred_ <- verifyIssuedCredential masterKey sentCred_
-        g <- asks random
-        -- read again: now was taken before a lock wait and an untimed request, and the check reads
-        -- it as the client's clock against the timestamps the service put on the rows
-        storedAt <- badgeNow
-        (applied, balance_) <- withStore' $ \db -> do
-          applied <- applyBadgeStatement db g badgePurchaseId badgeType statement verifiedCred_ storedAt
-          (applied,) <$> getBadgeLedgerLastEntry db badgePurchaseId
-        -- the statement is applied either way, so a month can be spent with nothing to show for it
-        case (sentCred_, verifiedCred_, applied) of
-          (Just _, Nothing, _) -> recordFailure BIFInvalidCredential
-          (_, _, False) -> recordUnexpected "issued badge credential has no ledger row to store it against"
-          -- no credential is the service saying the months ran out, which its statement then shows
-          (Nothing, _, _) | maybe False ((> 0) . balanceMonths) balance_ -> recordUnexpected "badge service issued no credential"
-          _ -> pure ()
-        maybe (throwCmdError "badge ledger has no balance") (pure . Right) balance_
-      J.Success BSPError {code, retryAfter} -> do
-        eToView $ ChatError $ CECommandError $ "badge service error: " <> T.unpack (badgeServiceErrorText code)
-        recordFailure BIFServiceError {code = boundedServiceErrorCode code, retryable = isJust retryAfter}
-        ri <- asks $ badgeRetryInterval . config
-        pure $ Left $ badgeRetryAfter ri retryAfter `addUTCTime` now
-      _ -> do
-        recordFailure BIFUnexpected {message = unexpectedResponse}
-        throwCmdError $ T.unpack unexpectedResponse
+  withEntityLock "badgeIssue" (CLBadgeUser userId) $ sendBadgeIssue sendTarget userId p BSCIssueBadge (recordBadgeIssueFailure p) now
+
+recordBadgeIssueFailure :: UserBadgePurchase -> BadgeIssueFailure -> CM ()
+recordBadgeIssueFailure UserBadgePurchase {badgePurchaseId} failure = do
+  failedAt <- badgeNow
+  withStore' $ \db -> setBadgeIssueError db badgePurchaseId failedAt failure
+
+-- | 'requestBadgeIssue' for a caller that already holds the owner's badge lock, which is not reentrant.
+sendBadgeIssue :: ConnectTarget 'CMContact -> UserId -> UserBadgePurchase -> (BadgeBalance -> BadgeServiceCommand) -> (BadgeIssueFailure -> CM ()) -> UTCTime -> CM (Either (BadgeServiceErrorCode, Maybe Word32) (StatementEntry, Maybe SubscriptionState))
+sendBadgeIssue sendTarget userId UserBadgePurchase {badgePurchaseId, badgeType, purchaseKey, purchasePrivKey, masterKey} command recordFailure now = do
+  user <- withStore $ \db -> getUser db userId
+  lastEntry <- withStore' (`getBadgeLedgerLastEntry` badgePurchaseId) >>= maybe (throwCmdError "badge ledger has no entry to assert") pure
+  let req =
+        BadgeServiceRequest
+          { version = currentBadgeServiceVersion,
+            purchaseKey = Just purchaseKey,
+            request = command BadgeBalance {lastEntry}
+          }
+  respData <-
+    sendServiceRequestTo NRMBackground user sendTarget Nothing (Just purchasePrivKey) req
+      `catchAllErrors` \e -> recordFailure (badgeIssueFailure e) >> throwError e
+  case J.fromJSON (J.Object respData) of
+    J.Success BSPBadgeCredential {credential = sentCred_, statement, subscription} -> do
+      verifiedCred_ <- verifyIssuedCredential masterKey sentCred_
+      g <- asks random
+      -- read again: now was taken before a lock wait and an untimed request, and the check reads
+      -- it as the client's clock against the timestamps the service put on the rows
+      storedAt <- badgeNow
+      let -- past the asserted coverage the state is the store's, except within an hour of an earlier check, when it can be
+          -- the last successful check's (a later fresh answer or device report corrects it); before then it can be a year old.
+          -- Ended is never stale: the service answers it only from a store check, or once the payment moved to another key, after which it grants nothing.
+          -- Its receiver must retire on it: a pass reads a stored ended with the badge still shown as the device's report
+          storedSubscription = boundedSubscriptionState <$> find (\s -> L.paidThrough lastEntry <= now || s == SSEnded) subscription
+      (applied, balance_) <- withStore' $ \db -> do
+        applied <- applyBadgeStatement db g badgePurchaseId badgeType statement verifiedCred_ storedAt
+        forM_ storedSubscription $ setBadgeSubscriptionStatus db badgePurchaseId
+        (applied,) <$> getBadgeLedgerLastEntry db badgePurchaseId
+      -- the statement is applied either way, so a month can be spent with nothing to show for it
+      case (sentCred_, verifiedCred_, applied) of
+        (Just _, Nothing, _) -> recordFailure BIFInvalidCredential
+        (_, _, False) -> recordUnexpected "issued badge credential has no ledger row to store it against"
+        -- no credential is the service saying nothing is owed - the months ran out, or a subscription
+        -- waits for its store to charge - which its statement then shows; ended after a move leaves the issued month running
+        (Nothing, _, _) | subscription /= Just SSEnded && maybe False ((> storedAt) . L.paidThrough) balance_ -> recordUnexpected "badge service issued no credential"
+        _ -> pure ()
+      maybe (throwCmdError "badge ledger has no balance") (pure . Right . (,storedSubscription)) balance_
+    J.Success BSPError {code, retryAfter} -> do
+      eToView $ ChatError $ CECommandError $ "badge service error: " <> T.unpack (badgeServiceErrorText code)
+      -- retryAfter only marks the failure as one that can clear: the retry waits a stall like any request that
+      -- issued nothing, since a shorter wait would let the service choose how often activations reach it
+      recordFailure BIFServiceError {code = boundedServiceErrorCode code, retryable = isJust retryAfter}
+      pure $ Left (code, retryAfter)
+    _ -> do
+      recordFailure BIFUnexpected {message = unexpectedResponse}
+      throwCmdError $ T.unpack unexpectedResponse
   where
     unexpectedResponse = "unexpected badge service response"
     recordUnexpected message = do
       eToView $ ChatError $ CEInternalError $ T.unpack message
       recordFailure BIFUnexpected {message}
-    recordFailure failure = do
-      failedAt <- badgeNow
-      withStore' $ \db -> setBadgeIssueError db badgePurchaseId failedAt failure
 
 -- | The signature covers the master key inside the credential, so it verifies no matter which key
 -- that is - the credential is stored only when that key is also this purchase's.
@@ -6020,15 +6401,19 @@ presentIssuedBadge user p@UserBadgePurchase {badgePurchaseId, shown} now
           presentUserBadgeToContacts user'
   where
     shownCred = shownBadgeCredential user p
+    shownType = (\(BadgeCredential _ _ _ BadgeInfo {badgeType}) -> badgeType) <$> shownCred
     -- Held back until the shown credential lapses, so the broadcast does not correlate with the
     -- request that produced it. Nothing shown at all is the state a lost profile write leaves.
-    presentDue cred = Just cred /= shownCred && maybe True ((<= now) . credentialExpiry) shownCred
+    -- A raised tier is presented at once, whichever request granted it: the subscriber raised it in
+    -- the store, so the broadcast tells it nothing new; a lower tier keeps the hold-back.
+    presentDue cred@(BadgeCredential _ _ _ BadgeInfo {badgeType}) =
+      Just cred /= shownCred && (maybe False (`raisesTier` badgeType) shownType || maybe True ((<= now) . credentialExpiry) shownCred)
 
--- | The visible half of "the badge expired".
-retireExpiredBadge :: User -> UserBadgePurchase -> UTCTime -> StatementEntry -> CM Bool
-retireExpiredBadge user UserBadgePurchase {badgePurchaseId, shown} now balance
-  | not (shown && L.paidThrough balance <= now) = pure False
-  | otherwise = withUserProfileLock "retireExpiredBadge" $ do
+-- | The visible half of "the badge ended".
+retireBadge :: User -> UserBadgePurchase -> CM Bool
+retireBadge user UserBadgePurchase {badgePurchaseId, shown}
+  | not shown = pure False
+  | otherwise = withUserProfileLock "retireBadge" $ do
       user' <- withStore $ \db -> do
         liftIO $ clearShownBadge db user badgePurchaseId
         setUserBadge db user Nothing
@@ -6043,11 +6428,11 @@ stopBadgeWorkers workers =
     cancelBadgeWorker v =
       void $ forkIO $ atomically (badgeWorkerAsync <$> readTMVar (sessionVar v)) >>= uninterruptibleCancel
 
--- | Verify the credential before writing anything; the purchase, the statement's rows, the
--- issuance and the profile's badge go in one transaction. Answers the user to tell contacts about,
+-- | Verify the credential before writing anything; the purchase, its subscription's state, the statement's
+-- rows, the issuance and the profile's badge go in one transaction. Answers the user to tell contacts about,
 -- which the caller does once the badge lock is released.
-storeRedeemedBadge :: User -> BadgeStash -> BadgeCredential -> BadgeStatement -> CM (Maybe User, ChatResponse)
-storeRedeemedBadge user@User {userId} stash@BadgeStash {masterKey} cred@(BadgeCredential _ credMasterKey _ info@BadgeInfo {badgeType}) statement =
+storeRedeemedBadge :: User -> BadgeStash -> BadgeCredential -> BadgeStatement -> Maybe SubscriptionState -> CM (Maybe User, ChatResponse)
+storeRedeemedBadge user@User {userId} stash@BadgeStash {masterKey} cred@(BadgeCredential _ credMasterKey _ info@BadgeInfo {badgeType}) statement subscription_ =
   verifyOwnBadge cred >>= \case
     Nothing -> throwRedeemError BREUnknownKeyIndex
     Just False -> throwRedeemError BRECredentialNotVerified
@@ -6061,6 +6446,7 @@ storeRedeemedBadge user@User {userId} stash@BadgeStash {masterKey} cred@(BadgeCr
       -- TODO [badges] retire a previously held badge
       (user', newBadge, applied) <- withStore $ \db -> do
         (purchaseId, newBadge) <- liftIO $ createStashBadgePurchase db user stash cred now
+        when newBadge $ forM_ subscription_ $ liftIO . setBadgeSubscriptionStatus db purchaseId
         applied <- liftIO $ applyBadgeStatement db g purchaseId badgeType statement (Just cred) now
         -- a replay must not put a superseded badge back, or tell every contact again
         user' <- if newBadge then setUserBadge db user (Just badge) else getUser db userId
@@ -6080,6 +6466,7 @@ applyBadgeStatement db g purchaseId badgeType BadgeStatement {entries} cred_ now
   -- and restate as one opening credit instead (badges-rpc.md), which is checked without a tip.
   tip <- getBadgeLedgerLastEntry db purchaseId
   storeBadgeStatement db purchaseId badgeType tip entries now
+  getBadgeLedgerLastEntry db purchaseId >>= mapM_ (\StatementEntry {balanceBadgeType} -> setBadgePurchaseType db purchaseId balanceBadgeType now)
   case (,) <$> cred_ <*> issuedEntryId of
     Nothing -> pure True
     Just (cred, entryUuid) ->
@@ -6507,11 +6894,13 @@ chatCommandP =
       "/_reject " *> (APIRejectContact <$> A.decimal <*> (" notify=" *> onOffP <|> pure False)),
       "/_service_request " *> (APISendServiceRequest <$> A.decimal <* A.space <*> strP <*> optional (" timeout=" *> (realToFrac <$> A.double)) <*> optional (" sign_key=" *> strP) <* A.space <*> jsonP),
       "/_redeem_badge_code " *> (APIRedeemBadgeCode <$> A.decimal <* A.space <*> textP),
-      "/_badge purchase " *> (APIPurchaseBadge <$> A.decimal <*> optional (" invoice=" *> (safeDecodeUtf8 <$> A.takeTill (== ' '))) <* A.space <*> jsonP),
+      "/_badge purchase " *> (APIPurchaseBadge <$> A.decimal <*> optional (" invoice=" *> (safeDecodeUtf8 <$> A.takeTill (== ' '))) <*> (" listed" $> SROListed <|> " restored" $> SRORestored <|> pure SROPurchased) <* A.space <*> jsonP),
+      "/_badge subscription " *> (APISetBadgeSubscriptionStatus <$> subscriptionStateP <* A.space <*> jsonP),
       "/_badge invoice " *> (APICreateBadgeInvoice <$> A.decimal),
       "/_badge state " *> (APIGetBadgeState <$> A.decimal),
       "/_badge ledger " *> (APIGetBadgeLedger <$> A.decimal <* A.space <*> A.decimal),
       "/_badge ack " *> (APIAckBadgeAlert <$> A.decimal <* A.space <*> A.decimal <* A.space <*> badgeAlertKindP <* A.space <*> onOffP <* A.space <*> textP),
+      "/_badge request " *> (APIRequestBadge <$> A.decimal),
       "/_service_response " *> (APISendServiceResponse <$> A.decimal <* A.space <*> strP <* A.space <*> jsonP),
       "/_wallet create new" $> APICreateWallet,
       "/_wallet create account " *> (APICreateWalletAccount <$> A.decimal),
@@ -6943,6 +7332,13 @@ chatCommandP =
     badgeAlertKindP = do
       t <- A.takeTill (== ' ')
       maybe (fail "bad badge alert kind") pure $ textDecode $ safeDecodeUtf8 t
+    subscriptionStateP =
+      A.takeTill (== ' ') >>= \case
+        "renewing" -> pure SSRenewing
+        "cancelled" -> pure SSCancelled
+        "billingRetry" -> pure SSBillingRetry
+        "ended" -> pure SSEnded
+        _ -> fail "bad subscription state"
     pwdP = jsonP <|> (UserPwd . safeDecodeUtf8 <$> A.takeTill (== ' '))
     verifyCodeP = safeDecodeUtf8 <$> A.takeWhile (\c -> isDigit c || c == ' ')
     msgTextP = jsonP <|> textP

src/Simplex/Chat/Library/Subscriber.hs

@@ -1688,22 +1688,26 @@ processAgentMessageConn cxt user@User {userId} entity gks_ corrId agentConnId ag
               User {userChatRelay} = user
         -- TODO [relays] owner, relays: TBC how to communicate member rejection rules from owner to relays
         memberJoinRequestViaRelay :: InvitationId -> VersionRangeChat -> Maybe SignedMsg -> Profile -> MemberId -> MemberKey -> Maybe MemberId -> CM ()
-        memberJoinRequestViaRelay invId chatVRange signedMsg_ p joiningMemberId joiningMemberKey@(MemberKey joiningKey) viaRelay = do
+        memberJoinRequestViaRelay invId chatVRange signedMsg_ p@Profile {displayName} joiningMemberId joiningMemberKey@(MemberKey joiningKey) viaRelay = do
           (_ucl, gLinkInfo_) <- withStore $ \db -> getUserContactLinkById db userId uclId
           case gLinkInfo_ of
             Just GroupLinkInfo {groupId, memberRole = gLinkMemRole} -> do
               g@(GIK gInfo _) <- withStore $ \db -> getGroupInfoKeys db cxt user groupId
-              existing_ <- withStore' $ \db -> eitherToMaybe <$> runExceptT (getGroupMemberByMemberId db cxt user gInfo joiningMemberId)
-              let signed = memberSigned gInfo joiningMemberId joiningKey signedMsg_
-              case existing_ of
-                Just rosterMem
-                  -- a privileged memberId's key is owner-authoritative (the roster); the joiner must prove
-                  -- possession of that exact key, otherwise this is an attempt to impersonate it
-                  | isRosterRole (memberRole' rosterMem) ->
-                      if verifyKey gInfo rosterMem signed
-                        then acceptJoin g signed (Just rosterMem) (memberRole' rosterMem)
-                        else messageError "memberJoinRequestViaRelay: rejected join claiming privileged memberId (key mismatch or invalid signature)"
-                _ -> acceptJoin g signed Nothing gLinkMemRole
+              if
+                | not (useRelays' gInfo) ->
+                    messageWarning $ "memberJoinRequestViaRelay (group " <> groupName' gInfo <> "): ignored relay join request from " <> displayName <> " (group does not use relays)"
+                | otherwise -> do
+                    existing_ <- withStore' $ \db -> eitherToMaybe <$> runExceptT (getGroupMemberByMemberId db cxt user gInfo joiningMemberId)
+                    let signed = memberSigned gInfo joiningMemberId joiningKey signedMsg_
+                    case existing_ of
+                      Just rosterMem
+                        -- a privileged memberId's key is owner-authoritative (the roster); the joiner must prove
+                        -- possession of that exact key, otherwise this is an attempt to impersonate it
+                        | isRosterRole (memberRole' rosterMem) ->
+                            if verifyKey gInfo rosterMem signed
+                              then acceptJoin g signed (Just rosterMem) (memberRole' rosterMem)
+                              else messageError "memberJoinRequestViaRelay: rejected join claiming privileged memberId (key mismatch or invalid signature)"
+                      _ -> acceptJoin g signed Nothing gLinkMemRole
             Nothing ->
               messageError "memberJoinRequestViaRelay: no group link info for relay link"
           where

src/Simplex/Chat/PaymentService.hs

@@ -1,19 +1,29 @@
 {-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TemplateHaskell #-}
 
 module Simplex.Chat.PaymentService
   ( ServiceInvoice (..),
     ServicePayment (..),
-    appleTransactionId,
+    AppleTransactionFacts (..),
+    applePayload,
+    appleTransactionRef,
+    applePayloadRef,
+    appleTransactionFacts,
     googlePurchaseRef,
     module Simplex.Chat.PaymentService.Types,
   ) where
 
+import Control.Applicative ((<|>))
+import Control.Monad ((<=<))
 import qualified Data.Aeson as J
 import qualified Data.Aeson.KeyMap as JM
 import qualified Data.Aeson.TH as JQ
+import qualified Data.Aeson.Types as JT
 import qualified Data.ByteString.Base64.URL as B64U
+import Data.Int (Int64)
+import Data.Maybe (isJust)
 import Data.Text (Text)
 import qualified Data.Text as T
 import Data.Text.Encoding (encodeUtf8)
@@ -44,14 +54,53 @@ data ServicePayment
   deriving (Show)
 
 -- | Read without verifying the signature: it names the transaction, and proves nothing about it.
-appleTransactionId :: Text -> Maybe Text
-appleTransactionId signed = case T.splitOn "." signed of
+applePayload :: Text -> Maybe J.Object
+applePayload signed = case T.splitOn "." signed of
   [_, payload, _] -> do
     J.Object o <- J.decodeStrict' =<< eitherToMaybe (B64U.decodeUnpadded $ encodeUtf8 payload)
-    J.String txId <- JM.lookup "transactionId" o
-    pure txId
+    Just o
   _ -> Nothing
 
+appleTransactionRef :: Text -> Maybe Text
+appleTransactionRef = applePayloadRef <=< applePayload
+
+-- | What an unverified payload says about its transaction, which decides only which payment a held record
+-- presents next: the service verifies whatever it is sent.
+data AppleTransactionFacts = AppleTransactionFacts
+  { transactionId :: Text,
+    productId :: Maybe Text,
+    purchaseDate :: Maybe Int64, -- epoch milliseconds
+    expiresDate :: Maybe Int64, -- epoch milliseconds
+    revoked :: Bool,
+    autoRenewable :: Bool
+  }
+  deriving (Eq, Show)
+
+-- | A date or type that does not read is taken as absent rather than failing the whole payload.
+appleTransactionFacts :: Text -> Maybe AppleTransactionFacts
+appleTransactionFacts = JT.parseMaybe facts <=< applePayload
+  where
+    facts o = do
+      transactionId <- o J..: "transactionId"
+      productId <- o J..:? "productId" <|> pure Nothing
+      purchaseDate <- o J..:? "purchaseDate" <|> pure Nothing
+      expiresDate <- o J..:? "expiresDate" <|> pure Nothing
+      -- as the service reads it: null is not revoked
+      revoked <- isJust <$> (o J..:? "revocationDate" :: JT.Parser (Maybe J.Value))
+      type_ <- o J..:? "type" <|> pure Nothing
+      pure AppleTransactionFacts {transactionId, productId, purchaseDate, expiresDate, revoked, autoRenewable = type_ == Just ("Auto-Renewable Subscription" :: Text)}
+
+-- | A subscription is named by its original transaction id, which every renewal keeps, so all its
+-- charges claim one purchase; any other transaction by its own id.
+applePayloadRef :: J.Object -> Maybe Text
+applePayloadRef o = case JM.lookup "type" o of
+  Just (J.String "Auto-Renewable Subscription") -> field "originalTransactionId"
+  _ -> field "transactionId"
+  where
+    field k = case JM.lookup k o of
+      Just (J.String t) -> Just t
+      _ -> Nothing
+
 -- | A purchase token is a bearer secret, so a purchase is named by its hash.
 googlePurchaseRef :: Text -> Text
 googlePurchaseRef = safeDecodeUtf8 . strEncode . C.sha256Hash . encodeUtf8

src/Simplex/Chat/Store/Badges.hs

@@ -10,23 +10,40 @@ module Simplex.Chat.Store.Badges
   ( BadgeStash (..),
     BadgeStashRef (..),
     UserBadgePurchase (..),
+    UnrenewedRun (..),
+    PurchaseKind (..),
     getUserBadgePurchase,
     getBadgePurchase,
+    setBadgeSubscriptionStatus,
     userHasBadge,
     setBadgeAlertAcked,
     setBadgeIssueError,
     setBadgeNextWake,
+    setBadgeUnrenewedRun,
     clearShownBadge,
     getBadgeCodeRedemption,
     createBadgeCodeRedemption,
     BadgeReceiptRecord (..),
     BadgeReceiptStatus (..),
+    StoreHoldKind (..),
     holdStoreReceipt,
+    holdStoreTransfer,
+    purchaseUnreached,
+    purchaseMovedOut,
+    paymentMovedOut,
+    getReceiptRecord,
     createBadgeStoreReceipt,
     getOpenStorePurchases,
+    getPendingStoreReceipts,
     getNextHeldStoreReceipt,
+    getStoreReceiptFailures,
+    storeReceiptHeldFor,
     recordStoreReceiptFailure,
     refuseStoreReceipt,
+    clearStoreReceiptRefusal,
+    settleStoreReceipt,
+    reholdStoreReceipt,
+    showChargedPurchase,
     deleteUnfundedStoreReceipts,
     deleteBadgeCodeRedemption,
     createStashBadgePurchase,
@@ -34,43 +51,51 @@ module Simplex.Chat.Store.Badges
     storeBadgeIssuance,
     getLatestIssuedCredential,
     storeBadgeStatement,
+    setBadgePurchaseType,
     getBadgeLedgerLastEntry,
+    getLastChargeCreditAt,
     getBadgeLedger,
     getBadgeLedgerEntryId,
   )
 where
 
 import Control.Concurrent.STM (TVar, atomically)
-import Control.Monad (forM, forM_, join)
+import Control.Monad (forM, forM_, join, when)
 import Crypto.Random (ChaChaDRG)
 import qualified Data.Aeson as J
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Lazy.Char8 as LB
 import Data.Int (Int64)
+import Data.List (find)
 import Data.Maybe (isJust, mapMaybe)
 import Data.Text (Text)
-import Data.Time.Clock (UTCTime)
+import Data.Time.Clock (UTCTime, addUTCTime, nominalDay)
+import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
 import Simplex.Chat.Badges
 import Simplex.Chat.Badges.Ledger
 import Simplex.Chat.Badges.Service (StatementCreditType (..), StatementDebitType (..), StatementEntry (..), StatementEntryType (..))
-import Simplex.Chat.Badges.Types (BadgeAlertKind, BadgeIssueError (..), BadgeIssueFailure, BadgePurchaseStatus (..), OpenStorePurchase (..))
-import Simplex.Chat.PaymentService (ServicePayment)
+import Simplex.Chat.Badges.Types (BadgeAlertKind, BadgeIssueError (..), BadgeIssueFailure (..), BadgePurchaseStatus (..), BadgeServiceErrorCode (..), BadgeSubscription (..), OpenStorePurchase (..), StoreReceiptOrigin (..), SubscriptionState (..))
+import Simplex.Chat.PaymentService (AppleTransactionFacts (..), ServicePayment (..), appleTransactionFacts)
 import Simplex.Chat.PaymentService.Types (StoreTransactionRef (..))
 import Simplex.Chat.Store.Shared (StoreError, insertedRowId)
 import Simplex.Chat.Types
 import Simplex.Messaging.Agent.Protocol (UserId)
-import Simplex.Messaging.Agent.Store.DB (Binary (..), BoolInt (..))
+import Simplex.Messaging.Agent.Store.DB (Binary (..), BoolInt (..), fromTextField_)
 import qualified Simplex.Messaging.Agent.Store.DB as DB
 import qualified Simplex.Messaging.Crypto as C
-import Simplex.Messaging.Encoding.String (strEncode)
+import Simplex.Messaging.Encoding.String (TextEncoding (..), strEncode)
 import Simplex.Messaging.Util (decodeJSON, maybeFirstRow, maybeFirstRow', safeDecodeUtf8)
 
 #if defined(dbPostgres)
 import Database.PostgreSQL.Simple (Only (..), (:.) (..))
+import Database.PostgreSQL.Simple.FromField (FromField (..))
 import Database.PostgreSQL.Simple.SqlQQ (sql)
+import Database.PostgreSQL.Simple.ToField (ToField (..))
 #else
 import Database.SQLite.Simple (Only (..), (:.) (..))
+import Database.SQLite.Simple.FromField (FromField (..))
 import Database.SQLite.Simple.QQ (sql)
+import Database.SQLite.Simple.ToField (ToField (..))
 #endif
 
 -- | The keys one attempt to fund a badge is signed with, stashed before the request is sent so that
@@ -118,22 +143,66 @@ data BadgeReceiptRecord = BadgeReceiptRecord
   }
 
 data BadgeReceiptStatus
-  = RSHeld {stash :: BadgeStash, invoiceId :: Maybe Text, payment :: Text, nextAttemptAt :: UTCTime, retryDelay :: Maybe Int64}
-  | RSCredited {badgePurchaseId :: Int64}
+  = RSHeld {stash :: BadgeStash, invoiceId :: Maybe Text, payment :: Text, nextAttemptAt :: UTCTime, retryDelay :: Maybe Int64, holdKind :: StoreHoldKind}
+  | RSCredited {badgePurchaseId :: Int64, refusalRecorded :: Bool} -- a resume or a tier change of it was refused
   | RSRefused {refusal :: Maybe BadgeIssueFailure}
 
+-- | What a held record waits for: its own purchase, or the resume of one, a move of its payment to new keys,
+-- or a change of the tier of the purchase it funds.
+data StoreHoldKind = SHKPurchase | SHKTransfer | SHKTierChange
+  deriving (Eq, Show)
+
+instance TextEncoding StoreHoldKind where
+  textEncode = \case
+    SHKPurchase -> "purchase"
+    SHKTransfer -> "transfer"
+    SHKTierChange -> "tier_change"
+  textDecode = \case
+    "purchase" -> Just SHKPurchase
+    "transfer" -> Just SHKTransfer
+    "tier_change" -> Just SHKTierChange
+    _ -> Nothing
+
+instance FromField StoreHoldKind where fromField = fromTextField_ textDecode
+
+instance ToField StoreHoldKind where toField = toField . textEncode
+
 -- | Resolves a store transaction to the record that owns it, looking up by its reference again after each step
 -- rather than trusting the write: finding none still leaves the echoed invoice's record to attach it to, and a
 -- concurrent hand-over of the same transaction may win either write. It stays with the record that already has
 -- it, whose keys the service may have credited; failing that it joins the record Buy created; and when no record
 -- can take it - the store echoed no invoice, or the one it echoed is already held by another transaction - the
--- presenting profile gets a new one, nothing else saying who paid.
-holdStoreReceipt :: DB.Connection -> TVar ChaChaDRG -> User -> Maybe Text -> StoreTransactionRef -> ServicePayment -> UTCTime -> IO (Maybe BadgeReceiptRecord)
-holdStoreReceipt db g User {userId} invoiceId_ txRef@StoreTransactionRef {provider, transactionRef} payment now =
+-- presenting profile gets a new one, nothing else saying who paid, unless the app found the transaction in the
+-- store's list: then it may be another device's, and nothing is recorded.
+holdStoreReceipt :: DB.Connection -> TVar ChaChaDRG -> User -> StoreReceiptOrigin -> Maybe Text -> StoreTransactionRef -> ServicePayment -> UTCTime -> IO (Maybe BadgeReceiptRecord)
+holdStoreReceipt db g User {userId} origin invoiceId_ txRef@StoreTransactionRef {provider, transactionRef} payment now =
   getReceiptRecord db txRef >>= \case
-    Just r@BadgeReceiptRecord {receiptId} -> do
-      -- a resolved record stays resolved, so a hand-over landing just after its credit cannot hold it again
-      DB.execute db "UPDATE badge_store_receipts SET payment = ? WHERE badge_store_receipt_id = ? AND payment IS NOT NULL" (paymentJSON, receiptId)
+    Just r@BadgeReceiptRecord {receiptId, status} -> do
+      -- a resolved record stays resolved here, so a hand-over landing just after its credit cannot hold it again;
+      -- only a resume re-holds a credited one, which the hand-over decides
+      case status of
+        RSHeld {payment = held}
+          | laterAppleTransaction payment held ->
+              DB.execute
+                db
+                "UPDATE badge_store_receipts SET payment = ?, next_attempt_at = ?, retry_delay = NULL, credit_error = NULL WHERE badge_store_receipt_id = ? AND payment = ?"
+                (paymentJSON, now, receiptId, held)
+        _ -> pure ()
+      -- the Buy record the store echoed for this charge is never attached, as the charge continues this record's subscription;
+      -- this record takes its invoice id, so the credit names the charge the app keeps unfinished
+      forM_ invoiceId_ $ \invoiceId -> do
+        deleted <-
+          maybeFirstRow' False ((== (1 :: Int)) . fromOnly) $
+            DB.query
+              db
+              [sql|
+                DELETE FROM badge_store_receipts
+                WHERE invoice_id = ? AND transaction_ref IS NULL AND payment IS NULL
+                  AND NOT EXISTS (SELECT 1 FROM badge_purchases p WHERE p.badge_store_receipt_id = badge_store_receipts.badge_store_receipt_id)
+                RETURNING 1
+              |]
+              (Only invoiceId)
+        when deleted $ DB.execute db "UPDATE badge_store_receipts SET invoice_id = ? WHERE badge_store_receipt_id = ?" (invoiceId, receiptId)
       pure $ Just r
     Nothing -> do
       forM_ invoiceId_ $ \invoiceId ->
@@ -143,12 +212,17 @@ holdStoreReceipt db g User {userId} invoiceId_ txRef@StoreTransactionRef {provid
           (provider, transactionRef, paymentJSON, now, invoiceId)
       getReceiptRecord db txRef >>= \case
         Just r -> pure $ Just r
-        Nothing -> do
-          insertReceipt
-          getReceiptRecord db txRef
+        Nothing -> case origin of
+          SROPurchased -> do
+            insertReceipt SHKPurchase
+            getReceiptRecord db txRef
+          SRORestored -> do
+            insertReceipt SHKTransfer
+            getReceiptRecord db txRef
+          SROListed -> pure Nothing
   where
     paymentJSON = safeDecodeUtf8 . LB.toStrict $ J.encode payment
-    insertReceipt = do
+    insertReceipt holdKind = do
       (purchaseKey, purchasePrivKey) <- atomically (C.generateKeyPair g) :: IO C.KeyPairEd25519
       BadgeMasterKey mk <- generateMasterKey g
       -- an invoice id another record holds is not repeated: this record is then keyed by its transaction alone
@@ -159,11 +233,87 @@ holdStoreReceipt db g User {userId} invoiceId_ txRef@StoreTransactionRef {provid
         db
         [sql|
           INSERT INTO badge_store_receipts
-            (user_id, invoice_id, provider, transaction_ref, payment, next_attempt_at, purchase_key, purchase_priv_key, master_key, created_at)
-          VALUES (?,?,?,?,?,?,?,?,?,?)
+            (user_id, invoice_id, provider, transaction_ref, payment, next_attempt_at, purchase_key, purchase_priv_key, master_key, hold_kind, created_at)
+          VALUES (?,?,?,?,?,?,?,?,?,?,?)
           ON CONFLICT DO NOTHING
         |]
-        ((userId, invoiceId', provider, transactionRef, paymentJSON, now) :. (purchaseKey, purchasePrivKey, Binary mk, now))
+        ((userId, invoiceId', provider, transactionRef, paymentJSON, now) :. (purchaseKey, purchasePrivKey, Binary mk, holdKind, now))
+
+-- | A hand-over of a transaction already recorded, by Restore or by a resubscription no resume reaches: a subscription
+-- record that funds no purchase of this profile, only one its payment moved away from, or one neither shown nor its
+-- owner's newest, is taken by this profile and held as a move of its payment to it; a one-time record never moves.
+-- True when its last refusal was transfer_limited, which the hand-over answers.
+holdStoreTransfer :: DB.Connection -> TVar ChaChaDRG -> User -> StoreTransactionRef -> ServicePayment -> UTCTime -> IO Bool
+holdStoreTransfer db g user@User {userId} txRef payment now =
+  getReceiptRecord db txRef >>= \case
+    Just BadgeReceiptRecord {receiptId, status = RSHeld {stash, holdKind = SHKPurchase}} ->
+      getStashBadgePurchase db stash >>= \case
+        Nothing ->
+          False
+            <$ DB.execute
+              db
+              "UPDATE badge_store_receipts SET user_id = ?, hold_kind = ?, next_attempt_at = ? WHERE badge_store_receipt_id = ? AND payment IS NOT NULL AND hold_kind = ?"
+              (userId, SHKTransfer, now, receiptId, SHKPurchase)
+        Just _ -> pure False
+    Just BadgeReceiptRecord {receiptId, status = RSRefused {refusal = Just BIFServiceError {code}}}
+      | code == BSEReceiptUsed || code == BSETransferLimited -> (code == BSETransferLimited) <$ holdTransfer receiptId
+    Just BadgeReceiptRecord {receiptId, ownerId, status = RSCredited {badgePurchaseId}} ->
+      movesHere ownerId badgePurchaseId >>= \case
+        False -> pure False
+        True -> do
+          lastRefusal <- maybeFirstRow fromOnly $ DB.query db "SELECT credit_error FROM badge_store_receipts WHERE badge_store_receipt_id = ?" (Only receiptId)
+          (purchaseKey, purchasePrivKey) <- atomically (C.generateKeyPair g) :: IO C.KeyPairEd25519
+          BadgeMasterKey mk <- generateMasterKey g
+          DB.execute db "UPDATE badge_store_receipts SET purchase_key = ?, purchase_priv_key = ?, master_key = ? WHERE badge_store_receipt_id = ? AND payment IS NULL" (purchaseKey, purchasePrivKey, Binary mk, receiptId)
+          holdTransfer receiptId
+          pure $ case join lastRefusal of
+            Just BIFServiceError {code = BSETransferLimited} -> True
+            _ -> False
+    _ -> pure False
+  where
+    movesHere ownerId badgePurchaseId =
+      getBadgePurchase db badgePurchaseId >>= \case
+        -- a one-time purchase is never moved, as its months were issued when it was bought
+        Just UserBadgePurchase {purchaseKind = PKSubscription _}
+          | ownerId /= userId -> pure True
+          | otherwise -> (||) <$> purchaseMovedOut db badgePurchaseId <*> purchaseUnreached db user badgePurchaseId
+        _ -> pure False
+    holdTransfer receiptId =
+      DB.execute
+        db
+        "UPDATE badge_store_receipts SET user_id = ?, payment = ?, next_attempt_at = ?, retry_delay = NULL, retry_count = 0, credit_error = NULL, hold_kind = ? WHERE badge_store_receipt_id = ? AND payment IS NULL"
+        (userId, safeDecodeUtf8 . LB.toStrict $ J.encode payment, now, SHKTransfer, receiptId)
+
+-- | A subscription neither shown nor its owner's newest, which no resume reaches.
+purchaseUnreached :: DB.Connection -> User -> Int64 -> IO Bool
+purchaseUnreached db owner badgePurchaseId = do
+  p_ <- getBadgePurchase db badgePurchaseId
+  newestId <- fmap (\UserBadgePurchase {badgePurchaseId = i} -> i) <$> getUserBadgePurchase db owner
+  pure $ case p_ of
+    Just UserBadgePurchase {shown = False, purchaseKind = PKSubscription _} -> newestId /= Just badgePurchaseId
+    _ -> False
+
+-- | The service answers a purchase whose payment moved away ended, so a resume of it never succeeds.
+purchaseMovedOut :: DB.Connection -> Int64 -> IO Bool
+purchaseMovedOut db badgePurchaseId = maybe False paymentMovedOut <$> getBadgeLedgerLastEntry db badgePurchaseId
+
+-- | A ledger tip that moved the purchase's payment to another key.
+paymentMovedOut :: StatementEntry -> Bool
+paymentMovedOut StatementEntry {entryType} = case entryType of
+  SEDebit SDTransferOut {} -> True
+  _ -> False
+
+-- | Whether a held Apple record presents this payment next: another transaction of its subscription, bought
+-- later and not revoked. The core decides which is newest, since the app's store listener races its sweep, and a
+-- re-delivered or re-signed copy of the held transaction changes nothing, so it cannot cost another store check.
+laterAppleTransaction :: ServicePayment -> Text -> Bool
+laterAppleTransaction payment held = case (payment, decodeJSON held) of
+  (SPApple {jws}, Just SPApple {jws = heldJws}) -> case (appleTransactionFacts jws, appleTransactionFacts heldJws) of
+    ( Just AppleTransactionFacts {transactionId, purchaseDate = Just purchasedAt, revoked = False},
+      Just AppleTransactionFacts {transactionId = heldId, purchaseDate = Just heldPurchasedAt}
+      ) -> transactionId /= heldId && purchasedAt > heldPurchasedAt
+    _ -> False
+  _ -> False
 
 getReceiptRecord :: DB.Connection -> StoreTransactionRef -> IO (Maybe BadgeReceiptRecord)
 getReceiptRecord db StoreTransactionRef {provider, transactionRef} =
@@ -172,19 +322,23 @@ getReceiptRecord db StoreTransactionRef {provider, transactionRef} =
       db
       [sql|
         SELECT r.badge_store_receipt_id, r.user_id, r.purchase_key, r.purchase_priv_key, r.master_key,
-          r.invoice_id, r.payment, r.next_attempt_at, r.retry_delay, p.badge_purchase_id, r.credit_error
+          r.invoice_id, r.payment, r.next_attempt_at, r.retry_delay, p.badge_purchase_id, r.credit_error, r.hold_kind
         FROM badge_store_receipts r
         LEFT JOIN badge_purchases p ON p.badge_store_receipt_id = r.badge_store_receipt_id
         WHERE r.provider = ? AND r.transaction_ref = ?
       |]
       (provider, transactionRef)
   where
-    toReceiptRecord ((receiptId, ownerId, purchaseKey, purchasePrivKey, mk) :. (invoiceId, payment_, nextAttemptAt_, retryDelay, purchaseId_, refusal)) =
+    toReceiptRecord ((receiptId, ownerId, purchaseKey, purchasePrivKey, mk) :. (invoiceId, payment_, nextAttemptAt_, retryDelay, purchaseId_, refusal, holdKind)) =
       BadgeReceiptRecord {receiptId, ownerId, status}
       where
         status = case (payment_, nextAttemptAt_) of
-          (Just payment, Just nextAttemptAt) -> RSHeld {stash = toBadgeStash BSRStoreReceipt (receiptId, purchaseKey, purchasePrivKey, mk), invoiceId, payment, nextAttemptAt, retryDelay}
-          _ -> maybe (RSRefused refusal) RSCredited purchaseId_
+          (Just payment, Just nextAttemptAt) -> RSHeld {stash = toBadgeStash BSRStoreReceipt (receiptId, purchaseKey, purchasePrivKey, mk), invoiceId, payment, nextAttemptAt, retryDelay, holdKind}
+          _ -> maybe (RSRefused refusal) (\badgePurchaseId -> RSCredited {badgePurchaseId, refusalRecorded = maybe False ownRefusal refusal}) purchaseId_
+        -- only a move is refused transfer_limited, and a refused move must not hold off the purchase's own resume or tier change
+        ownRefusal = \case
+          BIFServiceError {code = BSETransferLimited} -> False
+          _ -> True
 
 -- | The record made when Buy is tapped, before any receipt: the store echoes its invoice id.
 createBadgeStoreReceipt :: DB.Connection -> TVar ChaChaDRG -> User -> Text -> UTCTime -> IO ()
@@ -199,58 +353,149 @@ createBadgeStoreReceipt db g User {userId} invoiceId now = do
     |]
     (userId, invoiceId, purchaseKey, purchasePrivKey, Binary mk, now)
 
--- | No receipt yet, or one held: a credited or refused record is resolved and not listed.
-getOpenStorePurchases :: DB.Connection -> User -> IO [OpenStorePurchase]
-getOpenStorePurchases db User {userId} =
-  map toOpenStorePurchase
+-- | No receipt yet, or one held and not lapsed: a credited or refused record is resolved and not listed.
+getOpenStorePurchases :: DB.Connection -> User -> UTCTime -> IO [OpenStorePurchase]
+getOpenStorePurchases db User {userId} now =
+  mapMaybe toOpenStorePurchase
     <$> DB.query
       db
       [sql|
-        SELECT invoice_id, transaction_ref, credit_error
+        SELECT payment, invoice_id, transaction_ref, credit_error
         FROM badge_store_receipts
         WHERE user_id = ? AND (transaction_ref IS NULL OR payment IS NOT NULL)
         ORDER BY badge_store_receipt_id
       |]
       (Only userId)
   where
-    toOpenStorePurchase (invoiceId, transactionRef, creditError) = OpenStorePurchase {invoiceId, transactionRef, creditError}
+    toOpenStorePurchase (payment_, invoiceId, transactionRef, creditError)
+      | maybe False (appleChargeLapsed now) payment_ = Nothing
+      | otherwise = Just OpenStorePurchase {invoiceId, transactionRef, creditError}
 
-getNextHeldStoreReceipt :: DB.Connection -> UserId -> IO (Either StoreError (Maybe BadgeReceiptRecord))
-getNextHeldStoreReceipt db userId =
-  fmap Right . maybeFirstRow toHeld $
+-- | Each held receipt's payment and its last attempt's failure, if any; a lapsed one is not pending.
+getPendingStoreReceipts :: DB.Connection -> User -> UTCTime -> IO [(Text, Maybe BadgeIssueFailure)]
+getPendingStoreReceipts db User {userId} now =
+  filter (not . appleChargeLapsed now . fst)
+    <$> DB.query db "SELECT payment, credit_error FROM badge_store_receipts WHERE user_id = ? AND payment IS NOT NULL" (Only userId)
+
+-- | A profile showing a badge waits with its held records, but for a change of the tier of the badge it shows.
+-- A lapsed one is not attempted; a later charge handed over re-arms it.
+getNextHeldStoreReceipt :: DB.Connection -> UserId -> UTCTime -> IO (Either StoreError (Maybe BadgeReceiptRecord))
+getNextHeldStoreReceipt db userId now =
+  fmap (Right . fmap toHeld . find (not . lapsed)) $
     DB.query
       db
       [sql|
-        SELECT r.badge_store_receipt_id, r.purchase_key, r.purchase_priv_key, r.master_key, r.invoice_id, r.payment, r.next_attempt_at, r.retry_delay
+        SELECT r.badge_store_receipt_id, r.purchase_key, r.purchase_priv_key, r.master_key, r.invoice_id, r.payment, r.next_attempt_at, r.retry_delay, r.hold_kind
         FROM badge_store_receipts r
         JOIN users u ON u.user_id = r.user_id
-        WHERE r.user_id = ? AND r.payment IS NOT NULL AND u.shown_badge_id IS NULL
+        LEFT JOIN badge_purchases p ON p.badge_store_receipt_id = r.badge_store_receipt_id
+        WHERE r.user_id = ? AND r.payment IS NOT NULL
+          AND (u.shown_badge_id IS NULL OR (r.hold_kind = ? AND u.shown_badge_id = p.badge_purchase_id))
         ORDER BY r.next_attempt_at, r.retry_count, r.badge_store_receipt_id
-        LIMIT 1
       |]
-      (Only userId)
+      (userId, SHKTierChange)
   where
-    toHeld (stashRow@(receiptId, _, _, _) :. (invoiceId, payment, nextAttemptAt, retryDelay)) =
-      BadgeReceiptRecord {receiptId, ownerId = userId, status = RSHeld {stash = toBadgeStash BSRStoreReceipt stashRow, invoiceId, payment, nextAttemptAt, retryDelay}}
+    toHeld (stashRow@(receiptId, _, _, _) :. (invoiceId, payment, nextAttemptAt, retryDelay, holdKind)) =
+      BadgeReceiptRecord {receiptId, ownerId = userId, status = RSHeld {stash = toBadgeStash BSRStoreReceipt stashRow, invoiceId, payment, nextAttemptAt, retryDelay, holdKind}}
+    lapsed (_ :. (_, payment, _, _, _)) = appleChargeLapsed now payment
 
-recordStoreReceiptFailure :: DB.Connection -> Int64 -> Int64 -> UTCTime -> BadgeIssueFailure -> IO ()
-recordStoreReceiptFailure db receiptId retryDelay nextAttemptAt failure =
+-- | A held Apple subscription charge whose paid period ended more than a day ago, as one refunded before it was credited:
+-- it neither blocks a new badge nor shows as open nor is attempted, and its record stays, as a later charge under its original id continues it.
+appleChargeLapsed :: UTCTime -> Text -> Bool
+appleChargeLapsed now payment = case decodeJSON payment of
+  Just SPApple {jws}
+    | Just AppleTransactionFacts {expiresDate = Just expires, autoRenewable = True} <- appleTransactionFacts jws ->
+        nominalDay `addUTCTime` posixSecondsToUTCTime (fromIntegral expires / 1000) <= now
+  _ -> False
+
+storeReceiptHeldFor :: DB.Connection -> Int64 -> UserId -> StoreHoldKind -> IO Bool
+storeReceiptHeldFor db receiptId userId holdKind =
+  maybeFirstRow' False ((== (1 :: Int)) . fromOnly) $
+    DB.query db "SELECT 1 FROM badge_store_receipts WHERE badge_store_receipt_id = ? AND user_id = ? AND hold_kind = ? AND payment IS NOT NULL" (receiptId, userId, holdKind)
+
+-- | The attempts that failed since the record was last held: each hold resets the count.
+getStoreReceiptFailures :: DB.Connection -> Int64 -> IO Int64
+getStoreReceiptFailures db receiptId =
+  maybeFirstRow' 0 fromOnly $ DB.query db "SELECT retry_count FROM badge_store_receipts WHERE badge_store_receipt_id = ?" (Only receiptId)
+
+-- | Only while the record still holds the payment that failed: one adopted meanwhile is due at once.
+recordStoreReceiptFailure :: DB.Connection -> Int64 -> Text -> Int64 -> UTCTime -> BadgeIssueFailure -> IO ()
+recordStoreReceiptFailure db receiptId payment retryDelay nextAttemptAt failure =
   DB.execute
     db
     [sql|
       UPDATE badge_store_receipts
       SET retry_delay = ?, next_attempt_at = ?, retry_count = retry_count + 1, credit_error = ?
-      WHERE badge_store_receipt_id = ? AND payment IS NOT NULL
+      WHERE badge_store_receipt_id = ? AND payment = ?
     |]
-    (retryDelay, nextAttemptAt, failure, receiptId)
+    (retryDelay, nextAttemptAt, failure, receiptId, payment)
 
 -- | Kept rather than deleted, so that a later hand-over of the same transaction is answered from the record.
-refuseStoreReceipt :: DB.Connection -> Int64 -> BadgeIssueFailure -> IO ()
-refuseStoreReceipt db receiptId refusal =
+-- A refused move returns the record to the profile whose purchase it still funds.
+-- Only while the record still holds the payment refused, which is when it answers True: one adopted meanwhile is due at once.
+refuseStoreReceipt :: DB.Connection -> Int64 -> Text -> BadgeIssueFailure -> IO Bool
+refuseStoreReceipt db receiptId payment refusal =
+  maybeFirstRow' False ((== (1 :: Int)) . fromOnly) $
+    DB.query
+      db
+      [sql|
+        UPDATE badge_store_receipts
+        SET payment = NULL, next_attempt_at = NULL, retry_delay = NULL, retry_count = 0, credit_error = ?, hold_kind = ?,
+          user_id = COALESCE((SELECT p.user_id FROM badge_purchases p WHERE p.badge_store_receipt_id = ?), user_id)
+        WHERE badge_store_receipt_id = ? AND payment = ?
+        RETURNING 1
+      |]
+      (refusal, SHKPurchase, receiptId, receiptId, payment)
+
+-- | Only while the record is resolved: one held meanwhile keeps its hold.
+clearStoreReceiptRefusal :: DB.Connection -> Int64 -> IO ()
+clearStoreReceiptRefusal db receiptId =
+  DB.execute db "UPDATE badge_store_receipts SET credit_error = NULL WHERE badge_store_receipt_id = ? AND payment IS NULL" (Only receiptId)
+
+-- | Every settle clears the failure, so one recorded on a credited record is a refused resume or tier change.
+-- It returns the record to the profile whose purchase it funds, which a Restore may have taken it from meanwhile.
+settleStoreReceipt :: DB.Connection -> Int64 -> IO ()
+settleStoreReceipt db receiptId =
   DB.execute
     db
-    "UPDATE badge_store_receipts SET payment = NULL, next_attempt_at = NULL, retry_delay = NULL, retry_count = 0, credit_error = ? WHERE badge_store_receipt_id = ?"
-    (refusal, receiptId)
+    [sql|
+      UPDATE badge_store_receipts
+      SET payment = NULL, next_attempt_at = NULL, retry_delay = NULL, retry_count = 0, credit_error = NULL, hold_kind = ?,
+        user_id = COALESCE((SELECT p.user_id FROM badge_purchases p WHERE p.badge_store_receipt_id = ?), user_id)
+      WHERE badge_store_receipt_id = ?
+    |]
+    (SHKPurchase, receiptId, receiptId)
+
+-- | Whether a later charge of a credited record's subscription is answered as held: its purchase must be its owner's newest
+-- and a subscription. A tier change, of a shown purchase, is held whatever else is held, as the worker serves it while the
+-- badge is shown. A resume, of a purchase not shown, is held only while no other receipt of the owner is held, which the
+-- worker would credit first; until then the app keeps the charge unfinished and hands it over again. No other kind is held.
+reholdStoreReceipt :: DB.Connection -> User -> Int64 -> Int64 -> StoreHoldKind -> ServicePayment -> UTCTime -> IO Bool
+reholdStoreReceipt db owner receiptId badgePurchaseId holdKind payment now = do
+  newest_ <- getUserBadgePurchase db owner
+  case newest_ of
+    Just UserBadgePurchase {badgePurchaseId = newestId, shown, purchaseKind = PKSubscription _}
+      | newestId == badgePurchaseId -> case holdKind of
+          SHKTierChange | shown -> True <$ hold
+          SHKPurchase | not shown -> do
+            pending <- getPendingStoreReceipts db owner now
+            True <$ when (null pending) hold
+          _ -> pure False
+    _ -> pure False
+  where
+    hold =
+      DB.execute
+        db
+        "UPDATE badge_store_receipts SET payment = ?, next_attempt_at = ?, retry_delay = NULL, retry_count = 0, credit_error = NULL, hold_kind = ? WHERE badge_store_receipt_id = ? AND payment IS NULL"
+        (safeDecodeUtf8 . LB.toStrict $ J.encode payment, now, holdKind, receiptId)
+
+-- | A resume's or a tier change's credit: shows the purchase, again if a retire cleared it meanwhile, and keeps only the
+-- state the answer stored, since the charge disproves an ended or a billing retry stored before.
+showChargedPurchase :: DB.Connection -> User -> Int64 -> Int64 -> Maybe SubscriptionState -> IO ()
+showChargedPurchase db User {userId} receiptId badgePurchaseId state = do
+  settleStoreReceipt db receiptId
+  DB.execute db "UPDATE badge_purchases SET subscription_status = ? WHERE badge_purchase_id = ?" (state, badgePurchaseId)
+  DB.execute db "UPDATE users SET shown_badge_id = ? WHERE user_id = ?" (badgePurchaseId, userId)
 
 -- | A held record is paid for and a credited one is referenced by its purchase, so neither is deleted.
 deleteUnfundedStoreReceipts :: DB.Connection -> UTCTime -> IO ()
@@ -285,9 +530,13 @@ deleteBadgeCodeRedemption db User {userId} code =
 -- issued, and that must add no purchase and leave the shown badge alone.
 createStashBadgePurchase :: DB.Connection -> User -> BadgeStash -> BadgeCredential -> UTCTime -> IO (Int64, Bool)
 createStashBadgePurchase db User {userId} stash credential now = do
-  -- the credit settles a held receipt in the transaction that stores its purchase, a replay included
-  forM_ storeReceiptId_ $ \storeReceiptId -> DB.execute db "UPDATE badge_store_receipts SET payment = NULL, next_attempt_at = NULL, retry_delay = NULL, retry_count = 0 WHERE badge_store_receipt_id = ?" (Only storeReceiptId)
-  getStashBadgePurchase db stash >>= \case
+  -- a moved payment's record still links the purchase it moved from, which would be taken for a replay
+  forM_ storeReceiptId_ $ \receiptId ->
+    DB.execute
+      db
+      "UPDATE badge_purchases SET badge_store_receipt_id = NULL WHERE badge_store_receipt_id = ? AND EXISTS (SELECT 1 FROM badge_store_receipts WHERE badge_store_receipt_id = ? AND hold_kind = ?)"
+      (receiptId, receiptId, SHKTransfer)
+  purchase <- getStashBadgePurchase db stash >>= \case
     Just purchaseId -> pure (purchaseId, False)
     Nothing -> do
       DB.execute
@@ -302,6 +551,10 @@ createStashBadgePurchase db User {userId} stash credential now = do
       purchaseId <- insertedRowId db
       DB.execute db "UPDATE users SET shown_badge_id = ? WHERE user_id = ?" (purchaseId, userId)
       pure (purchaseId, True)
+  -- the credit settles a held receipt in the transaction that stores its purchase, a replay included,
+  -- once the purchase links it, so the record goes to the profile that purchase is of
+  forM_ storeReceiptId_ $ settleStoreReceipt db
+  pure purchase
   where
     BadgeStash {stashRef, purchaseKey, purchasePrivKey, masterKey = BadgeMasterKey mk} = stash
     BadgeCredential {badgeInfo = BadgeInfo {badgeType}} = credential
@@ -343,7 +596,7 @@ getLatestIssuedCredential db badgePurchaseId = do
       [sql|
         SELECT credential FROM badge_issuances
         WHERE badge_purchase_id = ?
-        ORDER BY period_end DESC
+        ORDER BY entry_id DESC
         LIMIT 1
       |]
       (Only badgePurchaseId)
@@ -390,9 +643,19 @@ data UserBadgePurchase = UserBadgePurchase
     alertAcked :: Maybe (BadgeAlertKind, Text),
     alertSnoozeUntil :: Maybe UTCTime,
     issueError :: Maybe BadgeIssueError,
-    nextWakeAt :: Maybe UTCTime
+    nextWakeAt :: Maybe UTCTime,
+    unrenewedRun :: Maybe UnrenewedRun,
+    purchaseKind :: PurchaseKind
   }
 
+data UnrenewedRun = UnrenewedRun {unrenewedSince :: UTCTime, lastUnrenewedAt :: UTCTime}
+  deriving (Eq)
+
+-- | A subscription's months come from store charges, so reaching paidThrough does not end it: the
+-- service says when it has. Derived from the replica, which holds a charge credit exactly for a subscription.
+data PurchaseKind = PKPrepaid | PKSubscription BadgeSubscription
+  deriving (Eq)
+
 -- | Newest, not the one shown_badge_id points at - retirement clears that, and the support ended
 -- alert is recomputed from this purchase after the badge stops being shown.
 getUserBadgePurchase :: DB.Connection -> User -> IO (Maybe UserBadgePurchase)
@@ -420,14 +683,20 @@ getBadgePurchase db purchaseId =
         SELECT p.badge_purchase_id, p.purchase_key, p.purchase_priv_key, p.master_key, p.current_badge_type,
                (CASE WHEN u.shown_badge_id = p.badge_purchase_id THEN 1 ELSE 0 END),
                p.alert_acked_kind, p.alert_acked_episode, p.alert_snooze_until,
-               p.issue_failed_since, p.issue_error_at, p.issue_error, p.next_wake_at
+               p.issue_failed_since, p.issue_error_at, p.issue_error, p.next_wake_at,
+               (SELECT l.change_months FROM badge_ledger l
+                WHERE l.badge_purchase_id = p.badge_purchase_id AND l.entry_type = 'credit' AND l.entry_credit_type = 'charge'
+                ORDER BY l.entry_id DESC
+                LIMIT 1),
+               p.subscription_status, p.unrenewed_since, p.last_unrenewed_at, r.transaction_ref
         FROM badge_purchases p
         JOIN users u ON u.user_id = p.user_id
+        LEFT JOIN badge_store_receipts r ON r.badge_store_receipt_id = p.badge_store_receipt_id
         WHERE p.badge_purchase_id = ? AND p.purchase_priv_key IS NOT NULL
       |]
       (Only purchaseId)
   where
-    toPurchase ((badgePurchaseId, purchaseKey, purchasePrivKey, Binary mk, badgeType, shown_, ackedKind_, ackedEpisode_, alertSnoozeUntil) :. (failedSince_, lastAttemptAt_, reason_, nextWakeAt)) =
+    toPurchase ((badgePurchaseId, purchaseKey, purchasePrivKey, Binary mk, badgeType, shown_, ackedKind_, ackedEpisode_, alertSnoozeUntil) :. (failedSince_, lastAttemptAt_, reason_, nextWakeAt, planMonths_, status, since_, lastAt_, transactionRef)) =
       UserBadgePurchase
         { badgePurchaseId,
           purchaseKey,
@@ -438,9 +707,15 @@ getBadgePurchase db purchaseId =
           alertAcked = (,) <$> ackedKind_ <*> ackedEpisode_,
           alertSnoozeUntil,
           issueError = BadgeIssueError <$> failedSince_ <*> lastAttemptAt_ <*> reason_,
-          nextWakeAt
+          nextWakeAt,
+          unrenewedRun = UnrenewedRun <$> since_ <*> lastAt_,
+          purchaseKind = maybe PKPrepaid (\planMonths -> PKSubscription BadgeSubscription {planMonths, status, transactionRef}) planMonths_
         }
 
+setBadgeSubscriptionStatus :: DB.Connection -> Int64 -> SubscriptionState -> IO ()
+setBadgeSubscriptionStatus db badgePurchaseId state =
+  DB.execute db "UPDATE badge_purchases SET subscription_status = ? WHERE badge_purchase_id = ?" (state, badgePurchaseId)
+
 -- | Whether a badge is on the profile now: set when a redemption stores one, cleared when it is
 -- retired. Read as the id rather than as a comparison, which in Postgres would be a boolean.
 userHasBadge :: DB.Connection -> User -> IO Bool
@@ -478,6 +753,13 @@ setBadgeNextWake :: DB.Connection -> Int64 -> Maybe UTCTime -> IO ()
 setBadgeNextWake db badgePurchaseId at_ =
   DB.execute db "UPDATE badge_purchases SET next_wake_at = ? WHERE badge_purchase_id = ?" (at_, badgePurchaseId)
 
+setBadgeUnrenewedRun :: DB.Connection -> Int64 -> Maybe UnrenewedRun -> IO ()
+setBadgeUnrenewedRun db badgePurchaseId run_ =
+  DB.execute
+    db
+    "UPDATE badge_purchases SET unrenewed_since = ?, last_unrenewed_at = ? WHERE badge_purchase_id = ?"
+    (unrenewedSince <$> run_, lastUnrenewedAt <$> run_, badgePurchaseId)
+
 -- | Stop showing a badge that has expired unrenewed; the profile update is broadcast by the caller.
 clearShownBadge :: DB.Connection -> User -> Int64 -> IO ()
 clearShownBadge db User {userId} badgePurchaseId =
@@ -516,6 +798,10 @@ storeBadgeStatement db badgePurchaseId badgeType tip entries now =
           SEDebit SDUnknown {} -> True
           _ -> False
 
+setBadgePurchaseType :: DB.Connection -> Int64 -> BadgeType -> UTCTime -> IO ()
+setBadgePurchaseType db badgePurchaseId badgeType now =
+  DB.execute db "UPDATE badge_purchases SET current_badge_type = ?, updated_at = ? WHERE badge_purchase_id = ?" (badgeType, now, badgePurchaseId)
+
 -- | The balance is the last row; nothing derives it by summing the history.
 getBadgeLedgerLastEntry :: DB.Connection -> Int64 -> IO (Maybe StatementEntry)
 getBadgeLedgerLastEntry db badgePurchaseId =
@@ -532,6 +818,20 @@ getBadgeLedgerLastEntry db badgePurchaseId =
       |]
       (Only badgePurchaseId)
 
+-- | When the service wrote the purchase's last charge credit, which it dates no earlier than the charge's period start.
+getLastChargeCreditAt :: DB.Connection -> Int64 -> IO (Maybe UTCTime)
+getLastChargeCreditAt db badgePurchaseId =
+  maybeFirstRow fromOnly $
+    DB.query
+      db
+      [sql|
+        SELECT service_created_at FROM badge_ledger
+        WHERE badge_purchase_id = ? AND entry_type = 'credit' AND entry_credit_type = 'charge'
+        ORDER BY entry_id DESC
+        LIMIT 1
+      |]
+      (Only badgePurchaseId)
+
 -- | Oldest first. A row whose type this version cannot rebuild is left out, as it is from the tip.
 getBadgeLedger :: DB.Connection -> User -> Int64 -> IO [StatementEntry]
 getBadgeLedger db User {userId} badgePurchaseId =
@@ -551,7 +851,7 @@ getBadgeLedger db User {userId} badgePurchaseId =
 toStatementEntry :: (Text, Int, Int, UTCTime, UTCTime, BadgeType) :. (Maybe UTCTime, UTCTime, Text, Maybe Text, Maybe Text, Maybe Text) -> Maybe StatementEntry
 toStatementEntry ((entryId, changeMonths, balanceMonths, balanceStartTs, balanceAnchorTs, balanceBadgeType) :. (wasPausedSince, createdAt, entryType_, credit_, debit_, value_)) =
   (\entryType -> StatementEntry {entryId, changeMonths, balanceMonths, balanceStartTs, balanceAnchorTs, balanceBadgeType, wasPausedSince, createdAt, entryType})
-    <$> maybe (entryTypeFromColumns Nothing entryType_ credit_ debit_) (entryTypeFromValue entryType_) value_
+    <$> maybe (entryTypeFromColumns noEntryReferences entryType_ credit_ debit_) (entryTypeFromValue entryType_) value_
 
 -- | Decodes the stored JSON rather than rebuilding from the tag, so a version that has since
 -- learnt the type reads it with its fields, and one that has not still gets it back verbatim.

src/Simplex/Chat/Store/Postgres/Migrations.hs

@@ -58,6 +58,7 @@ import Simplex.Chat.Store.Postgres.Migrations.M20261010_invite_member_via_group
 import Simplex.Chat.Store.Postgres.Migrations.M20261012_delivery_job_notification
 import Simplex.Chat.Store.Postgres.Migrations.M20261016_badge_store_receipts
 import Simplex.Chat.Store.Postgres.Migrations.M20261019_chat_layout
+import Simplex.Chat.Store.Postgres.Migrations.M20261021_badge_subscriptions
 import Simplex.Chat.Store.Postgres.Migrations.M20261030_wallet_seeds
 import Simplex.Messaging.Agent.Store.Shared (Migration (..))
 
@@ -117,6 +118,7 @@ schemaMigrations =
     ("20261012_delivery_job_notification", m20261012_delivery_job_notification, Just down_m20261012_delivery_job_notification),
     ("20261016_badge_store_receipts", m20261016_badge_store_receipts, Just down_m20261016_badge_store_receipts),
     ("20261019_chat_layout", m20261019_chat_layout, Just down_m20261019_chat_layout),
+    ("20261021_badge_subscriptions", m20261021_badge_subscriptions, Just down_m20261021_badge_subscriptions),
     ("20261030_wallet_seeds", m20261030_wallet_seeds, Just down_m20261030_wallet_seeds)
   ]
 

src/Simplex/Chat/Store/Postgres/Migrations/M20260915_user_badges.hs

@@ -152,19 +152,7 @@ DROP TABLE @badge_prices;
 |]
 
 {- TODO [badges] deferred draft schema for paid purchases, subscriptions, upgrades and transfers.
-The service added @badge_purchases.payment_id and @badge_ledger.payment_id in its 20260925_badge_store_receipts, so they left this draft; the client's stay deferred with the rest, as nothing writes its @payments yet.
-
-CREATE TABLE @subscription_charges(
-  charge_id TEXT NOT NULL PRIMARY KEY,
-  payment_id TEXT NOT NULL REFERENCES @payments ON DELETE CASCADE,
-  provider_charge_ref TEXT NOT NULL,
-  period_start TIMESTAMPTZ NOT NULL,
-  period_end TIMESTAMPTZ NOT NULL,
-  amount BIGINT NOT NULL,
-  currency TEXT NOT NULL,
-  charged_at TIMESTAMPTZ NOT NULL,
-  UNIQUE(payment_id, provider_charge_ref)
-);
+The service added @badge_purchases.payment_id and @badge_ledger.payment_id in its 20260925_badge_store_receipts, and @subscription_charges, @badge_ledger.charge_id, @badge_ledger.from_purchase_id and to_purchase_id in its 20261012_badge_subscriptions, so they left this draft; the client's stay deferred with the rest, as nothing writes its @payments yet.
 
 CREATE TABLE @badge_invoices(
   invoice_id TEXT NOT NULL PRIMARY KEY REFERENCES @invoices ON DELETE CASCADE,
@@ -197,32 +185,13 @@ CREATE TABLE @badge_subscription_changes(
 
 CREATE INDEX @idx_badge_subscription_changes_purchase ON @badge_subscription_changes(badge_purchase_id);
 
-ALTER TABLE @badge_ledger ADD COLUMN charge_id TEXT REFERENCES @subscription_charges;
-
-ALTER TABLE @badge_ledger ADD COLUMN from_purchase_id BIGINT REFERENCES @badge_purchases;
-
-ALTER TABLE @badge_ledger ADD COLUMN to_purchase_id BIGINT REFERENCES @badge_purchases;
-
-CREATE INDEX @idx_badge_ledger_charge ON @badge_ledger(charge_id);
-
-CREATE INDEX @idx_badge_ledger_from_purchase ON @badge_ledger(from_purchase_id);
-
-CREATE INDEX @idx_badge_ledger_to_purchase ON @badge_ledger(to_purchase_id);
-
 -- down
-DROP INDEX @idx_badge_ledger_charge;
-DROP INDEX @idx_badge_ledger_from_purchase;
-DROP INDEX @idx_badge_ledger_to_purchase;
-ALTER TABLE @badge_ledger DROP COLUMN charge_id;
-ALTER TABLE @badge_ledger DROP COLUMN from_purchase_id;
-ALTER TABLE @badge_ledger DROP COLUMN to_purchase_id;
 DROP INDEX @idx_badge_subscription_changes_purchase;
 DROP TABLE @badge_subscription_changes;
 DROP INDEX @idx_badge_invoices_purchase;
 DROP INDEX @idx_badge_invoices_offer;
 DROP INDEX @idx_badge_invoices_price;
 DROP TABLE @badge_invoices;
-DROP TABLE @subscription_charges;
 -}
 
 m20260915_user_badges :: Text

src/Simplex/Chat/Store/Postgres/Migrations/M20261021_badge_subscriptions.hs

@@ -0,0 +1,33 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+
+module Simplex.Chat.Store.Postgres.Migrations.M20261021_badge_subscriptions where
+
+import Data.Text (Text)
+import Text.RawString.QQ (r)
+
+m20261021_badge_subscriptions :: Text
+m20261021_badge_subscriptions =
+  [r|
+ALTER TABLE badge_purchases ADD COLUMN subscription_status TEXT;
+
+ALTER TABLE badge_purchases ADD COLUMN unrenewed_since TIMESTAMPTZ;
+
+ALTER TABLE badge_purchases ADD COLUMN last_unrenewed_at TIMESTAMPTZ;
+
+ALTER TABLE badge_store_receipts ADD COLUMN hold_kind TEXT NOT NULL DEFAULT 'purchase';
+|]
+
+down_m20261021_badge_subscriptions :: Text
+down_m20261021_badge_subscriptions =
+  [r|
+ALTER TABLE badge_store_receipts DROP COLUMN hold_kind;
+
+UPDATE badge_purchases SET alert_acked_kind = NULL, alert_acked_episode = NULL, alert_snooze_until = NULL WHERE alert_acked_kind = 'subscription_cancelled';
+
+ALTER TABLE badge_purchases DROP COLUMN last_unrenewed_at;
+
+ALTER TABLE badge_purchases DROP COLUMN unrenewed_since;
+
+ALTER TABLE badge_purchases DROP COLUMN subscription_status;
+|]

src/Simplex/Chat/Store/Postgres/Migrations/chat_schema.sql

@@ -280,7 +280,10 @@ CREATE TABLE test_chat_schema.badge_purchases (
     issue_error_at timestamp with time zone,
     issue_error text,
     next_wake_at timestamp with time zone,
-    badge_store_receipt_id bigint
+    badge_store_receipt_id bigint,
+    subscription_status text,
+    unrenewed_since timestamp with time zone,
+    last_unrenewed_at timestamp with time zone
 );
 
 
@@ -310,7 +313,8 @@ CREATE TABLE test_chat_schema.badge_store_receipts (
     next_attempt_at timestamp with time zone,
     retry_delay bigint,
     retry_count bigint DEFAULT 0 NOT NULL,
-    credit_error text
+    credit_error text,
+    hold_kind text DEFAULT 'purchase'::text NOT NULL
 );
 
 

src/Simplex/Chat/Store/Profiles.hs

@@ -287,7 +287,18 @@ getUserFileInfo db User {userId} =
     <$> DB.query db (fileInfoQuery <> " WHERE i.user_id = ?") (Only userId)
 
 deleteUserRecord :: DB.Connection -> User -> IO ()
-deleteUserRecord db User {userId} =
+deleteUserRecord db User {userId} = do
+  -- a move held for this profile returns the record to the profile whose purchase still links it, without the move's failures
+  DB.execute
+    db
+    [sql|
+      UPDATE badge_store_receipts
+      SET user_id = (SELECT p.user_id FROM badge_purchases p WHERE p.badge_store_receipt_id = badge_store_receipts.badge_store_receipt_id),
+        payment = NULL, next_attempt_at = NULL, retry_delay = NULL, retry_count = 0, credit_error = NULL, hold_kind = 'purchase'
+      WHERE user_id = ?
+        AND EXISTS (SELECT 1 FROM badge_purchases p WHERE p.badge_store_receipt_id = badge_store_receipts.badge_store_receipt_id AND p.user_id != ?)
+    |]
+    (userId, userId)
   DB.execute db "DELETE FROM users WHERE user_id = ?" (Only userId)
 
 updateUserPrivacy :: DB.Connection -> User -> IO ()

src/Simplex/Chat/Store/SQLite/Migrations.hs

@@ -182,6 +182,7 @@ import Simplex.Chat.Store.SQLite.Migrations.M20261012_delivery_job_notification
 import Simplex.Chat.Store.SQLite.Migrations.M20261016_badge_store_receipts
 import Simplex.Chat.Store.SQLite.Migrations.M20261018_autoincrement_ids
 import Simplex.Chat.Store.SQLite.Migrations.M20261019_chat_layout
+import Simplex.Chat.Store.SQLite.Migrations.M20261021_badge_subscriptions
 import Simplex.Chat.Store.SQLite.Migrations.M20261030_wallet_seeds
 import Simplex.Messaging.Agent.Store.Shared (Migration (..))
 
@@ -365,6 +366,7 @@ schemaMigrations =
     ("20261016_badge_store_receipts", m20261016_badge_store_receipts, Just down_m20261016_badge_store_receipts),
     ("20261018_autoincrement_ids", m20261018_autoincrement_ids, Just down_m20261018_autoincrement_ids),
     ("20261019_chat_layout", m20261019_chat_layout, Just down_m20261019_chat_layout),
+    ("20261021_badge_subscriptions", m20261021_badge_subscriptions, Just down_m20261021_badge_subscriptions),
     ("20261030_wallet_seeds", m20261030_wallet_seeds, Just down_m20261030_wallet_seeds)
   ]
 

src/Simplex/Chat/Store/SQLite/Migrations/M20260915_user_badges.hs

@@ -153,19 +153,7 @@ DROP TABLE @badge_prices;
 |]
 
 {- TODO [badges] deferred draft schema for paid purchases, subscriptions, upgrades and transfers.
-The service added @badge_purchases.payment_id and @badge_ledger.payment_id in its 20260925_badge_store_receipts, so they left this draft; the client's stay deferred with the rest, as nothing writes its @payments yet.
-
-CREATE TABLE @subscription_charges(
-  charge_id TEXT NOT NULL PRIMARY KEY,
-  payment_id TEXT NOT NULL REFERENCES @payments ON DELETE CASCADE,
-  provider_charge_ref TEXT NOT NULL,
-  period_start TEXT NOT NULL,
-  period_end TEXT NOT NULL,
-  amount INTEGER NOT NULL,
-  currency TEXT NOT NULL,
-  charged_at TEXT NOT NULL,
-  UNIQUE(payment_id, provider_charge_ref)
-) STRICT;
+The service added @badge_purchases.payment_id and @badge_ledger.payment_id in its 20260925_badge_store_receipts, and @subscription_charges, @badge_ledger.charge_id, @badge_ledger.from_purchase_id and to_purchase_id in its 20261012_badge_subscriptions, so they left this draft; the client's stay deferred with the rest, as nothing writes its @payments yet.
 
 CREATE TABLE @badge_invoices(
   invoice_id TEXT NOT NULL PRIMARY KEY REFERENCES @invoices ON DELETE CASCADE,
@@ -198,32 +186,13 @@ CREATE TABLE @badge_subscription_changes(
 
 CREATE INDEX @idx_badge_subscription_changes_purchase ON @badge_subscription_changes(badge_purchase_id);
 
-ALTER TABLE @badge_ledger ADD COLUMN charge_id TEXT REFERENCES @subscription_charges;
-
-ALTER TABLE @badge_ledger ADD COLUMN from_purchase_id INTEGER REFERENCES @badge_purchases;
-
-ALTER TABLE @badge_ledger ADD COLUMN to_purchase_id INTEGER REFERENCES @badge_purchases;
-
-CREATE INDEX @idx_badge_ledger_charge ON @badge_ledger(charge_id);
-
-CREATE INDEX @idx_badge_ledger_from_purchase ON @badge_ledger(from_purchase_id);
-
-CREATE INDEX @idx_badge_ledger_to_purchase ON @badge_ledger(to_purchase_id);
-
 -- down
-DROP INDEX @idx_badge_ledger_charge;
-DROP INDEX @idx_badge_ledger_from_purchase;
-DROP INDEX @idx_badge_ledger_to_purchase;
-ALTER TABLE @badge_ledger DROP COLUMN charge_id;
-ALTER TABLE @badge_ledger DROP COLUMN from_purchase_id;
-ALTER TABLE @badge_ledger DROP COLUMN to_purchase_id;
 DROP INDEX @idx_badge_subscription_changes_purchase;
 DROP TABLE @badge_subscription_changes;
 DROP INDEX @idx_badge_invoices_purchase;
 DROP INDEX @idx_badge_invoices_offer;
 DROP INDEX @idx_badge_invoices_price;
 DROP TABLE @badge_invoices;
-DROP TABLE @subscription_charges;
 -}
 
 m20260915_user_badges :: Query

src/Simplex/Chat/Store/SQLite/Migrations/M20261021_badge_subscriptions.hs

@@ -0,0 +1,32 @@
+{-# LANGUAGE QuasiQuotes #-}
+
+module Simplex.Chat.Store.SQLite.Migrations.M20261021_badge_subscriptions where
+
+import Database.SQLite.Simple (Query)
+import Database.SQLite.Simple.QQ (sql)
+
+m20261021_badge_subscriptions :: Query
+m20261021_badge_subscriptions =
+  [sql|
+ALTER TABLE badge_purchases ADD COLUMN subscription_status TEXT;
+
+ALTER TABLE badge_purchases ADD COLUMN unrenewed_since TEXT;
+
+ALTER TABLE badge_purchases ADD COLUMN last_unrenewed_at TEXT;
+
+ALTER TABLE badge_store_receipts ADD COLUMN hold_kind TEXT NOT NULL DEFAULT 'purchase';
+|]
+
+down_m20261021_badge_subscriptions :: Query
+down_m20261021_badge_subscriptions =
+  [sql|
+ALTER TABLE badge_store_receipts DROP COLUMN hold_kind;
+
+UPDATE badge_purchases SET alert_acked_kind = NULL, alert_acked_episode = NULL, alert_snooze_until = NULL WHERE alert_acked_kind = 'subscription_cancelled';
+
+ALTER TABLE badge_purchases DROP COLUMN last_unrenewed_at;
+
+ALTER TABLE badge_purchases DROP COLUMN unrenewed_since;
+
+ALTER TABLE badge_purchases DROP COLUMN subscription_status;
+|]

src/Simplex/Chat/Store/SQLite/Migrations/chat_query_plans.txt

@@ -78,6 +78,18 @@ Query:
 Plan:
 SEARCH groups USING INTEGER PRIMARY KEY (rowid=?)
 
+Query: 
+                DELETE FROM badge_store_receipts
+                WHERE invoice_id = ? AND transaction_ref IS NULL AND payment IS NULL
+                  AND NOT EXISTS (SELECT 1 FROM badge_purchases p WHERE p.badge_store_receipt_id = badge_store_receipts.badge_store_receipt_id)
+                RETURNING 1
+              
+Plan:
+SEARCH badge_store_receipts USING INDEX sqlite_autoindex_badge_store_receipts_1 (invoice_id=?)
+CORRELATED SCALAR SUBQUERY 1
+SEARCH p USING COVERING INDEX idx_badge_purchases_store_receipt (badge_store_receipt_id=?)
+SEARCH badge_purchases USING COVERING INDEX idx_badge_purchases_store_receipt (badge_store_receipt_id=?)
+
 Query: 
                 INSERT INTO group_members
                   ( group_id, index_in_group, member_id, member_role, member_category, member_status, member_relations_vector, invited_by, invited_by_group_member_id,
@@ -1270,8 +1282,8 @@ Plan:
 
 Query: 
           INSERT INTO badge_store_receipts
-            (user_id, invoice_id, provider, transaction_ref, payment, next_attempt_at, purchase_key, purchase_priv_key, master_key, created_at)
-          VALUES (?,?,?,?,?,?,?,?,?,?)
+            (user_id, invoice_id, provider, transaction_ref, payment, next_attempt_at, purchase_key, purchase_priv_key, master_key, hold_kind, created_at)
+          VALUES (?,?,?,?,?,?,?,?,?,?,?)
           ON CONFLICT DO NOTHING
         
 Plan:
@@ -3853,12 +3865,11 @@ SEARCH cp USING INTEGER PRIMARY KEY (rowid=?)
 Query: 
         SELECT credential FROM badge_issuances
         WHERE badge_purchase_id = ?
-        ORDER BY period_end DESC
+        ORDER BY entry_id DESC
         LIMIT 1
       
 Plan:
 SEARCH badge_issuances USING INDEX idx_badge_issuances_purchase_entry (badge_purchase_id=?)
-USE TEMP B-TREE FOR ORDER BY
 
 Query: 
         SELECT ct.contact_id
@@ -4119,15 +4130,6 @@ Query:
 Plan:
 SCAN group_members
 
-Query: 
-        SELECT invoice_id, transaction_ref, credit_error
-        FROM badge_store_receipts
-        WHERE user_id = ? AND (transaction_ref IS NULL OR payment IS NOT NULL)
-        ORDER BY badge_store_receipt_id
-      
-Plan:
-SEARCH badge_store_receipts USING INDEX idx_badge_store_receipts_user (user_id=?)
-
 Query: 
         SELECT l.entry_uuid, l.change_months, l.balance_months, l.balance_start_ts, l.balance_anchor_ts, l.balance_badge_type,
                l.was_paused_since, l.service_created_at, l.entry_type, l.entry_credit_type, l.entry_debit_type, l.entry_type_value
@@ -4157,14 +4159,32 @@ Query:
         SELECT p.badge_purchase_id, p.purchase_key, p.purchase_priv_key, p.master_key, p.current_badge_type,
                (CASE WHEN u.shown_badge_id = p.badge_purchase_id THEN 1 ELSE 0 END),
                p.alert_acked_kind, p.alert_acked_episode, p.alert_snooze_until,
-               p.issue_failed_since, p.issue_error_at, p.issue_error, p.next_wake_at
+               p.issue_failed_since, p.issue_error_at, p.issue_error, p.next_wake_at,
+               (SELECT l.change_months FROM badge_ledger l
+                WHERE l.badge_purchase_id = p.badge_purchase_id AND l.entry_type = 'credit' AND l.entry_credit_type = 'charge'
+                ORDER BY l.entry_id DESC
+                LIMIT 1),
+               p.subscription_status, p.unrenewed_since, p.last_unrenewed_at, r.transaction_ref
         FROM badge_purchases p
         JOIN users u ON u.user_id = p.user_id
+        LEFT JOIN badge_store_receipts r ON r.badge_store_receipt_id = p.badge_store_receipt_id
         WHERE p.badge_purchase_id = ? AND p.purchase_priv_key IS NOT NULL
       
 Plan:
 SEARCH p USING INTEGER PRIMARY KEY (rowid=?)
 SEARCH u USING INTEGER PRIMARY KEY (rowid=?)
+SEARCH r USING INTEGER PRIMARY KEY (rowid=?) LEFT-JOIN
+CORRELATED SCALAR SUBQUERY 1
+SEARCH l USING INDEX idx_badge_ledger_purchase (badge_purchase_id=?)
+
+Query: 
+        SELECT payment, invoice_id, transaction_ref, credit_error
+        FROM badge_store_receipts
+        WHERE user_id = ? AND (transaction_ref IS NULL OR payment IS NOT NULL)
+        ORDER BY badge_store_receipt_id
+      
+Plan:
+SEARCH badge_store_receipts USING INDEX idx_badge_store_receipts_user (user_id=?)
 
 Query: 
         SELECT pgm.message_id, m.shared_msg_id, m.msg_body, m.msg_chat_binding, m.msg_signatures
@@ -4187,21 +4207,23 @@ Plan:
 SEARCH file_badge_proofs USING INDEX idx_file_badge_proofs_file_id_kind (file_id=?)
 
 Query: 
-        SELECT r.badge_store_receipt_id, r.purchase_key, r.purchase_priv_key, r.master_key, r.invoice_id, r.payment, r.next_attempt_at, r.retry_delay
+        SELECT r.badge_store_receipt_id, r.purchase_key, r.purchase_priv_key, r.master_key, r.invoice_id, r.payment, r.next_attempt_at, r.retry_delay, r.hold_kind
         FROM badge_store_receipts r
         JOIN users u ON u.user_id = r.user_id
-        WHERE r.user_id = ? AND r.payment IS NOT NULL AND u.shown_badge_id IS NULL
+        LEFT JOIN badge_purchases p ON p.badge_store_receipt_id = r.badge_store_receipt_id
+        WHERE r.user_id = ? AND r.payment IS NOT NULL
+          AND (u.shown_badge_id IS NULL OR (r.hold_kind = ? AND u.shown_badge_id = p.badge_purchase_id))
         ORDER BY r.next_attempt_at, r.retry_count, r.badge_store_receipt_id
-        LIMIT 1
       
 Plan:
 SEARCH u USING INTEGER PRIMARY KEY (rowid=?)
 SEARCH r USING INDEX idx_badge_store_receipts_user (user_id=?)
+SEARCH p USING COVERING INDEX idx_badge_purchases_store_receipt (badge_store_receipt_id=?) LEFT-JOIN
 USE TEMP B-TREE FOR ORDER BY
 
 Query: 
         SELECT r.badge_store_receipt_id, r.user_id, r.purchase_key, r.purchase_priv_key, r.master_key,
-          r.invoice_id, r.payment, r.next_attempt_at, r.retry_delay, p.badge_purchase_id, r.credit_error
+          r.invoice_id, r.payment, r.next_attempt_at, r.retry_delay, p.badge_purchase_id, r.credit_error, r.hold_kind
         FROM badge_store_receipts r
         LEFT JOIN badge_purchases p ON p.badge_store_receipt_id = r.badge_store_receipt_id
         WHERE r.provider = ? AND r.transaction_ref = ?
@@ -4315,6 +4337,15 @@ SEARCH c USING INTEGER PRIMARY KEY (rowid=?)
 SEARCH cs USING INTEGER PRIMARY KEY (rowid=?) LEFT-JOIN
 SEARCH m USING INTEGER PRIMARY KEY (rowid=?) LEFT-JOIN
 
+Query: 
+        SELECT service_created_at FROM badge_ledger
+        WHERE badge_purchase_id = ? AND entry_type = 'credit' AND entry_credit_type = 'charge'
+        ORDER BY entry_id DESC
+        LIMIT 1
+      
+Plan:
+SEARCH badge_ledger USING INDEX idx_badge_ledger_purchase (badge_purchase_id=?)
+
 Query: 
         SELECT smp_server_id, host, port, key_hash, basic_auth, preset, tested, enabled,
                role_storage, role_proxy, role_names
@@ -4356,6 +4387,18 @@ Query:
 Plan:
 SEARCH user_contact_links USING INTEGER PRIMARY KEY (rowid=?)
 
+Query: 
+        UPDATE badge_store_receipts
+        SET payment = NULL, next_attempt_at = NULL, retry_delay = NULL, retry_count = 0, credit_error = ?, hold_kind = ?,
+          user_id = COALESCE((SELECT p.user_id FROM badge_purchases p WHERE p.badge_store_receipt_id = ?), user_id)
+        WHERE badge_store_receipt_id = ? AND payment = ?
+        RETURNING 1
+      
+Plan:
+SEARCH badge_store_receipts USING INTEGER PRIMARY KEY (rowid=?)
+SCALAR SUBQUERY 1
+SEARCH p USING INDEX idx_badge_purchases_store_receipt (badge_store_receipt_id=?)
+
 Query: 
         UPDATE chat_items
         SET item_deleted = 1, item_deleted_ts = ?, item_deleted_by_group_member_id = ?, item_content = ?, item_text = ?, updated_at = ?
@@ -5324,11 +5367,36 @@ SEARCH badge_purchases USING INTEGER PRIMARY KEY (rowid=?)
 
 Query: 
       UPDATE badge_store_receipts
-      SET retry_delay = ?, next_attempt_at = ?, retry_count = retry_count + 1, credit_error = ?
-      WHERE badge_store_receipt_id = ? AND payment IS NOT NULL
+      SET payment = NULL, next_attempt_at = NULL, retry_delay = NULL, retry_count = 0, credit_error = NULL, hold_kind = ?,
+        user_id = COALESCE((SELECT p.user_id FROM badge_purchases p WHERE p.badge_store_receipt_id = ?), user_id)
+      WHERE badge_store_receipt_id = ?
     
 Plan:
 SEARCH badge_store_receipts USING INTEGER PRIMARY KEY (rowid=?)
+SCALAR SUBQUERY 1
+SEARCH p USING INDEX idx_badge_purchases_store_receipt (badge_store_receipt_id=?)
+
+Query: 
+      UPDATE badge_store_receipts
+      SET retry_delay = ?, next_attempt_at = ?, retry_count = retry_count + 1, credit_error = ?
+      WHERE badge_store_receipt_id = ? AND payment = ?
+    
+Plan:
+SEARCH badge_store_receipts USING INTEGER PRIMARY KEY (rowid=?)
+
+Query: 
+      UPDATE badge_store_receipts
+      SET user_id = (SELECT p.user_id FROM badge_purchases p WHERE p.badge_store_receipt_id = badge_store_receipts.badge_store_receipt_id),
+        payment = NULL, next_attempt_at = NULL, retry_delay = NULL, retry_count = 0, credit_error = NULL, hold_kind = 'purchase'
+      WHERE user_id = ?
+        AND EXISTS (SELECT 1 FROM badge_purchases p WHERE p.badge_store_receipt_id = badge_store_receipts.badge_store_receipt_id AND p.user_id != ?)
+    
+Plan:
+SEARCH badge_store_receipts USING COVERING INDEX idx_badge_store_receipts_user (user_id=?)
+CORRELATED SCALAR SUBQUERY 2
+SEARCH p USING INDEX idx_badge_purchases_store_receipt (badge_store_receipt_id=?)
+CORRELATED SCALAR SUBQUERY 1
+SEARCH p USING INDEX idx_badge_purchases_store_receipt (badge_store_receipt_id=?)
 
 Query: 
       UPDATE chat_items
@@ -7529,10 +7597,18 @@ Plan:
 Query: INSERT INTO xftp_file_descriptions (user_id, file_descr_text, file_descr_part_no, file_descr_complete, created_at, updated_at) VALUES (?,?,?,?,?,?)
 Plan:
 
+Query: SELECT 1 FROM badge_store_receipts WHERE badge_store_receipt_id = ? AND user_id = ? AND hold_kind = ? AND payment IS NOT NULL
+Plan:
+SEARCH badge_store_receipts USING INTEGER PRIMARY KEY (rowid=?)
+
 Query: SELECT 1 FROM settings WHERE user_id = ? LIMIT 1
 Plan:
 SEARCH settings USING COVERING INDEX idx_settings_user_id (user_id=?)
 
+Query: SELECT COUNT(*) FROM badge_code_redemptions
+Plan:
+SCAN badge_code_redemptions USING COVERING INDEX idx_badge_code_redemptions_user
+
 Query: SELECT COUNT(*) FROM badge_store_receipts
 Plan:
 SCAN badge_store_receipts USING COVERING INDEX idx_badge_store_receipts_user
@@ -7652,10 +7728,31 @@ Query: SELECT badge_purchase_id FROM badge_purchases WHERE badge_store_receipt_i
 Plan:
 SEARCH badge_purchases USING COVERING INDEX idx_badge_purchases_store_receipt (badge_store_receipt_id=?)
 
+Query: SELECT badge_purchase_id, entry_id, period_end FROM badge_issuances ORDER BY entry_id
+Plan:
+SCAN badge_issuances USING INDEX idx_badge_issuances_entry
+
+Query: SELECT badge_store_receipt_id FROM badge_store_receipts
+Plan:
+SCAN badge_store_receipts USING COVERING INDEX idx_badge_store_receipts_user
+
 Query: SELECT badge_store_receipt_id FROM badge_store_receipts WHERE invoice_id = ?
 Plan:
 SEARCH badge_store_receipts USING COVERING INDEX sqlite_autoindex_badge_store_receipts_1 (invoice_id=?)
 
+Query: SELECT badge_store_receipt_id, badge_purchase_id FROM badge_purchases
+Plan:
+SCAN badge_purchases USING COVERING INDEX idx_badge_purchases_store_receipt
+
+Query: SELECT badge_type FROM badge_issuances ORDER BY period_end
+Plan:
+SCAN badge_issuances
+USE TEMP B-TREE FOR ORDER BY
+
+Query: SELECT badge_type FROM contact_profiles WHERE badge_proof IS NOT NULL ORDER BY contact_profile_id
+Plan:
+SCAN contact_profiles
+
 Query: SELECT balance_checked FROM badge_ledger ORDER BY entry_id
 Plan:
 SCAN badge_ledger
@@ -7753,6 +7850,10 @@ Query: SELECT contact_id FROM contacts WHERE user_id = ? AND (chat_item_ttl > 0
 Plan:
 SEARCH contacts USING INDEX idx_contacts_chat_ts (user_id=?)
 
+Query: SELECT contact_id FROM contacts WHERE user_id = ? AND (chat_item_ttl > 0)
+Plan:
+SEARCH contacts USING INDEX idx_contacts_chat_ts (user_id=?)
+
 Query: SELECT contact_id FROM contacts WHERE user_id = ? AND deleted = 0
 Plan:
 SEARCH contacts USING INDEX idx_contacts_chat_ts (user_id=?)
@@ -7801,10 +7902,26 @@ Query: SELECT count(1) FROM pending_group_messages
 Plan:
 SCAN pending_group_messages USING COVERING INDEX idx_pending_group_messages_group_member_id
 
+Query: SELECT credential FROM badge_issuances WHERE entry_id = ?
+Plan:
+SEARCH badge_issuances USING INDEX idx_badge_issuances_entry (entry_id=?)
+
+Query: SELECT credit_error FROM badge_store_receipts WHERE badge_store_receipt_id = ?
+Plan:
+SEARCH badge_store_receipts USING INTEGER PRIMARY KEY (rowid=?)
+
+Query: SELECT credit_error FROM badge_store_receipts WHERE credit_error IS NOT NULL
+Plan:
+SCAN badge_store_receipts
+
 Query: SELECT credit_error FROM badge_store_receipts WHERE payment IS NOT NULL AND credit_error IS NOT NULL
 Plan:
 SCAN badge_store_receipts
 
+Query: SELECT current_badge_type FROM badge_purchases ORDER BY badge_purchase_id
+Plan:
+SCAN badge_purchases
+
 Query: SELECT entropy FROM wallet_seeds
 Plan:
 SCAN wallet_seeds
@@ -7859,6 +7976,10 @@ Query: SELECT group_id FROM groups WHERE user_id = ? AND (chat_item_ttl > 0 OR c
 Plan:
 SEARCH groups USING INDEX sqlite_autoindex_groups_2 (user_id=?)
 
+Query: SELECT group_id FROM groups WHERE user_id = ? AND (chat_item_ttl > 0)
+Plan:
+SEARCH groups USING INDEX sqlite_autoindex_groups_2 (user_id=?)
+
 Query: SELECT group_id FROM groups WHERE user_id = ? AND creating_in_progress = 1 AND created_at <= ?
 Plan:
 SEARCH groups USING INDEX sqlite_autoindex_groups_2 (user_id=?)
@@ -7899,6 +8020,10 @@ Query: SELECT index_in_group, member_relations_vector FROM group_members WHERE l
 Plan:
 SCAN group_members
 
+Query: SELECT issue_error_at FROM badge_purchases
+Plan:
+SCAN badge_purchases
+
 Query: SELECT issue_failed_since, issue_error FROM badge_purchases
 Plan:
 SCAN badge_purchases
@@ -7987,6 +8112,210 @@ Query: SELECT member_xcontact_id, member_welcome_shared_msg_id FROM group_member
 Plan:
 SEARCH group_members USING INTEGER PRIMARY KEY (rowid=?)
 
+Query: SELECT message_id FROM messages WHERE msg_sent = 0 AND hex(shared_msg_id) = '32316A574B414A435165634A50792F53'
+Plan:
+SCAN messages
+
+Query: SELECT message_id FROM messages WHERE msg_sent = 0 AND hex(shared_msg_id) = '34777371515341626273746F6A725531'
+Plan:
+SCAN messages
+
+Query: SELECT message_id FROM messages WHERE msg_sent = 0 AND hex(shared_msg_id) = '364C745457626A726943454F5139666D'
+Plan:
+SCAN messages
+
+Query: SELECT message_id FROM messages WHERE msg_sent = 0 AND hex(shared_msg_id) = '365431694F536951395477767543584B'
+Plan:
+SCAN messages
+
+Query: SELECT message_id FROM messages WHERE msg_sent = 0 AND hex(shared_msg_id) = '392F42343435485A4D6C4A4A42784179'
+Plan:
+SCAN messages
+
+Query: SELECT message_id FROM messages WHERE msg_sent = 0 AND hex(shared_msg_id) = '417A30336574747049655266542B536C'
+Plan:
+SCAN messages
+
+Query: SELECT message_id FROM messages WHERE msg_sent = 0 AND hex(shared_msg_id) = '433045507738554A4F7579523533326F'
+Plan:
+SCAN messages
+
+Query: SELECT message_id FROM messages WHERE msg_sent = 0 AND hex(shared_msg_id) = '44797166387A61574D33377351566A70'
+Plan:
+SCAN messages
+
+Query: SELECT message_id FROM messages WHERE msg_sent = 0 AND hex(shared_msg_id) = '47416E6C397937475639655A4F6A4872'
+Plan:
+SCAN messages
+
+Query: SELECT message_id FROM messages WHERE msg_sent = 0 AND hex(shared_msg_id) = '47662F48747469674A782F4B6C485865'
+Plan:
+SCAN messages
+
+Query: SELECT message_id FROM messages WHERE msg_sent = 0 AND hex(shared_msg_id) = '486F6247596E317158426C6857656B58'
+Plan:
+SCAN messages
+
+Query: SELECT message_id FROM messages WHERE msg_sent = 0 AND hex(shared_msg_id) = '4B474E46695541693956467863556162'
+Plan:
+SCAN messages
+
+Query: SELECT message_id FROM messages WHERE msg_sent = 0 AND hex(shared_msg_id) = '4B66326D76554F74434C3653464A6934'
+Plan:
+SCAN messages
+
+Query: SELECT message_id FROM messages WHERE msg_sent = 0 AND hex(shared_msg_id) = '4B6A54346C556543442B70736A657343'
+Plan:
+SCAN messages
+
+Query: SELECT message_id FROM messages WHERE msg_sent = 0 AND hex(shared_msg_id) = '4C41445631472B445858565442547459'
+Plan:
+SCAN messages
+
+Query: SELECT message_id FROM messages WHERE msg_sent = 0 AND hex(shared_msg_id) = '4C424D4D41583853784C6A6769634C7A'
+Plan:
+SCAN messages
+
+Query: SELECT message_id FROM messages WHERE msg_sent = 0 AND hex(shared_msg_id) = '4E3530694B50794D6C6A386764364D36'
+Plan:
+SCAN messages
+
+Query: SELECT message_id FROM messages WHERE msg_sent = 0 AND hex(shared_msg_id) = '4F682F542F664E73554974746A646457'
+Plan:
+SCAN messages
+
+Query: SELECT message_id FROM messages WHERE msg_sent = 0 AND hex(shared_msg_id) = '4F6B396E4E486B7A4E7A2F505461306D'
+Plan:
+SCAN messages
+
+Query: SELECT message_id FROM messages WHERE msg_sent = 0 AND hex(shared_msg_id) = '4F6C47567330784972386E4B72496661'
+Plan:
+SCAN messages
+
+Query: SELECT message_id FROM messages WHERE msg_sent = 0 AND hex(shared_msg_id) = '51504E3266467468397A5A6A555A5A59'
+Plan:
+SCAN messages
+
+Query: SELECT message_id FROM messages WHERE msg_sent = 0 AND hex(shared_msg_id) = '516E6B70364443765466557A74576F51'
+Plan:
+SCAN messages
+
+Query: SELECT message_id FROM messages WHERE msg_sent = 0 AND hex(shared_msg_id) = '52346F3844796156594651305A6E6A4E'
+Plan:
+SCAN messages
+
+Query: SELECT message_id FROM messages WHERE msg_sent = 0 AND hex(shared_msg_id) = '525038584D53442F6863586C54706D70'
+Plan:
+SCAN messages
+
+Query: SELECT message_id FROM messages WHERE msg_sent = 0 AND hex(shared_msg_id) = '52567950695555535955742B7A6B432B'
+Plan:
+SCAN messages
+
+Query: SELECT message_id FROM messages WHERE msg_sent = 0 AND hex(shared_msg_id) = '53526370717345687454376566784A52'
+Plan:
+SCAN messages
+
+Query: SELECT message_id FROM messages WHERE msg_sent = 0 AND hex(shared_msg_id) = '55455056465233397446394D36417837'
+Plan:
+SCAN messages
+
+Query: SELECT message_id FROM messages WHERE msg_sent = 0 AND hex(shared_msg_id) = '55566967354649644E5644704E4E4578'
+Plan:
+SCAN messages
+
+Query: SELECT message_id FROM messages WHERE msg_sent = 0 AND hex(shared_msg_id) = '562B3130557347544E67734559524C35'
+Plan:
+SCAN messages
+
+Query: SELECT message_id FROM messages WHERE msg_sent = 0 AND hex(shared_msg_id) = '57344B6B584E514C4B30727A6A56394B'
+Plan:
+SCAN messages
+
+Query: SELECT message_id FROM messages WHERE msg_sent = 0 AND hex(shared_msg_id) = '57625336465661464B567538756A6C56'
+Plan:
+SCAN messages
+
+Query: SELECT message_id FROM messages WHERE msg_sent = 0 AND hex(shared_msg_id) = '57786C587171347577326B6E4B343430'
+Plan:
+SCAN messages
+
+Query: SELECT message_id FROM messages WHERE msg_sent = 0 AND hex(shared_msg_id) = '58326263487A776B576F5A322B452F56'
+Plan:
+SCAN messages
+
+Query: SELECT message_id FROM messages WHERE msg_sent = 0 AND hex(shared_msg_id) = '584F5873316B49463861366249744146'
+Plan:
+SCAN messages
+
+Query: SELECT message_id FROM messages WHERE msg_sent = 0 AND hex(shared_msg_id) = '614C4637486D4C3141774D42754E6958'
+Plan:
+SCAN messages
+
+Query: SELECT message_id FROM messages WHERE msg_sent = 0 AND hex(shared_msg_id) = '6164576959516B7051312F635174612F'
+Plan:
+SCAN messages
+
+Query: SELECT message_id FROM messages WHERE msg_sent = 0 AND hex(shared_msg_id) = '62454B4B3074475654356464626C4331'
+Plan:
+SCAN messages
+
+Query: SELECT message_id FROM messages WHERE msg_sent = 0 AND hex(shared_msg_id) = '684D6135384C78366B2B435771687870'
+Plan:
+SCAN messages
+
+Query: SELECT message_id FROM messages WHERE msg_sent = 0 AND hex(shared_msg_id) = '68565070767234594F4F4F3777783743'
+Plan:
+SCAN messages
+
+Query: SELECT message_id FROM messages WHERE msg_sent = 0 AND hex(shared_msg_id) = '6976634F5868363358575167476C5731'
+Plan:
+SCAN messages
+
+Query: SELECT message_id FROM messages WHERE msg_sent = 0 AND hex(shared_msg_id) = '6D72486D5153563130647836586A784A'
+Plan:
+SCAN messages
+
+Query: SELECT message_id FROM messages WHERE msg_sent = 0 AND hex(shared_msg_id) = '6F512B70507A763170634B2F77414D45'
+Plan:
+SCAN messages
+
+Query: SELECT message_id FROM messages WHERE msg_sent = 0 AND hex(shared_msg_id) = '7138444F774A364F492B6D4B56712F53'
+Plan:
+SCAN messages
+
+Query: SELECT message_id FROM messages WHERE msg_sent = 0 AND hex(shared_msg_id) = '71684C516E6E423172626C595546536D'
+Plan:
+SCAN messages
+
+Query: SELECT message_id FROM messages WHERE msg_sent = 0 AND hex(shared_msg_id) = '72395A612F30424B732B41375061344D'
+Plan:
+SCAN messages
+
+Query: SELECT message_id FROM messages WHERE msg_sent = 0 AND hex(shared_msg_id) = '7351307538344376486B4A79664E687A'
+Plan:
+SCAN messages
+
+Query: SELECT message_id FROM messages WHERE msg_sent = 0 AND hex(shared_msg_id) = '7435356241497658594F334A42374767'
+Plan:
+SCAN messages
+
+Query: SELECT message_id FROM messages WHERE msg_sent = 0 AND hex(shared_msg_id) = '75413371367563467650575265516A6A'
+Plan:
+SCAN messages
+
+Query: SELECT message_id FROM messages WHERE msg_sent = 0 AND hex(shared_msg_id) = '79326A546878645A336346444D506B56'
+Plan:
+SCAN messages
+
+Query: SELECT message_id FROM messages WHERE msg_sent = 0 AND hex(shared_msg_id) = '794D423855453661496754424746484F'
+Plan:
+SCAN messages
+
+Query: SELECT next_wake_at FROM badge_purchases
+Plan:
+SCAN badge_purchases
+
 Query: SELECT next_wake_at, badge_purchase_id FROM badge_purchases
 Plan:
 SCAN badge_purchases
@@ -8008,6 +8337,14 @@ Plan:
 SCAN m
 SEARCH p USING INTEGER PRIMARY KEY (rowid=?)
 
+Query: SELECT payment, credit_error FROM badge_store_receipts WHERE user_id = ? AND payment IS NOT NULL
+Plan:
+SEARCH badge_store_receipts USING INDEX idx_badge_store_receipts_user (user_id=?)
+
+Query: SELECT payment, next_attempt_at FROM badge_store_receipts WHERE payment IS NOT NULL
+Plan:
+SCAN badge_store_receipts
+
 Query: SELECT purchase_key FROM badge_code_redemptions
 Plan:
 SCAN badge_code_redemptions
@@ -8032,6 +8369,14 @@ Query: SELECT relay_status FROM group_relays WHERE group_relay_id = ?
 Plan:
 SEARCH group_relays USING INTEGER PRIMARY KEY (rowid=?)
 
+Query: SELECT retry_count FROM badge_store_receipts
+Plan:
+SCAN badge_store_receipts
+
+Query: SELECT retry_count FROM badge_store_receipts WHERE badge_store_receipt_id = ?
+Plan:
+SEARCH badge_store_receipts USING INTEGER PRIMARY KEY (rowid=?)
+
 Query: SELECT roster_blob FROM groups WHERE roster_blob IS NOT NULL
 Plan:
 SCAN groups
@@ -8092,10 +8437,18 @@ Query: SELECT stored_roster_version FROM groups WHERE group_id = ?
 Plan:
 SEARCH groups USING INTEGER PRIMARY KEY (rowid=?)
 
+Query: SELECT subscription_status FROM badge_purchases
+Plan:
+SCAN badge_purchases
+
 Query: SELECT summary_current_members_count FROM groups WHERE group_id = ?
 Plan:
 SEARCH groups USING INTEGER PRIMARY KEY (rowid=?)
 
+Query: SELECT unrenewed_since, last_unrenewed_at FROM badge_purchases
+Plan:
+SCAN badge_purchases
+
 Query: SELECT user_contact_link_id FROM contact_requests WHERE contact_request_id = ?
 Plan:
 SEARCH contact_requests USING INTEGER PRIMARY KEY (rowid=?)
@@ -8108,10 +8461,22 @@ Query: SELECT user_id FROM users WHERE local_display_name = ?
 Plan:
 SEARCH users USING COVERING INDEX sqlite_autoindex_users_2 (local_display_name=?)
 
+Query: SELECT user_id, badge_store_receipt_id IS NOT NULL FROM badge_purchases ORDER BY badge_purchase_id
+Plan:
+SCAN badge_purchases
+
+Query: SELECT user_id, hold_kind FROM badge_store_receipts ORDER BY badge_store_receipt_id
+Plan:
+SCAN badge_store_receipts
+
 Query: SELECT user_id, invoice_id, transaction_ref IS NOT NULL FROM badge_store_receipts ORDER BY badge_store_receipt_id
 Plan:
 SCAN badge_store_receipts
 
+Query: SELECT user_id, shown_badge_id FROM users ORDER BY user_id
+Plan:
+SCAN users
+
 Query: SELECT via_contact_uri, pres_header FROM connections WHERE connection_id = ?
 Plan:
 SEARCH connections USING INTEGER PRIMARY KEY (rowid=?)
@@ -8128,31 +8493,57 @@ Query: SELECT xgrplinkmem_received FROM group_members WHERE group_member_id = ?
 Plan:
 SEARCH group_members USING INTEGER PRIMARY KEY (rowid=?)
 
+Query: UPDATE badge_issuances SET period_end = ? WHERE entry_id = ?
+Plan:
+SEARCH badge_issuances USING INDEX idx_badge_issuances_entry (entry_id=?)
+
 Query: UPDATE badge_purchases SET alert_acked_kind = ?, alert_acked_episode = ?, alert_snooze_until = ? WHERE badge_purchase_id = ? AND user_id = ?
 Plan:
 SEARCH badge_purchases USING INTEGER PRIMARY KEY (rowid=?)
 
+Query: UPDATE badge_purchases SET badge_store_receipt_id = NULL WHERE badge_store_receipt_id = ? AND EXISTS (SELECT 1 FROM badge_store_receipts WHERE badge_store_receipt_id = ? AND hold_kind = ?)
+Plan:
+SEARCH badge_purchases USING INDEX idx_badge_purchases_store_receipt (badge_store_receipt_id=?)
+SCALAR SUBQUERY 1
+SEARCH badge_store_receipts USING INTEGER PRIMARY KEY (rowid=?)
+
+Query: UPDATE badge_purchases SET current_badge_type = ?, updated_at = ? WHERE badge_purchase_id = ?
+Plan:
+SEARCH badge_purchases USING INTEGER PRIMARY KEY (rowid=?)
+
 Query: UPDATE badge_purchases SET issue_failed_since = NULL, issue_error_at = NULL, issue_error = NULL WHERE badge_purchase_id = ?
 Plan:
 SEARCH badge_purchases USING INTEGER PRIMARY KEY (rowid=?)
 
+Query: UPDATE badge_purchases SET next_wake_at = ?
+Plan:
+SCAN badge_purchases
+
 Query: UPDATE badge_purchases SET next_wake_at = ? WHERE badge_purchase_id = ?
 Plan:
 SEARCH badge_purchases USING INTEGER PRIMARY KEY (rowid=?)
 
+Query: UPDATE badge_purchases SET subscription_status = ? WHERE badge_purchase_id = ?
+Plan:
+SEARCH badge_purchases USING INTEGER PRIMARY KEY (rowid=?)
+
+Query: UPDATE badge_purchases SET unrenewed_since = ?, last_unrenewed_at = ? WHERE badge_purchase_id = ?
+Plan:
+SEARCH badge_purchases USING INTEGER PRIMARY KEY (rowid=?)
+
+Query: UPDATE badge_store_receipts SET credit_error = NULL WHERE badge_store_receipt_id = ? AND payment IS NULL
+Plan:
+SEARCH badge_store_receipts USING INTEGER PRIMARY KEY (rowid=?)
+
 Query: UPDATE badge_store_receipts SET payment = ?
 Plan:
 SCAN badge_store_receipts
 
-Query: UPDATE badge_store_receipts SET payment = ? WHERE badge_store_receipt_id = ? AND payment IS NOT NULL
+Query: UPDATE badge_store_receipts SET payment = ?, next_attempt_at = ?, retry_delay = NULL, credit_error = NULL WHERE badge_store_receipt_id = ? AND payment = ?
 Plan:
 SEARCH badge_store_receipts USING INTEGER PRIMARY KEY (rowid=?)
 
-Query: UPDATE badge_store_receipts SET payment = NULL, next_attempt_at = NULL, retry_delay = NULL, retry_count = 0 WHERE badge_store_receipt_id = ?
-Plan:
-SEARCH badge_store_receipts USING INTEGER PRIMARY KEY (rowid=?)
-
-Query: UPDATE badge_store_receipts SET payment = NULL, next_attempt_at = NULL, retry_delay = NULL, retry_count = 0, credit_error = ? WHERE badge_store_receipt_id = ?
+Query: UPDATE badge_store_receipts SET payment = ?, next_attempt_at = ?, retry_delay = NULL, retry_count = 0, credit_error = NULL, hold_kind = ? WHERE badge_store_receipt_id = ? AND payment IS NULL
 Plan:
 SEARCH badge_store_receipts USING INTEGER PRIMARY KEY (rowid=?)
 
@@ -8160,6 +8551,18 @@ Query: UPDATE badge_store_receipts SET provider = ?, transaction_ref = ?, paymen
 Plan:
 SEARCH badge_store_receipts USING INDEX sqlite_autoindex_badge_store_receipts_1 (invoice_id=?)
 
+Query: UPDATE badge_store_receipts SET purchase_key = ?, purchase_priv_key = ?, master_key = ? WHERE badge_store_receipt_id = ? AND payment IS NULL
+Plan:
+SEARCH badge_store_receipts USING INTEGER PRIMARY KEY (rowid=?)
+
+Query: UPDATE badge_store_receipts SET user_id = ?, hold_kind = ?, next_attempt_at = ? WHERE badge_store_receipt_id = ? AND payment IS NOT NULL AND hold_kind = ?
+Plan:
+SEARCH badge_store_receipts USING INTEGER PRIMARY KEY (rowid=?)
+
+Query: UPDATE badge_store_receipts SET user_id = ?, payment = ?, next_attempt_at = ?, retry_delay = NULL, retry_count = 0, credit_error = NULL, hold_kind = ? WHERE badge_store_receipt_id = ? AND payment IS NULL
+Plan:
+SEARCH badge_store_receipts USING INTEGER PRIMARY KEY (rowid=?)
+
 Query: UPDATE chat_items SET item_content = ?, item_text = ?, updated_at = ? WHERE chat_item_id = ?
 Plan:
 SEARCH chat_items USING INTEGER PRIMARY KEY (rowid=?)

src/Simplex/Chat/Store/SQLite/Migrations/chat_schema.sql

@@ -946,6 +946,9 @@ CREATE TABLE badge_purchases(
   issue_error TEXT,
   next_wake_at TEXT,
   badge_store_receipt_id INTEGER REFERENCES badge_store_receipts,
+  subscription_status TEXT,
+  unrenewed_since TEXT,
+  last_unrenewed_at TEXT,
   UNIQUE(purchase_key)
 ) STRICT;
 CREATE TABLE badge_ledger(
@@ -1015,6 +1018,7 @@ CREATE TABLE badge_store_receipts(
   retry_delay INTEGER,
   retry_count INTEGER NOT NULL DEFAULT 0,
   credit_error TEXT,
+  hold_kind TEXT NOT NULL DEFAULT 'purchase',
   UNIQUE(provider, transaction_ref)
 ) STRICT;
 CREATE TABLE wallet_seeds(

src/Simplex/Chat/View.hs

@@ -46,7 +46,7 @@ import Simplex.Chat.Markdown
 import Simplex.Chat.Badges (BadgeInfo (..), BadgeStatus (..), BadgeType (..), LocalBadge, localBadgeInfo, localBadgeStatus)
 import Simplex.Chat.Badges.Ledger (creditTypeTag, debitTypeTag)
 import Simplex.Chat.Badges.Service (StatementEntry (..), StatementEntryType (..))
-import Simplex.Chat.Badges.Types (BadgeAlert (..), BadgeIssueError (..), BadgeState (..), OpenStorePurchase (..))
+import Simplex.Chat.Badges.Types (BadgeAlert (..), BadgeIssueError (..), BadgeState (..), BadgeSubscription (..), OpenStorePurchase (..))
 import Simplex.Chat.Messages hiding (NewChatItem (..))
 import Simplex.Chat.Messages.CIContent
 import Simplex.Chat.Operators
@@ -196,6 +196,7 @@ chatResponseToView hu cfg@ChatConfig {logLevel, showReactions, showFullLinks, te
   -- the badge is only shown when it is the one now on the profile; a replayed code's badge may not be
   CRBadgeRedeemed u badge newBadge _ -> ttyUser u $ if newBadge then "badge redeemed" : viewContactBadge (Just badge) else ["badge already redeemed"]
   CRBadgeInvoice u invoiceId -> ttyUser u ["badge invoice: " <> plain invoiceId]
+  CRStoreReceiptNotRecorded u -> ttyUser u ["store purchase not recorded"]
   CRBadgeState u st storePurchases -> ttyUser u $ viewUserBadgeState st <> map viewOpenStorePurchase storePurchases
   CRBadgeLedger u entries -> ttyUser u $ viewBadgeLedger entries
   CRWallet u info -> ttyUser u $ viewWalletInfo info
@@ -1854,7 +1855,7 @@ viewContactBadge = maybe [] $ \lb ->
 viewUserBadgeState :: Maybe BadgeState -> [StyledString]
 viewUserBadgeState = maybe [] viewBadge
   where
-    viewBadge BadgeState {badgePurchaseId, badgeType, monthsLeft, paidThrough, alert, issueError, nextWakeAt} =
+    viewBadge BadgeState {badgePurchaseId, badgeType, monthsLeft, paidThrough, alert, issueError, nextWakeAt, subscription} =
       plain
         ( tshow badgePurchaseId
             <> ": "
@@ -1863,10 +1864,12 @@ viewUserBadgeState = maybe [] viewBadge
             <> tshow monthsLeft
             <> " months left, paid through "
             <> day paidThrough
+            <> maybe "" viewSubscription subscription
             <> maybe "" ((", next check " <>) . dayTime) nextWakeAt
         )
         : maybe [] viewBadgeIssueError issueError
           <> maybe [] viewBadgeAlert alert
+    viewSubscription BadgeSubscription {status} = ", subscription" <> maybe "" ((" " <>) . textEncode) status
 
 viewBadgeIssueError :: BadgeIssueError -> [StyledString]
 viewBadgeIssueError BadgeIssueError {failedSince, lastAttemptAt, reason} =
@@ -2945,6 +2948,7 @@ viewChatError isCmd logLevel testView = \case
             BREInvalidReceipt -> "invalid store receipt"
             BREServiceNotConfigured -> "badge service not configured"
             BREBadgeActive -> "badge already active"
+            BREStorePurchaseOpen -> "store purchase open"
             BREServiceError code -> "badge service error: " <> T.unpack (badgeServiceErrorText code)
             BREInvalidResponse m -> "invalid service response: " <> m
             BREUnknownKeyIndex -> "credential names an unknown badge key index"