From 655e933c562fda7ddf35d556592854c7b5b7821d Mon Sep 17 00:00:00 2001 From: shum Date: Thu, 27 Aug 2026 00:22:26 +0000 Subject: [PATCH] core, tests: web order, invoice and provider event store --- .../src/BadgeService/Store.hs | 480 +++++++++++++++++- .../2026-08-21-badges-web-checkout.md | 16 +- src/Simplex/Chat/PaymentService/Types.hs | 29 ++ src/Simplex/Chat/Store/Badges.hs | 11 +- tests/Bots/BadgeServiceTests.hs | 240 ++++++++- 5 files changed, 738 insertions(+), 38 deletions(-) diff --git a/apps/simplex-badge-service/src/BadgeService/Store.hs b/apps/simplex-badge-service/src/BadgeService/Store.hs index 3f56342a9a..778cbec068 100644 --- a/apps/simplex-badge-service/src/BadgeService/Store.hs +++ b/apps/simplex-badge-service/src/BadgeService/Store.hs @@ -6,23 +6,40 @@ {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TypeOperators #-} --- | Queries over the badge service's own tables: purchases, payments, the ledger, issuances, --- redemption codes and the price catalog. Structured after --- "Directory.Store"\/"Directory.Store.Migrate": every function here takes a 'DB.Connection' --- and opens no transaction of its own; 'withServiceTransaction' is the only place a --- transaction is opened, which is what lets a later step compose a purchase row, a payment --- row, several ledger entries, an issuance and a code redemption into one atomic transaction. +-- | Queries over the badge service's own tables: web orders, invoices, provider events, +-- purchases and payments, the ledger, issuances, redemption codes and the price catalog. +-- Structured after "Directory.Store"\/"Directory.Store.Migrate": every function here takes a +-- 'DB.Connection' and opens no transaction of its own; 'withServiceTransaction' is the only +-- place a transaction is opened, which is what lets a caller compose a purchase row, a payment +-- row, several ledger entries, an issuance and a code redemption into one atomic transaction -- +-- or, on the web side, an order, its invoice, a provider event and a code row. -- --- The order, invoice and provider-event functions belong to D0. This module owns everything --- the RPC path needs on top of that: purchases and payments, the ledger, issuances, codes --- and the catalog. There is no store function that resolves an order to a code or a purchase --- -- that join does not exist in the schema (docs/protocol/badges-web.md §3 Linkage); a --- caller that needs it derives the code from the order id and looks it up by hash with --- 'getCodeByHash'. +-- The RPC path (B1) and the web-checkout path (D0) share this module and share nothing else: +-- there is no store function that resolves an order to a code or a purchase -- that join does +-- not exist in the schema (docs\/protocol\/badges-web.md §3 Linkage); a caller that needs it +-- derives the code from the order id and looks it up by hash with 'getCodeByHash'. module BadgeService.Store ( ServiceError (..), withServiceTransaction, + -- * Web orders and their invoices + OrderMethod (..), + WebOrderStatus (..), + NewWebOrder (..), + WebOrder (..), + createOrder, + getOrder, + getOrderByProviderRef, + getOrderByShortRef, + getStuckOrders, + updateOrderStatus, + setOrderProviderRef, + setOrderSettled, + + -- * Provider events + recordProviderEvent, + markProviderEventProcessed, + -- * Purchases and payments BadgePurchaseRow (..), getPurchaseByKey, @@ -88,18 +105,23 @@ import Simplex.Chat.Badges.Types LedgerEntryType (..), OfferDiscount (..), ) -import Simplex.Chat.PaymentService.Types (CurrencyAmount (..), PaymentStatus (..)) +import Simplex.Chat.PaymentService.Types (CurrencyAmount (..), InvoiceStatus (..), PaymentProvider (..), PaymentStatus (..)) import Simplex.Messaging.Agent.Store.Common (DBStore, withTransaction) -import Simplex.Messaging.Agent.Store.DB (Binary (..)) +import Simplex.Messaging.Agent.Store.DB (Binary (..), fromTextField_) import qualified Simplex.Messaging.Agent.Store.DB as DB import qualified Simplex.Messaging.Crypto as C +import Simplex.Messaging.Encoding.String (TextEncoding (..)) import Simplex.Messaging.Util (tshow) #if defined(dbPostgres) -import Database.PostgreSQL.Simple (Only (..), Query, (:.) (..)) +import Database.PostgreSQL.Simple (Only (..), Query, ToRow, (:.) (..)) +import Database.PostgreSQL.Simple.FromField (FromField (..)) import Database.PostgreSQL.Simple.SqlQQ (sql) +import Database.PostgreSQL.Simple.ToField (ToField (..)) #else -import Database.SQLite.Simple (Only (..), Query, (:.) (..)) +import Database.SQLite.Simple (Only (..), Query, ToRow, (:.) (..)) +import Database.SQLite.Simple.FromField (FromField (..)) import Database.SQLite.Simple.QQ (sql) +import Database.SQLite.Simple.ToField (ToField (..)) #endif -- | The error type of every store function: not-found (a lookup targeted by a mutation @@ -110,6 +132,12 @@ data ServiceError | SECodeNotFound | SEPriceNotFound | SEOfferNotFound + | SEOrderNotFound + | -- | 'markProviderEventProcessed' only: no @provider_events@ row for that + -- @(provider, event_id)@. Its caller reaches it through a 'recordProviderEvent' that + -- returned 'True' in the same transaction, so the row is always there; a 'Left' here means + -- the two calls disagreed about the key, which must not pass silently. + SEProviderEventNotFound | -- | 'attachPurchasePayment' only: the purchase already has a payment attached. SEPaymentConflict | -- | 'markCodeRedeemed' only: the code was already claimed by another redemption, so this one @@ -141,6 +169,418 @@ withServiceTransaction st action = Left e -> E.throwIO (ServiceRollback e) Right a -> pure a +-- Web orders and their invoices ---------------------------------------------- + +-- | @web_orders.method@ (A3: @CHECK (method IN ('card','btc','xmr'))@). It is the single source +-- for everything the payment method decides: the invoice's provider below, and E4's +-- @cryptoCurrency@, which is derived from it rather than read from +-- @invoices.payment_crypto_currency@ -- that column exists and is deliberately left NULL (A3). +-- +-- It lives here rather than in D6's @Orders.hs@, which the plan first named as its home, only +-- because D0 has to persist a method before that module exists; D6 imports it (plan §9). +data OrderMethod = OMCard | OMBtc | OMXmr + deriving (Eq, Show) + +instance TextEncoding OrderMethod where + textEncode = \case + OMCard -> "card" + OMBtc -> "btc" + OMXmr -> "xmr" + textDecode = \case + "card" -> Just OMCard + "btc" -> Just OMBtc + "xmr" -> Just OMXmr + _ -> Nothing + +instance ToField OrderMethod where toField = toField . textEncode + +instance FromField OrderMethod where fromField = fromTextField_ textDecode + +-- | @web_orders.status@ (A3: @CHECK (status IN ('invoiced','pending','paid','expired','failed'))@), +-- authoritative for the order lifecycle and what E3, E4 and H3 read. @invoices.status@ is +-- maintained in step with it, in the same transaction, by 'updateOrderStatus' and +-- 'setOrderSettled', and is read by nothing in this plan. +-- +-- Distinct from 'InvoiceStatus', the shared @invoices@ vocabulary: an order tracks five states +-- because E3 and E5 have to tell an underpaid expiry from a provider failure, where an invoice +-- has only the three the payment model defines. 'orderInvoiceStatus' is the one place the two +-- meet, and it projects the five onto the three. +data WebOrderStatus = WOSInvoiced | WOSPending | WOSPaid | WOSExpired | WOSFailed + deriving (Eq, Show) + +instance TextEncoding WebOrderStatus where + textEncode = \case + WOSInvoiced -> "invoiced" + WOSPending -> "pending" + WOSPaid -> "paid" + WOSExpired -> "expired" + WOSFailed -> "failed" + textDecode = \case + "invoiced" -> Just WOSInvoiced + "pending" -> Just WOSPending + "paid" -> Just WOSPaid + "expired" -> Just WOSExpired + "failed" -> Just WOSFailed + _ -> Nothing + +instance ToField WebOrderStatus where toField = toField . textEncode + +instance FromField WebOrderStatus where fromField = fromTextField_ textDecode + +-- | The @invoices.status@ that goes with each order status, so the two columns cannot drift +-- (A3's invariant). A projection, not a bijection: an invoice is 'ISOpen' while the order is +-- either invoiced or partly paid, and 'ISExpired' whether the order ran out of time or the +-- provider failed it. Nothing reads it back (A3), and @web_orders.status@ keeps the distinctions +-- this drops. +orderInvoiceStatus :: WebOrderStatus -> InvoiceStatus +orderInvoiceStatus = \case + WOSInvoiced -> ISOpen + WOSPending -> ISOpen + WOSPaid -> ISPaid + WOSExpired -> ISExpired + WOSFailed -> ISExpired + +-- | The @invoices.provider@ of an order, derived from its method rather than passed in: the +-- card methods go to Stripe (F1) and both crypto methods to the same BTCPay instance (E2), so +-- a caller could only ever get this wrong. +orderInvoiceProvider :: OrderMethod -> PaymentProvider +orderInvoiceProvider = \case + OMCard -> PPStripe + OMBtc -> PPCrypto + OMXmr -> PPCrypto + +-- | Both rows 'createOrder' writes, as one record: D6 fills a named structure rather than a +-- fifteen-argument call, and the field names read as the columns do. The order's own columns +-- come first, then the @invoices@ ones. +-- +-- @status@ is not a field: a new order is always @invoiced@ and its invoice always @invoiced@ +-- with it, so there is no representable state where a row is created already paid or expired. +-- Nor are @amount_paid@ and @settled_at@, which only 'updateOrderStatus' and 'setOrderSettled' +-- ever write. +data NewWebOrder = NewWebOrder + { -- | 128 random bits, base64url (D6). A bearer capability for the code (§3 Linkage, + -- decision 9), so it must not be sequential or derived from anything guessable. + orderId :: Text, + -- | The @invoices@ row this call writes; minted by D6, not here, because the store opens no + -- transaction and mints no identifiers. + invoiceId :: Text, + -- | The provider's invoice \/ session \/ payment-intent id. 'Nothing' only for a caller that + -- has not made the provider call yet; D6 always has it by the time it writes, and + -- 'setOrderProviderRef' can replace it later. + providerRef :: Maybe Text, + method :: OrderMethod, + -- | 5 Crockford characters (D6), unique per order: the reference support resolves by (H2), + -- shown on card statements (F1) and on the crypto payment and result screens (E5, E6). + shortRef :: Text, + badgeType :: BadgeType, + priceId :: Maybe BadgePriceId, + offerId :: Maybe BadgeOfferId, + months :: Word8, + -- | The charged total from A4's 'BadgeService.Catalog.offerTotal', in minor units of + -- @currency@. Written to @invoices.price@ and @invoices.amount@ alike, with + -- @discount_amount@ and @credit_amount@ left NULL: an offer's discount is expressed as free + -- months, so the total IS the price, and a web order has no credit to apply. + amount :: CurrencyAmount, + currency :: Text, + -- | Card only: the provider's hosted checkout URL (F1). + payUrl :: Maybe Text, + -- | Crypto only: the address and the amount in the crypto currency, both from E2's + -- @getPaymentMethods@, so E4 serves them from the database and never re-reads the provider. + paymentAddress :: Maybe Text, + cryptoAmount :: Maybe Text, + expiresAt :: UTCTime + } + +-- | An order joined to its @invoices@ row, which is how every read here returns one: a single +-- call yields the amount, the currency, the address, the crypto amount, the payment URL and the +-- expiry that E4's response needs. E4's @code@ and @disclosureExpiresAt@ do NOT come from here +-- -- they come from 'getCodeByHash' on the code derived from 'orderId' (§3 Linkage). +data WebOrder = WebOrder + { orderId :: Text, + invoiceId :: Text, + providerRef :: Maybe Text, + method :: OrderMethod, + shortRef :: Text, + badgeType :: BadgeType, + priceId :: Maybe BadgePriceId, + offerId :: Maybe BadgeOfferId, + months :: Word8, + status :: WebOrderStatus, + -- | Amount received so far, in minor units of the invoice currency at the rate the provider + -- locked -- never in crypto. A partial payment records it while the order stays @pending@. + amountPaid :: Maybe CurrencyAmount, + settledAt :: Maybe UTCTime, + createdAt :: UTCTime, + updatedAt :: UTCTime, + -- from the @invoices@ row + amount :: CurrencyAmount, + currency :: Text, + payUrl :: Maybe Text, + paymentAddress :: Maybe Text, + cryptoAmount :: Maybe Text, + expiresAt :: UTCTime + } + deriving (Show) + +type OrderRow = (Text, Text, Maybe Text, OrderMethod, Text, BadgeType, Maybe Text, Maybe Text, Int, WebOrderStatus) + +type OrderInvoiceRow = (Maybe Int64, Maybe UTCTime, UTCTime, UTCTime, Int64, Text, Maybe Text, Maybe Text, Maybe Text, UTCTime) + +-- | @months@ and both amounts are read as signed integers and converted: see 'word8FromInt' and +-- 'word32FromInt64'. +rowToOrder :: (OrderRow :. OrderInvoiceRow) -> Either ServiceError WebOrder +rowToOrder + ( (orderId, invoiceId, providerRef, method, shortRef, badgeType, priceId, offerId, monthsInt, status) + :. (amountPaidInt, settledAt, createdAt, updatedAt, amountInt, currency, payUrl, paymentAddress, cryptoAmount, expiresAt) + ) = do + months <- word8FromInt ("order " <> orderId <> " months") monthsInt + amount <- CurrencyAmount <$> word32FromInt64 ("order " <> orderId <> " amount") amountInt + amountPaid <- mapM (fmap CurrencyAmount . word32FromInt64 ("order " <> orderId <> " amount_paid")) amountPaidInt + Right + WebOrder + { orderId, + invoiceId, + providerRef, + method, + shortRef, + badgeType, + priceId = BadgePriceId <$> priceId, + offerId = BadgeOfferId <$> offerId, + months, + status, + amountPaid, + settledAt, + createdAt, + updatedAt, + amount, + currency, + payUrl, + paymentAddress, + cryptoAmount, + expiresAt + } + +-- | The join every order read uses. It is an INNER join: 'createOrder' is the only writer of a +-- @web_orders@ row and always writes the invoice with it, so an order without one does not +-- exist, and 'WebOrder' can hold the invoice's NOT NULL columns unwrapped. +orderSelect :: Query +orderSelect = + [sql| + SELECT o.order_id, o.invoice_id, o.provider_ref, o.method, o.short_ref, o.badge_type, o.price_id, o.offer_id, o.months, o.status, + o.amount_paid, o.settled_at, o.created_at, o.updated_at, + i.amount, i.currency, i.payment_url, i.payment_address, i.payment_crypto_amount, i.expires_at + FROM sx_badge_service_web_orders o + JOIN sx_badge_service_invoices i ON i.invoice_id = o.invoice_id + |] + +-- | Writes the @invoices@ row and the @web_orders@ row that references it, in that order (the +-- foreign key points that way). Both start @invoiced@. The caller supplies the transaction, as +-- everywhere else here, so a failed provider call after a partial write leaves neither row. +-- +-- @invoices.payment_crypto_currency@ is deliberately not written: 'method' is the single source +-- and E4 derives the currency from it (A3). +createOrder :: DB.Connection -> NewWebOrder -> UTCTime -> ExceptT ServiceError IO () +createOrder db newOrder now = do + let NewWebOrder {orderId, invoiceId, providerRef, method, shortRef, badgeType, priceId, offerId, months} = newOrder + NewWebOrder {amount = CurrencyAmount amount, currency, payUrl, paymentAddress, cryptoAmount, expiresAt} = newOrder + liftIO $ + DB.execute + db + [sql| + INSERT INTO sx_badge_service_invoices + (invoice_id, provider, price, amount, currency, payment_url, payment_address, payment_crypto_amount, expires_at, status, created_at, updated_at) + VALUES (?,?,?,?,?,?,?,?,?,?,?,?) + |] + ( (invoiceId, orderInvoiceProvider method, amount, amount, currency, payUrl) + :. (paymentAddress, cryptoAmount, expiresAt, orderInvoiceStatus WOSInvoiced, now, now) + ) + liftIO $ + DB.execute + db + [sql| + INSERT INTO sx_badge_service_web_orders + (order_id, invoice_id, provider_ref, method, short_ref, badge_type, price_id, offer_id, months, status, created_at, updated_at) + VALUES (?,?,?,?,?,?,?,?,?,?,?,?) + |] + ( (orderId, invoiceId, providerRef, method, shortRef, badgeType) + :. (unPriceId <$> priceId, unOfferId <$> offerId, months, WOSInvoiced, now, now) + ) + where + unPriceId (BadgePriceId pid) = pid + unOfferId (BadgeOfferId oid) = oid + +getOrder :: DB.Connection -> Text -> ExceptT ServiceError IO (Maybe WebOrder) +getOrder db orderId = queryOneOrder db (orderSelect <> " WHERE o.order_id = ?") (Only orderId) + +-- | At most one row: A3's @idx_web_orders_provider_ref@ is UNIQUE, so a provider reference that +-- resolved to two orders could not have been stored. F2 resolves a Stripe charge this way, and +-- H3 re-reads provider state through it. +getOrderByProviderRef :: DB.Connection -> Text -> ExceptT ServiceError IO (Maybe WebOrder) +getOrderByProviderRef db providerRef = queryOneOrder db (orderSelect <> " WHERE o.provider_ref = ?") (Only providerRef) + +-- | At most one row, on A3's UNIQUE @idx_web_orders_short_ref@. This is what support resolves a +-- bank-statement reference with (H2's @--ref@ subcommands). +getOrderByShortRef :: DB.Connection -> Text -> ExceptT ServiceError IO (Maybe WebOrder) +getOrderByShortRef db shortRef = queryOneOrder db (orderSelect <> " WHERE o.short_ref = ?") (Only shortRef) + +queryOneOrder :: ToRow q => DB.Connection -> Query -> q -> ExceptT ServiceError IO (Maybe WebOrder) +queryOneOrder db q params = do + rows <- liftIO $ DB.query db q params + case rows of + [] -> pure Nothing + (row : _) -> Just <$> liftEither (rowToOrder row) + +-- | Orders still open (@invoiced@ or @pending@) whose invoice expiry has passed, oldest expiry +-- first. H3's reconciliation pass reads it and re-reads each one's provider state: a missed +-- webhook is normal, so a stuck order is a routine outcome rather than an error. +-- +-- The status filter is exactly the plan's two: a @paid@ order is never stuck however long ago +-- its invoice expired, and @expired@ and @failed@ are left out too, even though E3 can still +-- move either to @paid@ on a late webhook. So an order that a webhook already marked @expired@ +-- and that then settles on chain with THAT webhook missed is not recovered by H3's pass; it is +-- recovered by support (H2). Widening the filter to all four is a change to H3's contract, not +-- to this query. +getStuckOrders :: DB.Connection -> UTCTime -> ExceptT ServiceError IO [WebOrder] +getStuckOrders db now = do + rows <- + liftIO $ + DB.query + db + (orderSelect <> " WHERE o.status IN (?,?) AND i.expires_at < ? ORDER BY i.expires_at ASC, o.order_id ASC") + (WOSInvoiced, WOSPending, now) + liftEither $ mapM rowToOrder rows + +-- | The new order status and, optionally, the amount received so far -- so a partial payment or +-- an underpaid expiry records what arrived without settling the order (E3). @settled_at@ is not +-- touched: only 'setOrderSettled' writes it, and only together with @paid@. +-- +-- @Nothing@ leaves a previously recorded @amount_paid@ alone rather than clearing it: an order +-- moving from @pending@ to @expired@ underpaid must keep the amount E5 renders. The matching +-- @invoices.status@ is written in the same statement pair, keeping A3's invariant. +updateOrderStatus :: DB.Connection -> Text -> WebOrderStatus -> Maybe CurrencyAmount -> UTCTime -> ExceptT ServiceError IO () +updateOrderStatus db orderId status amountPaid now = do + updated <- case amountPaid of + Nothing -> + liftIO $ + DB.query + db + "UPDATE sx_badge_service_web_orders SET status = ?, updated_at = ? WHERE order_id = ? RETURNING order_id" + (status, now, orderId) + Just (CurrencyAmount paid) -> + liftIO $ + DB.query + db + "UPDATE sx_badge_service_web_orders SET status = ?, amount_paid = ?, updated_at = ? WHERE order_id = ? RETURNING order_id" + (status, paid, now, orderId) + when (null (updated :: [Only Text])) $ throwError SEOrderNotFound + setOrderInvoiceStatus db orderId status now + +-- | Points the order at a provider invoice \/ session \/ payment-intent id, replacing whatever +-- was there: F3 learns a Stripe payment intent only after the checkout session completes, so +-- the reference an order was created with is not always its final one. A3's UNIQUE index makes +-- a value that already belongs to another order fail loudly rather than resolve a charge to the +-- wrong order. +setOrderProviderRef :: DB.Connection -> Text -> Text -> UTCTime -> ExceptT ServiceError IO () +setOrderProviderRef db orderId providerRef now = do + updated <- + liftIO $ + DB.query + db + "UPDATE sx_badge_service_web_orders SET provider_ref = ?, updated_at = ? WHERE order_id = ? RETURNING order_id" + (providerRef, now, orderId) + when (null (updated :: [Only Text])) $ throwError SEOrderNotFound + +-- | Settlement's single writer: @settled_at@, @amount_paid@ and @status = 'paid'@ go in one +-- statement, so no reader can ever see a paid order without its amount or its time, and +-- @invoices.status@ moves to @settled@ with them. E3, H3 and F2 all settle through it. +-- +-- It does not guard on the current status. Settlement is idempotent and monotonic toward @paid@ +-- (E3), but that is the caller's rule to apply -- it decides whether a second @InvoiceSettled@ +-- is a replay before it gets here, because it must also decide whether to write a code row. +setOrderSettled :: DB.Connection -> Text -> CurrencyAmount -> UTCTime -> ExceptT ServiceError IO () +setOrderSettled db orderId (CurrencyAmount amountPaid) settledAt = do + updated <- + liftIO $ + DB.query + db + [sql| + UPDATE sx_badge_service_web_orders + SET status = ?, amount_paid = ?, settled_at = ?, updated_at = ? + WHERE order_id = ? + RETURNING order_id + |] + (WOSPaid, amountPaid, settledAt, settledAt, orderId) + when (null (updated :: [Only Text])) $ throwError SEOrderNotFound + setOrderInvoiceStatus db orderId WOSPaid settledAt + +-- | The @invoices.status@ half of A3's invariant, written through the order's own @invoice_id@ +-- so no caller has to carry it. +setOrderInvoiceStatus :: DB.Connection -> Text -> WebOrderStatus -> UTCTime -> ExceptT ServiceError IO () +setOrderInvoiceStatus db orderId status now = + liftIO $ + DB.execute + db + [sql| + UPDATE sx_badge_service_invoices + SET status = ?, updated_at = ? + WHERE invoice_id IN (SELECT invoice_id FROM sx_badge_service_web_orders WHERE order_id = ?) + |] + (orderInvoiceStatus status, now, orderId) + +-- Provider events --------------------------------------------------------------- + +-- | Records the arrival of a provider webhook event and answers whether it should be processed. +-- +-- 'False' means, and only means, that this event has already been processed: a row exists AND +-- its @processed_at@ is set. A row whose @processed_at@ is NULL is one whose previous attempt +-- did not complete -- the process died between recording the event and finishing the settlement +-- transaction -- so this returns 'True' and the event is processed again (E3). Treating that row +-- as a duplicate would strand a paid order forever, which is the failure this whole table +-- exists to prevent. +-- +-- The insert is @ON CONFLICT DO NOTHING@ against A3's @(provider, event_id)@ primary key rather +-- than a read followed by a write, so two deliveries of the same event racing in separate +-- transactions cannot both insert. +recordProviderEvent :: DB.Connection -> PaymentProvider -> Text -> UTCTime -> ExceptT ServiceError IO Bool +recordProviderEvent db provider eventId now = do + inserted <- + liftIO $ + DB.query + db + [sql| + INSERT INTO sx_badge_service_provider_events (provider, event_id, received_at) + VALUES (?,?,?) + ON CONFLICT (provider, event_id) DO NOTHING + RETURNING event_id + |] + (provider, eventId, now) + case (inserted :: [Only Text]) of + (_ : _) -> pure True -- first delivery + [] -> do + -- the row was already there; @received_at@ keeps the first delivery's time + rows <- + liftIO $ + DB.query + db + "SELECT processed_at FROM sx_badge_service_provider_events WHERE provider = ? AND event_id = ?" + (provider, eventId) + pure $ case rows :: [Only (Maybe UTCTime)] of + (Only (Just _) : _) -> False -- processed already: a replay + _ -> True -- recorded but never processed: the previous attempt did not complete + +-- | Closes the event out, inside the settlement transaction that processed it -- so a crash +-- anywhere before the commit leaves @processed_at@ NULL and 'recordProviderEvent' hands the +-- event back on the provider's next delivery. +markProviderEventProcessed :: DB.Connection -> PaymentProvider -> Text -> UTCTime -> ExceptT ServiceError IO () +markProviderEventProcessed db provider eventId now = do + updated <- + liftIO $ + DB.query + db + "UPDATE sx_badge_service_provider_events SET processed_at = ? WHERE provider = ? AND event_id = ? RETURNING event_id" + (now, provider, eventId) + when (null (updated :: [Only Text])) $ throwError SEProviderEventNotFound + -- Purchases and payments ----------------------------------------------------- -- | The service's own projection of a @badge_purchases@ row. The single shared purchase record @@ -212,12 +652,6 @@ createPurchase db purchaseKey masterKey@(BadgeMasterKey mk) badgeType now = do updatedAt = now } --- | The service's DB has no 'Simplex.Chat.PaymentService.Types.PaymentProvider' column codec --- yet (no step has needed to persist more than this one literal); D0\/E2\/F1 should add a --- proper 'TextEncoding' instance once a second provider needs writing from the service side. -codePaymentProviderText :: Text -codePaymentProviderText = "code" - -- | Writes the @payments@ row alone (caller-minted UUID as @payment_id@, @provider = 'code'@, -- @invoice_id@ NULL, @status = 'settled'@ via 'PSSettled'\'s 'ToField'). Attaching it -- to the purchase is 'attachPurchasePayment', a separate call because the two are not always @@ -233,7 +667,7 @@ createCodePayment db paymentId now = INSERT INTO sx_badge_service_payments (payment_id, invoice_id, provider, status, created_at, updated_at) VALUES (?,?,?,?,?,?) |] - (paymentId, Nothing :: Maybe Text, codePaymentProviderText, PSSettled, now, now) + (paymentId, Nothing :: Maybe Text, PPCode, PSSettled, now, now) -- | Points the purchase's @payment_id@ at an existing payment. Guarded by @payment_id IS NULL@ -- so a purchase that already has a payment is never silently repointed; on no rows affected, a diff --git a/plans/badges-codes/2026-08-21-badges-web-checkout.md b/plans/badges-codes/2026-08-21-badges-web-checkout.md index a7cf20b03a..e8cb7102ae 100644 --- a/plans/badges-codes/2026-08-21-badges-web-checkout.md +++ b/plans/badges-codes/2026-08-21-badges-web-checkout.md @@ -149,7 +149,7 @@ The two `-m` filters are needed because the badge tests live under two hspec pat | C3 | `BadgeManager` worker | C1, C2 | ☑ | | C4 | Redeem path wired end to end | B6, B7, B9, C3 | ☑ | | C5 | Client and service integration tests | B10, C4 | ☑ | -| D0 | Store layer: orders, invoices, provider events | A3, A5, B1 | ☐ | +| D0 | Store layer: orders, invoices, provider events | A3, A5, B1 | ☑ | | D1 | Web project skeleton and tsc build | — | ☐ | | D2 | Design system and site wizard shell | D1 | ☐ | | D3 | Catalog fetch and the four site screens | D2, D4 | ☐ | @@ -753,14 +753,15 @@ Phase D ends with a browsable, priced site wizard whose Pay button reaches a rea **Do:** The web-order half of the store layer, split from B1 because it has no caller until D6 and belongs to the site rather than to the RPC path. It adds functions to the module B1 created, so there is no cabal edit, and it depends on B1 for `ServiceError` and `withServiceTransaction`. Same discipline as B1: every function takes a `DB.Connection` and opens no transaction of its own. -- `createOrder`, writing the `@invoices` row and the `@web_orders` row that references it in one call. +- `createOrder`, writing the `@invoices` row and the `@web_orders` row that references it in one call, taking a `NewWebOrder` record carrying both rows' fields — including the `invoiceId`, which the caller mints, since the store mints no identifiers (§9). - `getOrder`, returning the order **joined to its `@invoices` row**, so one call yields amount, currency, address, crypto amount, payment URL and expiry. E4 serves the order half of its response from this; its `code` and `disclosureExpiresAt` come from a separate `getCodeByHash` on the derived code (§3 Linkage). - `getOrderByProviderRef` and `getOrderByShortRef`, each returning at most one row; A3's unique indexes make a second impossible. H2's `--ref` subcommands resolve through the second. - `getStuckOrders :: UTCTime -> …`, returning orders in `invoiced` or `pending` whose `@invoices.expires_at` has passed, oldest first. H3's pass reads it. - `updateOrderStatus`, taking the new status and an optional `amountPaid`, so a partial payment or an underpaid expiry records the amount without settling (E3); `setOrderProviderRef`; `setOrderSettled`, writing `settled_at`, `amount_paid` and `status = 'paid'` together. `updateOrderStatus` and `setOrderSettled` also write the matching `@invoices.status` in the same transaction, keeping A3's invariant; nothing in this plan reads it. - `recordProviderEvent`, returning `False` only when the event is already present **and** processed; a row with a NULL `processed_at` is reprocessed, because the previous attempt did not complete. `markProviderEventProcessed`, called inside the settlement transaction. +- The two column enums the web tables need, `OrderMethod` and `WebOrderStatus`, are defined here with their `TextEncoding`/`ToField`/`FromField` instances — `OrderMethod` is the type D6's `Orders.hs` first named `Method`, moved because D0 has to persist a method before that module exists (§9). `@invoices.provider` is derived from the method and written through a real `TextEncoding PaymentProvider`, which this step adds, discharging B1's and C1's §9 notes. -**Verify:** In `tests/Bots/BadgeServiceTests.hs`: `createOrder` writes both rows and `getOrder` returns the invoice fields with them; `getOrderByProviderRef` finds the order after `setOrderProviderRef` replaces the value; `getOrderByShortRef` resolves a bank-statement reference; `getStuckOrders` returns an expired `pending` order and omits a `paid` one; `updateOrderStatus` with an `amountPaid` on a `pending` order records it and leaves `settled_at` NULL; `recordProviderEvent` returns `False` on a processed replay and `True` on an unprocessed one. +**Verify:** In `tests/Bots/BadgeServiceTests.hs`: `createOrder` writes both rows and `getOrder` returns the invoice fields with them; `getOrderByProviderRef` finds the order after `setOrderProviderRef` replaces the value; `getOrderByShortRef` resolves a bank-statement reference; `getStuckOrders` returns an expired `pending` order and omits a `paid` one; `updateOrderStatus` with an `amountPaid` on a `pending` order records it and leaves `settled_at` NULL; `setOrderSettled` writes `settled_at`, `amount_paid` and `status = 'paid'` together and moves `@invoices.status` with them; `recordProviderEvent` returns `False` on a processed replay and `True` on an unprocessed one; `markProviderEventProcessed` flips a NULL `processed_at` so the next `recordProviderEvent` returns `False`. #### D1 — Web project skeleton and tsc build @@ -864,13 +865,13 @@ POST /api/checkout { priceId, offerId?, method: "card"|"btc"|"xmr" } 503 { error: "provider_unavailable" } ``` -- `Orders.hs` defines the provider interface used by E2 and F1: `data Method = MCard | MBtc | MXmr`; `data OrderDraft` carrying badge type, months, amount, currency and `shortRef`; `data ProviderInvoice` carrying the provider's invoice id, `payUrl`, address, crypto amount and expiry; and `data ProviderError = PENetwork Text | PEStatus Int Text | PEDecode Text`, all of which map to `provider_unavailable` at the endpoint and are logged with their detail (H4). It also defines `readProviderInvoice :: Method -> Text -> IO (Either ProviderError ProviderStatus)`, keyed on `provider_ref`, where `data ProviderStatus = PSSettled CurrencyAmount UTCTime | PSPending CurrencyAmount | PSOpen | PSExpired CurrencyAmount | PSFailed`; H3 needs it to re-read a stuck order. Until E2 and F1 land, every branch of both functions returns `Left (PEStatus 503 "not configured")`, which the endpoint maps to `provider_unavailable`. +- `Orders.hs` defines the provider interface used by E2 and F1. The method type is **not** defined here: it is D0's `OrderMethod` (`OMCard | OMBtc | OMXmr`, `BadgeService/Store.hs`), imported, because the store had to persist a method before this module existed (§9). `Orders.hs` adds `data OrderDraft` carrying badge type, months, amount, currency and `shortRef`; `data ProviderInvoice` carrying the provider's invoice id, `payUrl`, address, crypto amount and expiry; and `data ProviderError = PENetwork Text | PEStatus Int Text | PEDecode Text`, all of which map to `provider_unavailable` at the endpoint and are logged with their detail (H4). It also defines `readProviderInvoice :: OrderMethod -> Text -> IO (Either ProviderError ProviderStatus)`, keyed on `provider_ref`, where `data ProviderStatus = PSSettled CurrencyAmount UTCTime | PSPending CurrencyAmount | PSOpen | PSExpired CurrencyAmount | PSFailed`; H3 needs it to re-read a stuck order. Until E2 and F1 land, every branch of both functions returns `Left (PEStatus 503 "not configured")`, which the endpoint maps to `provider_unavailable`. - Badge type and months are derived server-side: `priceId` gives the badge type, `offerId` gives the months, and a request with no `offerId` is exactly one month. The browser never states either, so a tampered request cannot buy a legend badge at a supporter price. - `amount` comes from A4's `offerTotal`; the browser's figure is never trusted. `cryptoCurrency` is derived from `method`; `@invoices.payment_crypto_currency` stays NULL (A3). - Price and offer status are checked here and only here: `deprecated` is accepted, `disabled` is rejected (RPC §Catalog). - `orderId` is 128 random bits, base64url. It is a bearer capability for the code (A3, decision 9), so it must not be sequential or derived from anything guessable. - `shortRef` is 5 characters from B3's Crockford alphabet, encoded with B3's encoder, drawn from a CSPRNG, unique per order, stored on `@web_orders`. On a unique-constraint violation the generator retries up to 10 times before failing the checkout request with `bad_request` and logging it (H4). The 32⁵ space is adequate for this plan's order volume; H5 records widening `shortRef` as the remedy if retries become frequent. -- The provider call goes through `createProviderInvoice :: Method -> OrderDraft -> IO (Either ProviderError ProviderInvoice)`, dispatching on method. A method whose provider section is absent from the ini is rejected the same way. +- The provider call goes through `createProviderInvoice :: OrderMethod -> OrderDraft -> IO (Either ProviderError ProviderInvoice)`, dispatching on method. A method whose provider section is absent from the ini is rejected the same way. - On a successful provider call, write an `@invoices` row and a `web_orders` row with `status = 'invoiced'` and `provider_ref` set from `ProviderInvoice`, in one transaction. **Verify:** In `tests/Bots/BadgeServiceTests.hs`: a disabled price, a disabled offer and an offer pinned to a different price are rejected before any provider call with `price_disabled`, `offer_disabled` and `offer_mismatch` respectively, the disabled rows produced with B1's `setPriceStatus` and `setOfferStatus`. An unrecognised extra key such as `months` or `amount` in the request body is ignored rather than honoured, since the request carries neither. At this step every method returns `provider_unavailable` and no order row is written, whether or not a provider section is present. No checkout can succeed until E2, so the assertions that need a written order, the `orderId` and `shortRef` uniqueness and the charged amounts, are in E2's Verify. @@ -1469,6 +1470,11 @@ Append here when a step contradicts this plan: the step id, what was wrong, and - **Phase C review — mobile cannot configure the badge service at all, which makes G2's and G3's Verify lines impossible as written. Assigned to G0.** `defaultChatConfig` sets `badgeServiceAddress = Nothing` and `badgeWebBaseUrl = ""`; `defaultMobileConfig` (`Mobile.hs`) overrides three unrelated fields and none of these; and `mobileChatOpts` hardcodes `optBadgeServiceAddress = Nothing`, `optBadgeWebUrl = Nothing` and `optBadgeIssuerKeys = []`. The three overrides exist only on the terminal CLI (`--badge-service-address`, `--badge-web-url`, `--badge-issuer-key`), so "verify manually against a locally run service" cannot be done on iOS or Android by any means the client offers. G0 is the assignment: it is the first mobile step, it lands before G2 and G3 need it, and until it does every mobile Verify line in Phase G is unrunnable. Whatever shape it takes — build-time constants, a debug-only setting, `mobileChatOpts` parameters — the three values must be reachable from a mobile build. - **Phase C review — `redeemBadgeCode` reads the reported badge state outside the badge lock. Accepted, not fixed.** The lock is released after `storeRedeemedBadge` and before `presentUserBadgeToContacts` (it must be: `presentUserBadgeToContacts` takes `chatLock`), and `getUserBadgeState` for the response runs after that. A concurrent redemption on the same profile could supersede this one in between, so the response would name the *other* purchase as shown. Cosmetic: both purchases are stored correctly, the rows are right, and the next `APIGetBadgeState` reports the truth. Fixing it would mean either computing the response inside the lock — which is a different value from the one the app will read next — or widening the lock over `chatLock`, which is the inversion C3 exists to avoid. - **Phase C review — a haddock gap fixed, and a style "fix" reverted as wrong.** The review reported `hasIssuanceForPeriod` (`Store/Badges.hs`) as the module's only query not using `[sql| |]`, and it was reformatted to match. That premise was false and the re-review caught it: the module carries bare-string queries at four other sites against six `[sql| |]` blocks, and the convention is by query length — `[sql| |]` for multi-line or multi-column statements, a plain string for a one-liner. Under the real convention the original was already consistent, and the reformat made a one-line `SELECT EXISTS` span five lines, so it was reverted. Recorded because two successive reviews asserted the convention without reading the module for it. And `runBadgeWorker`'s haddock did not mention the `waitChatStartedAndActivated` gate the C3 review round added to the top of its loop, which is the one thing about that loop a reader most needs to know after a suspend; it now names it and the three sibling loops that gate the same way. +- **D0 — `PaymentProvider` now has a column codec, and both `codePaymentProviderText = "code"` literals are gone.** B1's and C1's entries above deferred a real `TextEncoding PaymentProvider` until "a second provider needs writing from the service side"; D0's `createOrder` is that step, since `@invoices.provider` is written per order. The instance lives with the type (`PaymentService/Types.hs`), with `ToField`/`FromField` derived from it under the same CPP pattern `Badges/Types.hs` uses, and no JSON: `PaymentProvider` does not cross the wire, so this spelling is only ever read back from a column it was written to. The service's and the client's `createCodePayment` both now write `PPCode`, so the two databases cannot drift. **`@invoices.provider` is derived from `@web_orders.method`, not passed in** — `card → stripe`, `btc | xmr → crypto`, both crypto methods being the one BTCPay instance — so a caller cannot get the pair wrong. E2 and F1 inherit this rather than inventing their own literals; note that `crypto` is the spelling, not `btcpay` (which appears only in B10's hand-written test fixture). +- **D0 — the method enum lives in `Store.hs` as `OrderMethod`, not in D6's `Orders.hs` as `Method`.** D0 has to persist `@web_orders.method` before `Orders.hs` exists, and D0 makes no cabal edit, so the type and its codec are defined beside the column they serve. D6's step text is corrected to import it. The same applies to `WebOrderStatus` (`invoiced | pending | paid | expired | failed`), which is deliberately **not** `BadgePaymentStatus`: that enum has a `new` state an order never occupies and spells settlement `settled`, where A3's CHECK requires `paid`. `orderInvoiceStatus` is the single mapping between the two vocabularies, and it is what keeps A3's "`@invoices.status` in step" invariant true. +- **D0 — `createOrder` takes an `invoiceId`, which the plan's field list did not name.** `@invoices.invoice_id` is `TEXT NOT NULL PRIMARY KEY` with no default and the store mints no identifiers (it opens no transaction either), so D6 mints it alongside the `orderId`. It must NOT be the `orderId` itself: the order id is a bearer capability for the code (decision 9) and putting it in a second table widens the surface for no gain. Two more shapes the field list left open, both now fixed in code: `@invoices.price` and `@invoices.amount` both carry A4's `offerTotal` with `discount_amount`/`credit_amount` NULL, because an offer's discount is expressed as free months so the total IS the price; and `@invoices.payment_crypto_currency` is not written at all (A3 — `method` is the single source). +- **D0 — every order read is an INNER join to `@invoices`, and two new `ServiceError` constructors.** `getOrder`, `getOrderByProviderRef`, `getOrderByShortRef` and `getStuckOrders` all go through one `orderSelect`, joined rather than left-joined: `createOrder` is the only writer of a `@web_orders` row and always writes the invoice with it, so an order without one does not exist and `WebOrder` can hold the invoice's NOT NULL columns unwrapped. `SEOrderNotFound` is what `updateOrderStatus`, `setOrderProviderRef` and `setOrderSettled` throw when the order they name is absent; `SEProviderEventNotFound` is `markProviderEventProcessed`'s, reachable only if it and `recordProviderEvent` disagree about the key. **`setOrderSettled` does not guard on the current status**: settlement is idempotent and monotonic toward `paid` (E3), but that is E3's rule to apply, because the same decision governs whether a code row is written — a guard here would answer `SEOrderNotFound` for a replay, which is worse than no guard. +- **D0 — `getStuckOrders`' status filter leaves a recovery gap, implemented as specified. H3 decides.** The step says `invoiced` or `pending`, and that is what shipped. But E3 can move `expired` and `failed` to `paid` on a late webhook, so an order that one webhook marked `expired` and that then settles on chain with THAT webhook missed is never re-read from the provider by H3's pass — the buyer has paid and only support (H2) recovers it. Missed webhooks are exactly what H3 exists for, so this is worth a decision rather than an assumption; widening the filter to all four non-`paid` statuses is a change to H3's contract, not to this query, and the haddock on `getStuckOrders` says so. ## 10. End-to-end verification diff --git a/src/Simplex/Chat/PaymentService/Types.hs b/src/Simplex/Chat/PaymentService/Types.hs index 77b865633b..e739add223 100644 --- a/src/Simplex/Chat/PaymentService/Types.hs +++ b/src/Simplex/Chat/PaymentService/Types.hs @@ -198,6 +198,35 @@ instance ToField PaymentStatus where toField = toField . textEncode -- that a compile error instead of a silent loss. 'InvoiceStatus' keeps its 'FromField' because -- its three constructors are nullary and its decode is lossless. +-- | DB column spelling for @invoices.provider@, @payments.provider@ and +-- @provider_events.provider@. 'PaymentProvider' does not cross the wire (the RPC names a +-- provider through 'ServicePaymentMethod'), so this spelling is only ever read back from a +-- column it was written to -- the same arrangement 'InvoiceStatus' and 'PaymentStatus' document +-- above. It replaces the two @codePaymentProviderText = "code"@ literals that the client and +-- the service each carried while no codec existed (plan §9, B1\/C1): the badge service now writes +-- a second provider ('PPStripe' and 'PPCrypto', from D0's 'BadgeService.Store.createOrder'), which +-- is the condition both notes named for adding this. +instance TextEncoding PaymentProvider where + textEncode = \case + PPApple -> "apple" + PPGoogle -> "google" + PPStripe -> "stripe" + PPCrypto -> "crypto" + PPCode -> "code" + PPReceipt -> "receipt" + textDecode = \case + "apple" -> Just PPApple + "google" -> Just PPGoogle + "stripe" -> Just PPStripe + "crypto" -> Just PPCrypto + "code" -> Just PPCode + "receipt" -> Just PPReceipt + _ -> Nothing + +instance ToField PaymentProvider where toField = toField . textEncode + +instance FromField PaymentProvider where fromField = fromTextField_ textDecode + -- JSON -- CardProvider has a single nullary constructor; tagSingleConstructors is needed so it still diff --git a/src/Simplex/Chat/Store/Badges.hs b/src/Simplex/Chat/Store/Badges.hs index dac50099f0..844c8d5c35 100644 --- a/src/Simplex/Chat/Store/Badges.hs +++ b/src/Simplex/Chat/Store/Badges.hs @@ -83,7 +83,7 @@ import Simplex.Chat.Badges.Types LedgerDebitType (..), LedgerEntryType (..), ) -import Simplex.Chat.PaymentService.Types (PaymentStatus (..)) +import Simplex.Chat.PaymentService.Types (PaymentProvider (..), PaymentStatus (..)) import Simplex.Chat.Store.Shared (StoreError (..)) import Simplex.Messaging.Agent.Protocol (UserId) import Simplex.Messaging.Agent.Store.DB (Binary (..), BoolInt (..)) @@ -142,13 +142,6 @@ badgeSlot = \case BTInvestor -> BSInvestor BTUnknown tag -> BSOther tag --- | @payments.provider@ has no column codec yet: 'Simplex.Chat.PaymentService.Types.PaymentProvider' --- has no 'TextEncoding' instance, and adding one is D0\/E2\/F1's, once a second provider needs --- writing. Until then this literal is the client twin of --- 'BadgeService.Store.codePaymentProviderText' and must keep the same spelling. -codePaymentProviderText :: Text -codePaymentProviderText = "code" - -- | The @payments@ row of a code redemption: a caller-minted UUID (the column is -- @TEXT NOT NULL PRIMARY KEY@ with no default), @provider = 'code'@, no invoice — a code -- payment never has one — and @settled@, because a redeemed code is paid for by definition. @@ -166,7 +159,7 @@ createCodePayment db now = do INSERT INTO payments (payment_id, invoice_id, provider, status, created_at, updated_at) VALUES (?,?,?,?,?,?) |] - (paymentId, Nothing :: Maybe Text, codePaymentProviderText, PSSettled, now, now) + (paymentId, Nothing :: Maybe Text, PPCode, PSSettled, now, now) pure paymentId -- | The purchase row of a code redemption, written on success only: a code redemption does not diff --git a/tests/Bots/BadgeServiceTests.hs b/tests/Bots/BadgeServiceTests.hs index 33a978ac8a..e841c49c84 100644 --- a/tests/Bots/BadgeServiceTests.hs +++ b/tests/Bots/BadgeServiceTests.hs @@ -105,6 +105,7 @@ import Simplex.Chat.Badges.Types ( BadgeItemStatus (..), BadgeLedgerEntry (..), BadgeOfferId (..), + BadgePriceId (..), BadgePurchasePayment (BPPCode), BadgePurchaseStatus (..), LedgerCreditType (..), @@ -117,7 +118,7 @@ import Simplex.Chat.Library.Commands (execChatCommand') import Simplex.Chat.Options (CoreChatOpts (..)) import Simplex.Chat.Options.DB import Simplex.Chat.PaymentService (ServicePayment (..)) -import Simplex.Chat.PaymentService.Types (CurrencyAmount (..)) +import Simplex.Chat.PaymentService.Types (CurrencyAmount (..), PaymentProvider (..)) import Simplex.Chat.Types (ChatPeerType (..), ConnectTarget (..), Profile (..), User (User, userId)) import Simplex.Messaging.Agent.Env.SQLite (AgentConfig (serviceRequestTimeout)) import Simplex.Messaging.Agent.Protocol (ConnectionMode (CMContact)) @@ -193,6 +194,11 @@ badgeServiceTests = do it "should return the redeeming purchase key from getCodeByHash" testBadgeStoreGetCodeByHashRedeemer it "should refuse to redeem a revoked code, leaving the row untouched" testBadgeStoreMarkCodeRedeemedRefusesRevoked it "should clear both redemption columns and set unredeemed_at" testBadgeStoreUnredeemCode + it "should write an order and its invoice in one call and read them back joined" testBadgeStoreCreateOrderAndGet + it "should resolve an order by its provider ref, its replacement and its short ref" testBadgeStoreOrderRefLookups + it "should return expired invoiced and pending orders oldest first, omitting paid and unexpired ones" testBadgeStoreStuckOrders + it "should record a partial payment without settling, then settle status, amount and time together" testBadgeStoreOrderStatusAndSettlement + it "should reprocess an unprocessed provider event and refuse a processed replay" testBadgeStoreProviderEventReplay it "should redeem a valid code into a verifiable credential, with a credit(payment) then debit(badge) ledger" testBadgeServiceRedeemCodeIssuesCredential it "should return the same credential and write no new row when the identical request is repeated" testBadgeServiceRedeemCodeIdempotent it "should append exactly one debit(lapse) when the identical request is repeated after months lapsed" testBadgeServiceReplayAfterLapseHealsOnce @@ -2361,6 +2367,238 @@ testBadgeStoreUnredeemCode ps = Nothing -> expectationFailure "unredeemed_at should be set after unredeemCode" redeemer `shouldBe` Nothing +-- D0 store layer: orders, invoices, provider events --------------------------- + +-- | A crypto order as D6 will write one: a supporter badge, 3 months, $14.00, with the address +-- and crypto amount E2's @getPaymentMethods@ returns. The catalog ids are passed in rather than +-- filled by a record update, which -XDuplicateRecordFields warns on, and only the first test +-- below seeds a catalog to pin them to. +testNewOrder :: Text -> Text -> UTCTime -> Maybe BadgePriceId -> Maybe BadgeOfferId -> NewWebOrder +testNewOrder orderId shortRef expiresAt priceId offerId = + NewWebOrder + { orderId, + invoiceId = orderId <> "-invoice", + providerRef = Just (orderId <> "-btcpay"), + method = OMBtc, + shortRef, + badgeType = BTSupporter, + priceId, + offerId, + months = 3, + amount = CurrencyAmount 1400, + currency = "usd", + payUrl = Nothing, + paymentAddress = Just "bc1qd0teststoreaddress", + cryptoAmount = Just "0.00042", + expiresAt + } + +-- | The order's id, for asserting WHICH order a lookup resolved to: 'WebOrder''s field selectors +-- are ambiguous under -XDuplicateRecordFields, so every read below goes through a pattern match. +orderIdOf :: WebOrder -> Text +orderIdOf WebOrder {orderId} = orderId + +-- | 'serviceRowCount' against a 'DBStore' rather than an open connection, which is what the +-- store tests hold. +serviceRowCount' :: DBStore -> String -> IO Int +serviceRowCount' st table = withConnection st (`serviceRowCount` table) + +-- | The @invoices row as the database holds it: @(provider, price, amount, currency, status, +-- payment_crypto_currency)@. Read as raw columns rather than through 'getOrder', so the +-- assertions pin what was written rather than what the join makes of it -- and because +-- @invoices.status@ and @provider@ are read by nothing in production (A3), these are the only +-- reads of them that will ever exist. +serviceInvoiceRow :: HasCallStack => DBStore -> Text -> IO (Text, Int64, Int64, Text, Text, Maybe Text) +serviceInvoiceRow st invoiceId = do + rows <- + withConnection st $ \db -> + DB.query db "SELECT provider, price, amount, currency, status, payment_crypto_currency FROM sx_badge_service_invoices WHERE invoice_id = ?" (Only invoiceId) + case rows of + [row] -> pure row + _ -> expectationFailure ("expected exactly one invoice row for " <> show invoiceId <> ", got " <> show (length rows)) >> error "unreachable" + +-- createOrder writes BOTH rows -- the @invoices row and the @web_orders row that references it -- +-- and getOrder returns them joined, so one call yields the amount, currency, address, crypto +-- amount, payment URL and expiry E4 serves. The catalog is seeded first and the order pinned to a +-- real price and offer, so price_id/offer_id are exercised as the foreign keys they are rather +-- than as NULLs. +testBadgeStoreCreateOrderAndGet :: HasCallStack => TestParams -> IO () +testBadgeStoreCreateOrderAndGet ps = + withFreshBadgeStore ps $ \st -> do + seedCatalog st + BadgeCatalog {prices, offers} <- expectRight $ withServiceTransaction st getActiveCatalog + Just BadgePrice {priceId = supporterPriceId} <- pure $ find (\BadgePrice {badgeType} -> badgeType == BTSupporter) prices + Just BadgeOffer {offerId = threeMonths} <- pure $ find (\BadgeOffer {priceId, months} -> priceId == Just supporterPriceId && months == 3) offers + now <- getCurrentTime + let expiry = addUTCTime (30 * 60) now + newOrder = testNewOrder "d0-order-1" "K3M7Q" expiry (Just supporterPriceId) (Just threeMonths) + _ <- expectRight $ withServiceTransaction st $ \db -> createOrder db newOrder now + -- both rows, and exactly one of each + serviceRowCount' st "web_orders" `shouldReturn` 1 + serviceRowCount' st "invoices" `shouldReturn` 1 + Just order <- expectRight $ withServiceTransaction st $ \db -> getOrder db "d0-order-1" + let WebOrder {orderId, invoiceId, providerRef, method, shortRef, badgeType, priceId, offerId, months, status} = order + WebOrder {amountPaid, settledAt, amount, currency, payUrl, paymentAddress, cryptoAmount, expiresAt, createdAt} = order + (orderId, invoiceId, shortRef) `shouldBe` ("d0-order-1", "d0-order-1-invoice", "K3M7Q") + (providerRef, method, badgeType, months) `shouldBe` (Just "d0-order-1-btcpay", OMBtc, BTSupporter, 3) + (priceId, offerId) `shouldBe` (Just supporterPriceId, Just threeMonths) + -- a new order is invoiced and unpaid: neither column a settlement writes is set + (status, amountPaid, settledAt) `shouldBe` (WOSInvoiced, Nothing, Nothing) + -- the invoice half of the join, which is the whole point of getOrder returning one record + (amount, currency) `shouldBe` (CurrencyAmount 1400, "usd") + (payUrl, paymentAddress, cryptoAmount) `shouldBe` (Nothing, Just "bc1qd0teststoreaddress", Just "0.00042") + expiresAt `shouldBeStoredAt` expiry + createdAt `shouldBeStoredAt` now + -- and the invoice columns nothing in this plan reads: provider is derived from the method + -- (btc -> crypto), price and amount both carry the charged total, the status is the order's + -- projected through orderInvoiceStatus (invoiced -> open), and payment_crypto_currency is + -- deliberately left NULL (A3) + serviceInvoiceRow st "d0-order-1-invoice" `shouldReturn` ("crypto", 1400, 1400, "usd", "open", Nothing) + unknown <- expectRight $ withServiceTransaction st $ \db -> getOrder db "d0-order-nonexistent" + (orderIdOf <$> unknown) `shouldBe` Nothing + +-- getOrderByProviderRef and getOrderByShortRef each resolve exactly one order, and setOrderProviderRef +-- REPLACES the reference an order was created with -- which F3 needs, because a Stripe payment intent +-- is only known once the checkout session completes. Two orders exist throughout, so a lookup that +-- ignored its argument and returned the only row would fail. +testBadgeStoreOrderRefLookups :: HasCallStack => TestParams -> IO () +testBadgeStoreOrderRefLookups ps = + withFreshBadgeStore ps $ \st -> do + now <- getCurrentTime + let expiry = addUTCTime (30 * 60) now + _ <- expectRight $ withServiceTransaction st $ \db -> createOrder db (testNewOrder "d0-order-1" "K3M7Q" expiry Nothing Nothing) now + _ <- expectRight $ withServiceTransaction st $ \db -> createOrder db (testNewOrder "d0-order-2" "T9WZ4" expiry Nothing Nothing) now + let byProviderRef ref = fmap orderIdOf <$> expectRight (withServiceTransaction st $ \db -> getOrderByProviderRef db ref) + byShortRef ref = fmap orderIdOf <$> expectRight (withServiceTransaction st $ \db -> getOrderByShortRef db ref) + byProviderRef "d0-order-1-btcpay" `shouldReturn` Just "d0-order-1" + byProviderRef "d0-order-2-btcpay" `shouldReturn` Just "d0-order-2" + -- the replacement: the old reference resolves to nothing, the new one to the same order + _ <- expectRight $ withServiceTransaction st $ \db -> setOrderProviderRef db "d0-order-1" "pi_d0_stripe_intent" now + byProviderRef "d0-order-1-btcpay" `shouldReturn` Nothing + byProviderRef "pi_d0_stripe_intent" `shouldReturn` Just "d0-order-1" + byProviderRef "d0-order-2-btcpay" `shouldReturn` Just "d0-order-2" + -- the bank-statement reference support resolves by (H2), and only that order + byShortRef "K3M7Q" `shouldReturn` Just "d0-order-1" + byShortRef "T9WZ4" `shouldReturn` Just "d0-order-2" + byShortRef "QQQQQ" `shouldReturn` Nothing + -- and every mutation names an order that must exist + refused <- withServiceTransaction st $ \db -> setOrderProviderRef db "d0-order-nonexistent" "pi_nothing" now + refused `shouldBe` Left SEOrderNotFound + +-- getStuckOrders returns the orders H3's pass must re-read from the provider: still open +-- (invoiced or pending) and past their invoice expiry, oldest expiry first. A paid order is never +-- stuck however long ago its invoice expired -- late on-chain settlement is routine (E3) -- and an +-- unexpired order is not stuck yet. +testBadgeStoreStuckOrders :: HasCallStack => TestParams -> IO () +testBadgeStoreStuckOrders ps = + withFreshBadgeStore ps $ \st -> do + now <- getCurrentTime + let daysAgo d = addUTCTime (negate d * nominalDay) now + create orderId shortRef expiry = expectRight $ withServiceTransaction st $ \db -> createOrder db (testNewOrder orderId shortRef expiry Nothing Nothing) now + create "d0-stuck-oldest" "AAAAA" (daysAgo 3) + create "d0-stuck-newer" "BBBBB" (daysAgo 1) + create "d0-settled" "CCCCC" (daysAgo 2) + create "d0-open" "DDDDD" (addUTCTime nominalDay now) + _ <- expectRight $ withServiceTransaction st $ \db -> updateOrderStatus db "d0-stuck-newer" WOSPending (Just (CurrencyAmount 700)) now + _ <- expectRight $ withServiceTransaction st $ \db -> setOrderSettled db "d0-settled" (CurrencyAmount 1400) now + stuck <- expectRight $ withServiceTransaction st $ \db -> getStuckOrders db now + -- oldest expiry first, the paid one omitted, the unexpired one omitted + map orderIdOf stuck `shouldBe` ["d0-stuck-oldest", "d0-stuck-newer"] + map (\WebOrder {status} -> status) stuck `shouldBe` [WOSInvoiced, WOSPending] + -- the cutoff is the instant passed in, not the current time: two days back, only the oldest + -- has expired + earlier <- expectRight $ withServiceTransaction st $ \db -> getStuckOrders db (daysAgo 2) + map orderIdOf earlier `shouldBe` ["d0-stuck-oldest"] + +-- updateOrderStatus records what arrived without settling: a partial payment moves the order to +-- pending and writes amount_paid, leaving settled_at NULL, and a later status change with no +-- amount keeps the amount already recorded (E5 renders it for an underpaid expiry). setOrderSettled +-- then writes settled_at, amount_paid and status = 'paid' together. Both move @invoices.status in +-- step, which is A3's invariant and is asserted from the column itself. +testBadgeStoreOrderStatusAndSettlement :: HasCallStack => TestParams -> IO () +testBadgeStoreOrderStatusAndSettlement ps = + withFreshBadgeStore ps $ \st -> do + now <- getCurrentTime + let expiry = addUTCTime (30 * 60) now + invoiceStatus = do + (_, _, _, _, status, _) <- serviceInvoiceRow st "d0-order-1-invoice" + pure status + orderState = do + Just WebOrder {status, amountPaid, settledAt} <- expectRight $ withServiceTransaction st $ \db -> getOrder db "d0-order-1" + pure (status, amountPaid, settledAt) + _ <- expectRight $ withServiceTransaction st $ \db -> createOrder db (testNewOrder "d0-order-1" "K3M7Q" expiry Nothing Nothing) now + invoiceStatus `shouldReturn` "open" + -- a partial payment: recorded, not settled. The order moves invoiced -> pending; the invoice + -- does not move at all, because orderInvoiceStatus maps both onto ISOpen + _ <- expectRight $ withServiceTransaction st $ \db -> updateOrderStatus db "d0-order-1" WOSPending (Just (CurrencyAmount 700)) now + orderState `shouldReturn` (WOSPending, Just (CurrencyAmount 700), Nothing) + invoiceStatus `shouldReturn` "open" + -- an underpaid expiry: no new amount, and the one already recorded is kept rather than cleared + _ <- expectRight $ withServiceTransaction st $ \db -> updateOrderStatus db "d0-order-1" WOSExpired Nothing now + orderState `shouldReturn` (WOSExpired, Just (CurrencyAmount 700), Nothing) + invoiceStatus `shouldReturn` "expired" + -- late settlement after expiry, which is routine on-chain: all three columns at once + let settledAt = addUTCTime (2 * 3600) now + _ <- expectRight $ withServiceTransaction st $ \db -> setOrderSettled db "d0-order-1" (CurrencyAmount 1400) settledAt + (status, amountPaid, storedSettledAt) <- orderState + (status, amountPaid) `shouldBe` (WOSPaid, Just (CurrencyAmount 1400)) + case storedSettledAt of + Just at -> at `shouldBeStoredAt` settledAt + Nothing -> expectationFailure "settled_at should be set by setOrderSettled" + -- the invoice leaves 'expired' for 'paid' with the order: the projection is applied on every + -- write, not only on the way out of 'open' + invoiceStatus `shouldReturn` "paid" + -- neither writer invents an order + missingUpdate <- withServiceTransaction st $ \db -> updateOrderStatus db "d0-order-nonexistent" WOSPending Nothing now + missingUpdate `shouldBe` Left SEOrderNotFound + missingSettle <- withServiceTransaction st $ \db -> setOrderSettled db "d0-order-nonexistent" (CurrencyAmount 1400) now + missingSettle `shouldBe` Left SEOrderNotFound + +-- recordProviderEvent returns False ONLY for an event that has already been PROCESSED. A row whose +-- processed_at is NULL is one whose previous attempt died mid-settlement, so it comes back as True +-- and is processed again (E3, E7); treating it as a duplicate would strand a paid order forever. +-- markProviderEventProcessed is what flips that row, inside the settlement transaction. +testBadgeStoreProviderEventReplay :: HasCallStack => TestParams -> IO () +testBadgeStoreProviderEventReplay ps = + withFreshBadgeStore ps $ \st -> do + now <- getCurrentTime + let record provider eventId at = expectRight $ withServiceTransaction st $ \db -> recordProviderEvent db provider eventId at + eventRow :: Text -> IO (UTCTime, Maybe UTCTime) + eventRow eventId = do + rows <- + withConnection st $ \db -> + DB.query db "SELECT received_at, processed_at FROM sx_badge_service_provider_events WHERE provider = 'crypto' AND event_id = ?" (Only eventId) + case rows of + [row] -> pure (row :: (UTCTime, Maybe UTCTime)) + _ -> expectationFailure ("expected exactly one event row, got " <> show (length rows)) >> error "unreachable" + -- first delivery + record PPCrypto "d0-invoice-1-InvoiceSettled" now `shouldReturn` True + -- redelivered before the first attempt completed: reprocess, and the row is not duplicated + let redeliveredAt = addUTCTime 60 now + record PPCrypto "d0-invoice-1-InvoiceSettled" redeliveredAt `shouldReturn` True + serviceRowCount' st "provider_events" `shouldReturn` 1 + -- the row still carries the FIRST delivery's time, and is still unprocessed + (receivedAt, unprocessed) <- eventRow "d0-invoice-1-InvoiceSettled" + receivedAt `shouldBeStoredAt` now + unprocessed `shouldBe` Nothing + -- the settlement transaction completes + let processedAt = addUTCTime 120 now + _ <- expectRight $ withServiceTransaction st $ \db -> markProviderEventProcessed db PPCrypto "d0-invoice-1-InvoiceSettled" processedAt + (_, storedProcessedAt) <- eventRow "d0-invoice-1-InvoiceSettled" + case storedProcessedAt of + Just at -> at `shouldBeStoredAt` processedAt + Nothing -> expectationFailure "processed_at should be set by markProviderEventProcessed" + -- and now the same event is a replay + record PPCrypto "d0-invoice-1-InvoiceSettled" (addUTCTime 180 now) `shouldReturn` False + -- dedup is keyed on (provider, event_id): the same id from another provider is a new event + record PPStripe "d0-invoice-1-InvoiceSettled" now `shouldReturn` True + -- as is a different event from the same provider + record PPCrypto "d0-invoice-1-InvoiceProcessing" now `shouldReturn` True + serviceRowCount' st "provider_events" `shouldReturn` 3 + -- closing out an event that was never recorded is a mismatch between the two calls, not a no-op + missing <- withServiceTransaction st $ \db -> markProviderEventProcessed db PPCrypto "d0-invoice-1-never-recorded" now + missing `shouldBe` Left SEProviderEventNotFound + -- B4 issuer key + credential signing ----------------------------------------- sundayEndOfDay :: DiffTime