diff --git a/apps/simplex-badge-service/src/BadgeService/Service.hs b/apps/simplex-badge-service/src/BadgeService/Service.hs index 92eeeb195b..67e21278f5 100644 --- a/apps/simplex-badge-service/src/BadgeService/Service.hs +++ b/apps/simplex-badge-service/src/BadgeService/Service.hs @@ -383,9 +383,9 @@ credentialForEntry BadgeIssuerKey {keyIdx, secretKey} masterKey e@StatementEntry issuanceAfter :: StatementEntry -> (StatementEntry, BadgeCredential) -> (StatementEntry, StatementEntry, BadgeCredential) issuanceAfter previous (issued, credential) = (previous, issued, credential) -credentialResponse :: Maybe BadgeCredential -> Maybe T.Text -> [StatementEntry] -> BadgeServiceResponse -credentialResponse credential previousEntryId entries = - BSPBadgeCredential {credential, receipt = Nothing, statement = BadgeStatement {entries, previousEntryId}} +credentialResponse :: Maybe BadgeCredential -> Maybe T.Text -> Maybe SubscriptionState -> [StatementEntry] -> BadgeServiceResponse +credentialResponse credential previousEntryId subscription entries = + BSPBadgeCredential {credential, receipt = Nothing, statement = BadgeStatement {entries, previousEntryId}, subscription} -- | Nothing is written until the credential is signed, so a signing failure leaves the code unspent. redeemCode :: BadgeIssuerKey -> ChatController -> Maybe (TQueue GroupEvent) -> C.PublicKeyEd25519 -> BadgeMasterKey -> T.Text -> IO BadgeServiceResponse @@ -420,7 +420,7 @@ redeemCode key cc trackerQ_ purchaseKey masterKey codeText = case parseBadgeCode -- A key that already redeemed gets its credential back without a use, even if the code has since -- expired or been revoked: a client whose reply was lost retries, and would otherwise lose the badge. KeyRedeemed KeyPurchase {badgePurchaseId, credential} -> - maybe (Left $ errorResponse BSEInternal) (Left . credentialResponse (Just credential) Nothing) + maybe (Left $ errorResponse BSEInternal) (Left . credentialResponse (Just credential) Nothing Nothing) <$> getLedgerEntries db badgePurchaseId 0 -- code_used would make the client drop its keys, so the holder could never get the badge back. KeyRedeemedUnreadable -> @@ -504,7 +504,7 @@ creditedResponse db purchaseKey = \case Credited CreditedPurchase {purchaseKey = k, badgePurchaseId, credential} | k /= purchaseKey -> pure $ Left $ errorResponse BSEReceiptUsed | otherwise -> - maybe (Left $ errorResponse BSEInternal) (Left . credentialResponse (Just credential) Nothing) + maybe (Left $ errorResponse BSEInternal) (Left . credentialResponse (Just credential) Nothing Nothing) <$> getLedgerEntries db badgePurchaseId 0 signFirstMonth :: BadgeIssuerKey -> ChatController -> BadgeMasterKey -> BadgeType -> Int -> StatementCreditType -> UTCTime -> IO (Either BadgeServiceResponse (StatementEntry, (StatementEntry, BadgeCredential))) @@ -525,7 +525,7 @@ firstMonthResponse :: DB.Connection -> Int64 -> Maybe T.Text -> (StatementEntry, firstMonthResponse db purchaseId creditPaymentId_ (granted, signed) = do appendLedgerPlan db purchaseId creditPaymentId_ [granted] $ Just $ issuanceAfter granted signed entries_ <- getLedgerEntries db purchaseId 0 - pure $ maybe (errorResponse BSEInternal) (credentialResponse (Just $ snd signed) Nothing) entries_ + pure $ maybe (errorResponse BSEInternal) (credentialResponse (Just $ snd signed) Nothing Nothing) entries_ -- | The purchase is reached through the verified signer key and no other way. issueBadgeCmd :: BadgeIssuerKey -> ChatController -> C.PublicKeyEd25519 -> BadgeBalance -> IO BadgeServiceResponse @@ -565,4 +565,4 @@ issueBadgeCmd key cc purchaseKey BadgeBalance {lastEntry} = do -- single opening credit, rather than resending the whole history entries_ <- getLedgerEntries db purchaseId (fromMaybe 0 assertedId) credential_ <- getCurrentIssuance db purchaseId t - pure $ maybe (errorResponse BSEInternal) (credentialResponse credential_ (assertedUuid <$ assertedId)) entries_ + pure $ maybe (errorResponse BSEInternal) (credentialResponse credential_ (assertedUuid <$ assertedId) Nothing) entries_ diff --git a/apps/simplex-badge-service/src/BadgeService/Store.hs b/apps/simplex-badge-service/src/BadgeService/Store.hs index 6d238e78f4..0360fdb693 100644 --- a/apps/simplex-badge-service/src/BadgeService/Store.hs +++ b/apps/simplex-badge-service/src/BadgeService/Store.hs @@ -251,7 +251,7 @@ getLedgerTip db purchaseId = db [sql| SELECT l.entry_uuid, l.change_months, l.balance_months, l.balance_start_ts, l.balance_anchor_ts, l.balance_badge_type, - l.entry_type, l.entry_credit_type, l.entry_debit_type, l.service_created_at, l.payment_id, pay.invoice_id + l.entry_type, l.entry_credit_type, l.entry_debit_type, l.service_created_at, l.payment_id, pay.invoice_id, l.charge_id FROM sx_badge_service_badge_ledger l LEFT JOIN sx_badge_service_payments pay ON pay.payment_id = l.payment_id WHERE l.badge_purchase_id = ? @@ -276,7 +276,7 @@ getLedgerEntries db purchaseId afterEntryId = db [sql| SELECT l.entry_uuid, l.change_months, l.balance_months, l.balance_start_ts, l.balance_anchor_ts, l.balance_badge_type, - l.entry_type, l.entry_credit_type, l.entry_debit_type, l.service_created_at, l.payment_id, pay.invoice_id + l.entry_type, l.entry_credit_type, l.entry_debit_type, l.service_created_at, l.payment_id, pay.invoice_id, l.charge_id FROM sx_badge_service_badge_ledger l LEFT JOIN sx_badge_service_payments pay ON pay.payment_id = l.payment_id WHERE l.badge_purchase_id = ? AND l.entry_id > ? @@ -284,10 +284,10 @@ getLedgerEntries db purchaseId afterEntryId = |] (purchaseId, afterEntryId) -toEntry :: (Text, Int, Int, UTCTime, UTCTime, BadgeType, Text, Maybe Text, Maybe Text, UTCTime) :. (Maybe Text, Maybe Text) -> Maybe StatementEntry -toEntry ((entryId, changeMonths, balanceMonths, balanceStartTs, balanceAnchorTs, balanceBadgeType, entryType_, credit_, debit_, createdAt) :. (paymentId_, invoiceId_)) = +toEntry :: (Text, Int, Int, UTCTime, UTCTime, BadgeType, Text, Maybe Text, Maybe Text, UTCTime) :. (Maybe Text, Maybe Text, Maybe Text) -> Maybe StatementEntry +toEntry ((entryId, changeMonths, balanceMonths, balanceStartTs, balanceAnchorTs, balanceBadgeType, entryType_, credit_, debit_, createdAt) :. (paymentId_, invoiceId_, chargeId_)) = (\entryType -> StatementEntry {entryId, changeMonths, balanceMonths, balanceStartTs, balanceAnchorTs, balanceBadgeType, wasPausedSince = Nothing, createdAt, entryType}) - <$> entryTypeFromColumns ((InvoiceId <$> invoiceId_) <$ paymentId_) entryType_ credit_ debit_ + <$> entryTypeFromColumns ((InvoiceId <$> invoiceId_) <$ paymentId_) chargeId_ entryType_ credit_ debit_ getCurrentIssuance :: DB.Connection -> Int64 -> UTCTime -> IO (Maybe BadgeCredential) getCurrentIssuance db purchaseId now = do @@ -306,7 +306,7 @@ getCurrentIssuance db purchaseId now = do _ -> Nothing -- | creditPaymentId_ names the payment behind a payment credit among the rows. --- TODO write the other reference columns (charge_id, from_purchase_id, to_purchase_id) for entry types that carry one; only the tag is written today. +-- TODO write the other reference columns (from_purchase_id, to_purchase_id) for entry types that carry one; only the tag is written today. appendLedgerPlan :: DB.Connection -> Int64 -> Maybe Text -> [StatementEntry] -> Maybe (StatementEntry, StatementEntry, BadgeCredential) -> IO () appendLedgerPlan db purchaseId creditPaymentId_ rows issuance_ = do mapM_ appendRow rows @@ -327,18 +327,19 @@ appendLedgerPlan db purchaseId creditPaymentId_ rows issuance_ = do where appendRow StatementEntry {entryId, changeMonths, balanceMonths, balanceStartTs, balanceAnchorTs, balanceBadgeType, createdAt, entryType} = do let (entryTypeT, creditType, debitType) = entryTypeColumns entryType - paymentId_ = case entryType of - SECredit SCPayment {} -> creditPaymentId_ - _ -> Nothing + (paymentId_, chargeId_) = case entryType of + SECredit SCPayment {} -> (creditPaymentId_, Nothing) + SECredit SCCharge {chargeId} -> (Nothing, Just chargeId) + _ -> (Nothing, Nothing) DB.execute db [sql| INSERT INTO sx_badge_service_badge_ledger (entry_uuid, badge_purchase_id, change_months, balance_months, balance_start_ts, balance_anchor_ts, - balance_badge_type, service_created_at, created_at, entry_type, entry_credit_type, entry_debit_type, payment_id) - VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?) + balance_badge_type, service_created_at, created_at, entry_type, entry_credit_type, entry_debit_type, payment_id, charge_id) + VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?) |] - ((entryId, purchaseId, changeMonths, balanceMonths, balanceStartTs, balanceAnchorTs) :. (balanceBadgeType, createdAt, createdAt, entryTypeT, creditType, debitType, paymentId_)) + ((entryId, purchaseId, changeMonths, balanceMonths, balanceStartTs, balanceAnchorTs) :. (balanceBadgeType, createdAt, createdAt, entryTypeT, creditType, debitType, paymentId_, chargeId_)) insertedRowId db -- The claim takes one use before adding the purchase, so a concurrent revoke or redemption waits on this row and sees the new count. diff --git a/apps/simplex-badge-service/src/BadgeService/Store/Postgres/Migrations.hs b/apps/simplex-badge-service/src/BadgeService/Store/Postgres/Migrations.hs index 92d3b5fd47..5f2575acb1 100644 --- a/apps/simplex-badge-service/src/BadgeService/Store/Postgres/Migrations.hs +++ b/apps/simplex-badge-service/src/BadgeService/Store/Postgres/Migrations.hs @@ -19,7 +19,8 @@ schemaMigrations :: [(String, Text, Maybe Text)] schemaMigrations = [ ("20260915_badge_service_schema", m20260915_badge_service_schema, Just down_m20260915_badge_service_schema), ("20260918_badge_group_ops", m20260918_badge_group_ops, Just down_m20260918_badge_group_ops), - ("20260925_badge_store_receipts", m20260925_badge_store_receipts, Just down_m20260925_badge_store_receipts) + ("20260925_badge_store_receipts", m20260925_badge_store_receipts, Just down_m20260925_badge_store_receipts), + ("20261012_badge_subscriptions", m20261012_badge_subscriptions, Just down_m20261012_badge_subscriptions) ] -- | The client tables share this database, so the service tables are the same names behind a prefix. @@ -191,6 +192,66 @@ DROP INDEX @idx_payments_provider_ref; CREATE INDEX @idx_payments_provider_ref ON @payments(provider, provider_ref); |] +m20261012_badge_subscriptions :: Text +m20261012_badge_subscriptions = + withPrefix + servicePrefix + -- provider_token is a Play purchase token, a bearer secret: it is kept only for a subscription, which Play is asked about again. + [r| +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, + plan_id TEXT NOT NULL, + period_start TIMESTAMPTZ NOT NULL, + period_end TIMESTAMPTZ NOT NULL, + amount BIGINT, + currency TEXT, + created_at TIMESTAMPTZ NOT NULL, + UNIQUE(payment_id, provider_charge_ref) +); + +ALTER TABLE @badge_ledger ADD COLUMN charge_id TEXT REFERENCES @subscription_charges; + +CREATE INDEX @idx_badge_ledger_charge ON @badge_ledger(charge_id); + +ALTER TABLE @payments ADD COLUMN subscription_state TEXT; + +ALTER TABLE @payments ADD COLUMN subscription_checked_at TIMESTAMPTZ; + +ALTER TABLE @payments ADD COLUMN provider_token TEXT; + +ALTER TABLE @payments DROP COLUMN subscription_renews_at; + +ALTER TABLE @payments DROP COLUMN grace_until; + +ALTER TABLE @payments DROP COLUMN cancelled; +|] + +down_m20261012_badge_subscriptions :: Text +down_m20261012_badge_subscriptions = + withPrefix + servicePrefix + [r| +ALTER TABLE @payments ADD COLUMN subscription_renews_at TIMESTAMPTZ; + +ALTER TABLE @payments ADD COLUMN grace_until TIMESTAMPTZ; + +ALTER TABLE @payments ADD COLUMN cancelled SMALLINT NOT NULL DEFAULT 0; + +ALTER TABLE @payments DROP COLUMN provider_token; + +ALTER TABLE @payments DROP COLUMN subscription_checked_at; + +ALTER TABLE @payments DROP COLUMN subscription_state; + +DROP INDEX @idx_badge_ledger_charge; + +ALTER TABLE @badge_ledger DROP COLUMN charge_id; + +DROP TABLE @subscription_charges; +|] + {- TODO [badges] deferred with the draft in M20260915_user_badges, service only. ALTER TABLE @payments ADD COLUMN receipt_hash BYTEA; diff --git a/apps/simplex-badge-service/src/BadgeService/Store/SQLite/Migrations.hs b/apps/simplex-badge-service/src/BadgeService/Store/SQLite/Migrations.hs index cd3d97f0ac..3409aa4f05 100644 --- a/apps/simplex-badge-service/src/BadgeService/Store/SQLite/Migrations.hs +++ b/apps/simplex-badge-service/src/BadgeService/Store/SQLite/Migrations.hs @@ -20,7 +20,8 @@ schemaMigrations :: [(String, Query, Maybe Query)] schemaMigrations = [ ("20260915_badge_service_schema", m20260915_badge_service_schema, Just down_m20260915_badge_service_schema), ("20260918_badge_group_ops", m20260918_badge_group_ops, Just down_m20260918_badge_group_ops), - ("20260925_badge_store_receipts", m20260925_badge_store_receipts, Just down_m20260925_badge_store_receipts) + ("20260925_badge_store_receipts", m20260925_badge_store_receipts, Just down_m20260925_badge_store_receipts), + ("20261012_badge_subscriptions", m20261012_badge_subscriptions, Just down_m20261012_badge_subscriptions) ] -- | The client tables share this database, so the service tables are the same names behind a prefix. @@ -192,6 +193,66 @@ DROP INDEX @idx_payments_provider_ref; CREATE INDEX @idx_payments_provider_ref ON @payments(provider, provider_ref); |] +m20261012_badge_subscriptions :: Query +m20261012_badge_subscriptions = + withPrefix + servicePrefix + -- provider_token is a Play purchase token, a bearer secret: it is kept only for a subscription, which Play is asked about again. + [sql| +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, + plan_id TEXT NOT NULL, + period_start TEXT NOT NULL, + period_end TEXT NOT NULL, + amount INTEGER, + currency TEXT, + created_at TEXT NOT NULL, + UNIQUE(payment_id, provider_charge_ref) +) STRICT; + +ALTER TABLE @badge_ledger ADD COLUMN charge_id TEXT REFERENCES @subscription_charges; + +CREATE INDEX @idx_badge_ledger_charge ON @badge_ledger(charge_id); + +ALTER TABLE @payments ADD COLUMN subscription_state TEXT; + +ALTER TABLE @payments ADD COLUMN subscription_checked_at TEXT; + +ALTER TABLE @payments ADD COLUMN provider_token TEXT; + +ALTER TABLE @payments DROP COLUMN subscription_renews_at; + +ALTER TABLE @payments DROP COLUMN grace_until; + +ALTER TABLE @payments DROP COLUMN cancelled; +|] + +down_m20261012_badge_subscriptions :: Query +down_m20261012_badge_subscriptions = + withPrefix + servicePrefix + [sql| +ALTER TABLE @payments ADD COLUMN subscription_renews_at TEXT; + +ALTER TABLE @payments ADD COLUMN grace_until TEXT; + +ALTER TABLE @payments ADD COLUMN cancelled INTEGER NOT NULL DEFAULT 0; + +ALTER TABLE @payments DROP COLUMN provider_token; + +ALTER TABLE @payments DROP COLUMN subscription_checked_at; + +ALTER TABLE @payments DROP COLUMN subscription_state; + +DROP INDEX @idx_badge_ledger_charge; + +ALTER TABLE @badge_ledger DROP COLUMN charge_id; + +DROP TABLE @subscription_charges; +|] + {- TODO [badges] deferred with the draft in M20260915_user_badges, service only. ALTER TABLE @payments ADD COLUMN receipt_hash BLOB; diff --git a/src/Simplex/Chat/Badges/Ledger.hs b/src/Simplex/Chat/Badges/Ledger.hs index 870820d7c8..cf46287a60 100644 --- a/src/Simplex/Chat/Badges/Ledger.hs +++ b/src/Simplex/Chat/Badges/Ledger.hs @@ -205,15 +205,16 @@ debitTypeTag = \case SDLapse -> "lapse" SDUnknown {tag} -> tag --- | Rebuilds only what the columns determine: constructors with no fields, and a payment credit. +-- | Rebuilds only what the columns determine: constructors with no fields, a payment credit and a charge 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. -- 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, +-- TODO [badges] rebuild 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 +entryTypeFromColumns :: Maybe (Maybe InvoiceId) -> Maybe Text -> Text -> Maybe Text -> Maybe Text -> Maybe StatementEntryType +entryTypeFromColumns payment_ chargeId_ entryType credit_ debit_ = case (entryType, credit_, debit_) of ("credit", Just "payment", _) -> SECredit . SCPayment <$> payment_ + ("credit", Just "charge", _) -> SECredit . SCCharge <$> chargeId_ ("credit", Just t, _) -> SECredit <$> creditType t ("debit", _, Just t) -> SEDebit <$> debitType t _ -> Nothing diff --git a/src/Simplex/Chat/Badges/Service.hs b/src/Simplex/Chat/Badges/Service.hs index 80ee632c25..f72e4f4161 100644 --- a/src/Simplex/Chat/Badges/Service.hs +++ b/src/Simplex/Chat/Badges/Service.hs @@ -18,6 +18,7 @@ module Simplex.Chat.Badges.Service BadgeUpgrade (..), BadgeServiceResponse (..), BadgeServiceErrorCode (..), + SubscriptionState (..), BadgeCatalog (..), BadgePrice (..), BadgeOffer (..), @@ -42,6 +43,7 @@ import Simplex.Chat.Badges import Simplex.Chat.Badges.Types import Simplex.Chat.PaymentService import qualified Simplex.Messaging.Crypto as C +import Simplex.Messaging.Encoding.String (TextEncoding (..), textParseJSON, textToEncoding, textToJSON) import Simplex.Messaging.Parsers (defaultJSON, dropPrefix, taggedObjectJSON) import Simplex.Messaging.Version (VersionRange, VersionScope, mkVersionRange) import Simplex.Messaging.Version.Internal (Version (..)) @@ -121,7 +123,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, @@ -129,6 +132,15 @@ data BadgeServiceResponse retryAfter :: Maybe Word32 } +-- | 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) + data BadgeCatalog = BadgeCatalog { prices :: [BadgePrice], offers :: [BadgeOffer] @@ -236,6 +248,27 @@ instance ToJSON StatementDebitType where SDUnknown _ j -> JE.value $ J.Object j v -> $(JQ.mkToEncoding (taggedObjectJSON $ dropPrefix "SD") ''StatementDebitType) v +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" + $(JQ.deriveJSON (taggedObjectJSON $ dropPrefix "SE") ''StatementEntryType) $(JQ.deriveJSON defaultJSON ''StatementEntry) diff --git a/src/Simplex/Chat/Store/Badges.hs b/src/Simplex/Chat/Store/Badges.hs index 12a914d35f..9fe2fce145 100644 --- a/src/Simplex/Chat/Store/Badges.hs +++ b/src/Simplex/Chat/Store/Badges.hs @@ -551,7 +551,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 Nothing Nothing 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. diff --git a/src/Simplex/Chat/Store/Postgres/Migrations/M20260915_user_badges.hs b/src/Simplex/Chat/Store/Postgres/Migrations/M20260915_user_badges.hs index 20fc4fa99d..86ecaa8831 100644 --- a/src/Simplex/Chat/Store/Postgres/Migrations/M20260915_user_badges.hs +++ b/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 and @badge_ledger.charge_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,23 +185,17 @@ 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; @@ -222,7 +204,6 @@ 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 diff --git a/src/Simplex/Chat/Store/SQLite/Migrations/M20260915_user_badges.hs b/src/Simplex/Chat/Store/SQLite/Migrations/M20260915_user_badges.hs index 8646d8b29e..185c2fa189 100644 --- a/src/Simplex/Chat/Store/SQLite/Migrations/M20260915_user_badges.hs +++ b/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 and @badge_ledger.charge_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,23 +186,17 @@ 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; @@ -223,7 +205,6 @@ 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 diff --git a/tests/BadgeTests.hs b/tests/BadgeTests.hs index c2410e0423..6beb685968 100644 --- a/tests/BadgeTests.hs +++ b/tests/BadgeTests.hs @@ -104,6 +104,7 @@ badgeTests = do it "redeemBadgeCode request matches the schema" testRedeemRequestJSON it "purchaseBadge request matches the schema" testPurchaseRequestJSON it "badgeCredential response matches the schema" testCredentialResponseJSON + it "badgeCredential carries a subscription's state, and reads one it does not know as unknown" testCredentialSubscriptionJSON it "error response matches the schema" testErrorResponseJSON it "statement entries round-trip, unknown entry types verbatim" testStatementJSON describe "store purchases" $ do @@ -790,17 +791,19 @@ testEntryTypeColumns = do mapM_ (\c -> wireTag (J.toJSON (SECredit c)) "credit" `shouldBe` Just (creditTypeTag c)) credits mapM_ (\d -> wireTag (J.toJSON (SEDebit d)) "debit" `shouldBe` Just (debitTypeTag d)) debits -- the types this version writes survive a round trip through the columns, a payment credit - -- through the payment its row references + -- through the payment its row references, and a charge credit through its charge mapM_ - (\t -> uncurry3 (entryTypeFromColumns Nothing) (entryTypeColumns t) `shouldSatisfy` sameEntryType t) + (\t -> uncurry3 (entryTypeFromColumns Nothing Nothing) (entryTypeColumns t) `shouldSatisfy` sameEntryType t) [SECredit SCCode, SEDebit SDBadge, SEDebit SDLapse] let storeCredit = SECredit (SCPayment Nothing) invoiceCredit = SECredit (SCPayment (Just (InvoiceId "inv1"))) - uncurry3 (entryTypeFromColumns (Just Nothing)) (entryTypeColumns storeCredit) `shouldSatisfy` sameEntryType storeCredit - uncurry3 (entryTypeFromColumns (Just (Just (InvoiceId "inv1")))) (entryTypeColumns invoiceCredit) `shouldSatisfy` sameEntryType invoiceCredit + chargeCredit = SECredit (SCCharge "ch1") + uncurry3 (entryTypeFromColumns (Just Nothing) Nothing) (entryTypeColumns storeCredit) `shouldSatisfy` sameEntryType storeCredit + uncurry3 (entryTypeFromColumns (Just (Just (InvoiceId "inv1"))) Nothing) (entryTypeColumns invoiceCredit) `shouldSatisfy` sameEntryType invoiceCredit + uncurry3 (entryTypeFromColumns Nothing (Just "ch1")) (entryTypeColumns chargeCredit) `shouldSatisfy` sameEntryType chargeCredit -- a type that needs a reference column is not silently read back as something else - uncurry3 (entryTypeFromColumns Nothing) (entryTypeColumns storeCredit) `shouldSatisfy` isNothing - uncurry3 (entryTypeFromColumns Nothing) (entryTypeColumns (SECredit (SCCharge "ch1"))) `shouldSatisfy` isNothing + uncurry3 (entryTypeFromColumns Nothing Nothing) (entryTypeColumns storeCredit) `shouldSatisfy` isNothing + uncurry3 (entryTypeFromColumns Nothing Nothing) (entryTypeColumns chargeCredit) `shouldSatisfy` isNothing -- which is why every type is stored as its own JSON as well, and read from that first: the -- columns alone would answer a row naming an invoice or a purchase as no row at all mapM_ roundTrips credits @@ -939,7 +942,7 @@ testCredentialResponseJSON = do mk <- generateMasterKey drg let info = BadgeInfo {badgeType = BTSupporter, badgeExpiry = futureTime, badgeExtra = ""} Right cred <- issueBadge testKeyIdx sk (VerifiedBadgeRequest BadgeRequest {masterKey = mk, badgeInfo = info}) - let resp = BSPBadgeCredential {credential = Just cred, receipt = Nothing, statement = BadgeStatement {entries = [], previousEntryId = Nothing}} + let resp = BSPBadgeCredential {credential = Just cred, receipt = Nothing, statement = BadgeStatement {entries = [], previousEntryId = Nothing}, subscription = Nothing} J.toJSON resp `shouldBe` J.object [ "type" J..= ("badgeCredential" :: T.Text), @@ -948,6 +951,24 @@ testCredentialResponseJSON = do ] roundTrips resp +testCredentialSubscriptionJSON :: IO () +testCredentialSubscriptionJSON = do + let states = [(SSRenewing, "renewing"), (SSCancelled, "cancelled"), (SSBillingRetry, "billingRetry"), (SSEnded, "ended")] + mapM_ (\(s, t) -> (J.toJSON s, J.fromJSON (J.String t)) `shouldBe` (J.String t, J.Success s)) states + let response subscription_ = J.object $ ["type" J..= ("badgeCredential" :: T.Text), "statement" J..= J.object ["entries" J..= ([] :: [J.Value])]] <> maybe [] (\s -> ["subscription" J..= (s :: T.Text)]) subscription_ + subscriptionOf v = case J.fromJSON v of + J.Success BSPBadgeCredential {subscription} -> Right subscription + J.Success _ -> Left "not a badgeCredential" + J.Error e -> Left e + subscriptionOf (response Nothing) `shouldBe` Right Nothing + subscriptionOf (response (Just "billingRetry")) `shouldBe` Right (Just SSBillingRetry) + -- a state added by a newer service does not fail the response, and is not read as ended + subscriptionOf (response (Just "paused")) `shouldBe` Right (Just (SSUnknown "paused")) + J.toJSON (SSUnknown "paused") `shouldBe` J.String "paused" + let resp = BSPBadgeCredential {credential = Nothing, receipt = Nothing, statement = BadgeStatement {entries = [], previousEntryId = Nothing}, subscription = Just SSRenewing} + J.toJSON resp `shouldBe` response (Just "renewing") + roundTrips resp + testErrorResponseJSON :: IO () testErrorResponseJSON = do let resp = BSPError {code = BSECodeInvalid, message = Nothing, retryAfter = Nothing} diff --git a/tests/Bots/BadgeService/WebTests.hs b/tests/Bots/BadgeService/WebTests.hs index 65c5cc3017..5599b9ff6c 100644 --- a/tests/Bots/BadgeService/WebTests.hs +++ b/tests/Bots/BadgeService/WebTests.hs @@ -14,7 +14,7 @@ import BadgeService.Poller import BadgeService.Providers import BadgeService.Providers.BTCPay (btcpayProvider, listPageSize, maxListPages) import BadgeService.Providers.Stripe (stripeProvider) -import BadgeService.Store (KeyPurchase (..), KeyRedemption (..), ManagedGroup (..), NewCodePurchase (..), RevokeResult (..), createCodePurchase, getCodePurchaseForKey, getManagedGroup, insertBadgeCode, insertManagedGroup, markOwnerBootstrapped, revokeCode) +import BadgeService.Store (KeyPurchase (..), KeyRedemption (..), ManagedGroup (..), NewCodePurchase (..), NewStorePurchase (..), RevokeResult (..), appendLedgerPlan, createCodePurchase, createStorePurchase, getCodePurchaseForKey, getLedgerEntries, getLedgerTip, getManagedGroup, insertBadgeCode, insertManagedGroup, markOwnerBootstrapped, revokeCode) import BadgeService.Store.Invoices import BadgeService.Waiters (awaitStatus, newWaiters, publish, waitingCount) import BadgeService.Web.Server @@ -59,7 +59,8 @@ import Network.HTTP.Types (Header, HeaderName, hCacheControl, hContentType) import Network.HTTP.Types.Status (statusCode) import qualified Network.Wai.Handler.Warp as Warp import Simplex.Chat.Badges (BadgeCredential (..), BadgeInfo (..), BadgeMasterKey (..), BadgeType (..)) -import Simplex.Chat.Badges.Service (BadgeOffer (..), BadgePrice (..)) +import Simplex.Chat.Badges.Ledger (addMonths, emptyEntry, grantEntry) +import Simplex.Chat.Badges.Service (BadgeOffer (..), BadgePrice (..), StatementCreditType (..)) import Simplex.Chat.Badges.Types (BadgeCodePaymentStatus (..), BadgeItemStatus (..), BadgeOfferId (..), BadgePriceId (..), OfferDiscount (..)) import Simplex.Chat.PaymentService.Types (CryptoCurrency (..), CurrencyAmount (..), InvoiceId (..), InvoiceStatus (..), PaymentProvider (..), PaymentStatus (..), ServicePaymentDestination (..), ServicePaymentMethod (..)) import Simplex.Messaging.Agent.Store.Common (DBStore (..), withConnection, withTransaction) @@ -137,12 +138,13 @@ columnsOf st table = withConnection st $ \db -> badgeWebTests :: Spec badgeWebTests = do describe "badge service schema" $ do - it "carries the five service-only columns" testServiceColumns + it "carries the service-only columns, and none of the subscription columns it never wrote" testServiceColumns it "refuses a duplicate provider_ref" testProviderRefUnique it "M20260918 adds the multi-use columns and the group table" testGroupOpsColumns it "M20260918 defaults a fresh code to one use with none spent" testGroupOpsRedeemCounts it "migrates all the way down and up again" testSchemaDownUpCycle it "rolls back only the group migration and re-applies it, keeping a code redeemed twice spent" testGroupOpsDownUp + it "rolls back only the subscription migration, restoring the columns it dropped, and re-applies it" testSubscriptionsDownUp describe "badge service store" $ do it "writes the invoice, its code and their link atomically" testCreationIsAtomic it "newInvoiceId is 128 CSPRNG bits, base64url, and two calls differ" testNewInvoiceIdRandom @@ -155,6 +157,7 @@ badgeWebTests = do it "a revoked code cannot be redeemed, and a redeemed code cannot be revoked" testRevokeAndRedeemExcludeEachOther it "a multi-use code can be revoked while it has uses left, and not once they are gone" testRevokeMultiUseCode it "every timestamp round-trips to the second" testTimestampRoundTrip + it "stores a charge credit with its charge, and reads it back at the tip and in the statement" testChargeCreditRoundTrip describe "managed group" $ do it "round-trips and bootstraps once" testManagedGroupRoundTripsAndBootstrapsOnce it "refuses a second row and burns the flag per group" testManagedGroupIsSingleRow @@ -318,6 +321,16 @@ testServiceColumns = withServiceStore $ \st -> do columnsOf st "sx_badge_service_payments" >>= (`shouldSatisfy` elem "crypto_paid") columnsOf st "sx_badge_service_badge_codes" >>= (`shouldSatisfy` \cs -> all (`elem` cs) ["expires_at", "revoked_at"]) + assertSubscriptionColumns st + +assertSubscriptionColumns :: HasCallStack => DBStore -> IO () +assertSubscriptionColumns st = do + columnsOf st "sx_badge_service_subscription_charges" + >>= (`shouldSatisfy` \cs -> all (`elem` cs) ["charge_id", "payment_id", "provider_charge_ref", "plan_id", "period_start", "period_end", "amount", "currency", "created_at"]) + columnsOf st "sx_badge_service_badge_ledger" >>= (`shouldSatisfy` elem "charge_id") + payments <- columnsOf st "sx_badge_service_payments" + payments `shouldSatisfy` \cs -> all (`elem` cs) ["subscription_state", "subscription_checked_at", "provider_token"] + payments `shouldSatisfy` \cs -> not (any (`elem` cs) ["subscription_renews_at", "grace_until", "cancelled"]) testGroupOpsColumns :: IO () testGroupOpsColumns = withServiceStore assertGroupOpsColumns @@ -343,8 +356,23 @@ testSchemaDownUpCycle = withServiceStore $ \st -> do runMigrations st $ MTRDown downMigrations columnsOf st "sx_badge_service_badge_codes" `shouldReturn` [] columnsOf st "sx_badge_service_group" `shouldReturn` [] + columnsOf st "sx_badge_service_subscription_charges" `shouldReturn` [] runMigrations st $ MTRUp badgeServiceSchemaMigrations assertGroupOpsColumns st + assertSubscriptionColumns st + +testSubscriptionsDownUp :: IO () +testSubscriptionsDownUp = withServiceStore $ \st -> do + let subscriptions = [m | m@Migration {name = "20261012_badge_subscriptions"} <- badgeServiceSchemaMigrations] + length subscriptions `shouldBe` 1 + runMigrations st $ MTRDown (mapMaybe toDownMigration subscriptions) + columnsOf st "sx_badge_service_subscription_charges" `shouldReturn` [] + columnsOf st "sx_badge_service_badge_ledger" >>= (`shouldNotSatisfy` elem "charge_id") + payments <- columnsOf st "sx_badge_service_payments" + payments `shouldSatisfy` \cs -> all (`elem` cs) ["subscription_renews_at", "grace_until", "cancelled"] + payments `shouldSatisfy` \cs -> not (any (`elem` cs) ["subscription_state", "subscription_checked_at", "provider_token"]) + runMigrations st $ MTRUp subscriptions + assertSubscriptionColumns st testGroupOpsDownUp :: IO () testGroupOpsDownUp = withServiceStore $ \st -> do @@ -696,6 +724,22 @@ testTimestampRoundTrip = withServiceStore $ \st -> do irExpiresAt row `shouldBe` truncated irCreatedAt row `shouldBe` truncated +testChargeCreditRoundTrip :: IO () +testChargeCreditRoundTrip = withServiceStore $ \st -> do + now <- truncateToSecond <$> getCurrentTime + (purchaseKey, masterKey) <- newPurchaseKeys + Just purchaseId <- withTransaction st $ \db -> + createStorePurchase db NewStorePurchase {paymentId = "pay1", provider = PPApple, providerRef = "2000000812345671", paid = Nothing, purchaseKey, masterKey, badgeType = BTSupporter} now + withConnection st $ \db -> + DB.execute + db + "INSERT INTO sx_badge_service_subscription_charges (charge_id, payment_id, provider_charge_ref, plan_id, period_start, period_end, created_at) VALUES (?,?,?,?,?,?,?)" + ("ch1" :: Text, "pay1" :: Text, "2000000812345672" :: Text, "SUBSCR_BADGE_SUPPORTER_MONTH_01" :: Text, now, addMonths 1 now, now) + let charge = grantEntry now "e1" 1 (SCCharge "ch1") (emptyEntry now BTSupporter) + withTransaction st $ \db -> appendLedgerPlan db purchaseId Nothing [charge] Nothing + withTransaction st (\db -> getLedgerEntries db purchaseId 0) >>= (`shouldBe` Just [J.toJSON charge]) . fmap (map J.toJSON) + withTransaction st (`getLedgerTip` purchaseId) >>= (`shouldBe` Just (J.toJSON charge)) . fmap J.toJSON + testManagedGroupRoundTripsAndBootstrapsOnce :: IO () testManagedGroupRoundTripsAndBootstrapsOnce = withServiceStore $ \st -> do now <- truncateToSecond <$> getCurrentTime