diff --git a/.github/workflows/badge-web.yml b/.github/workflows/badge-web.yml new file mode 100644 index 0000000000..4961c79fd1 --- /dev/null +++ b/.github/workflows/badge-web.yml @@ -0,0 +1,33 @@ +name: badge web + +on: + push: + branches: + - master + - stable + paths: + - "apps/simplex-badge-service/web/**" + - ".github/workflows/badge-web.yml" + pull_request: + paths: + - "apps/simplex-badge-service/web/**" + - ".github/workflows/badge-web.yml" + +jobs: + test: + runs-on: ubuntu-latest + defaults: + run: + working-directory: apps/simplex-badge-service/web + steps: + - uses: actions/checkout@v4 + + - uses: actions/setup-node@v4 + with: + node-version: 24 + cache: npm + cache-dependency-path: apps/simplex-badge-service/web/package-lock.json + + - run: npm ci + + - run: npm test diff --git a/.gitignore b/.gitignore index 035d24c6cd..fd6ebfb9f6 100644 --- a/.gitignore +++ b/.gitignore @@ -86,4 +86,11 @@ website/.cache website/test/stubs-layout-cache/_includes/*.js apps/android/app/release apps/multiplatform/.kotlin/sessions +# anywhere in the tree: this file holds a real BTCPay api_key and webhook_secret +badge_service.ini +# Badge service Docker deployment: the Dockerfile, compose, and example config are tracked; the +# live config (a secret) and its data volume are not. +scripts/badge-service/badge_service.ini +scripts/badge-service/data/ +scripts/badge-service/web/ diff --git a/apps/simplex-badge-service/Main.hs b/apps/simplex-badge-service/Main.hs index 64a2e1d553..cdeb1c0c1e 100644 --- a/apps/simplex-badge-service/Main.hs +++ b/apps/simplex-badge-service/Main.hs @@ -4,10 +4,13 @@ module Main where import BadgeService.Options (BadgeServiceOpts (..)) import BadgeService.Service +import Control.Logger.Simple (LogConfig (..), LogLevel (..), setLogLevel, withGlobalLogging) import Simplex.Chat.Terminal (terminalChatConfig) +-- | withGlobalLogging installs the SMP agent's log sinks, which the chat core otherwise installs only under --log-agent. main :: IO () -main = do +main = withGlobalLogging LogConfig {lc_file = Nothing, lc_stderr = True} $ do + setLogLevel LogWarn opts@BadgeServiceOpts {runCLI} <- welcomeGetOpts if runCLI then badgeServiceCLI opts diff --git a/apps/simplex-badge-service/README.md b/apps/simplex-badge-service/README.md index 9776a8de05..a29f0d7036 100644 --- a/apps/simplex-badge-service/README.md +++ b/apps/simplex-badge-service/README.md @@ -1,16 +1,34 @@ # SimpleX badge service -Scaffolding for the SimpleX supporter-badge RPC service. The wire protocol is specified in [`docs/protocol/badges-rpc.md`](../../docs/protocol/badges-rpc.md), and the implementation plans live under [`plans/`](../../plans) (`2026-07-30-supporter-badges-v3-ux.md`, `2026-07-31-badges-core-implementation.md`, `2026-08-04-badges-mvp-scope.md`). +`simplex-badge-service` runs the whole supporter-badge service as one process, two +lanes: a SimpleX chat bot that answers service RPC over a double-ratchet contact +address, and — only when `--service-config` names a `badge_service.ini` — the badge-codes +web checkout (BTCPay and Stripe payment, code issuance, the poller). **Without +`--service-config` the web listener does not start at all**; the process still runs the +chat side and nothing else. + +The wire protocol for the RPC side is +[`docs/protocol/badges-rpc.md`](../../docs/protocol/badges-rpc.md). The web checkout is +specified in +[`plans/badges-codes/2026-08-27-badge-codes.md`](../../plans/badges-codes/2026-08-27-badge-codes.md), +whose §9 is the `badge_service.ini` reference, with the implementation plan in +[`plans/badges-codes/2026-08-31-service-btcpay.md`](../../plans/badges-codes/2026-08-31-service-btcpay.md). +Earlier plans (`2026-07-30-supporter-badges-v3-ux.md`, `2026-07-31-badges-core-implementation.md`, +`2026-08-04-badges-mvp-scope.md`) predate the web checkout and describe the RPC-only +scaffold this service started as. At this stage the service: - creates a double-ratchet contact address on first start (service RPC requires DR, see [`docs/protocol/badges-rpc.md`](../../docs/protocol/badges-rpc.md)), - listens for service requests (`CEvtServiceRequest`) on that address, rejects a request whose `purchaseKey` is not the key the agent verified the signature against, and answers `redeemBadgeCode`, - issues redemption codes, storing only their `SHA-256` and printing each code once, -- does not accept contact requests — the address is for RPC only, +- does not accept contact requests unless `[dev] chat_redeem` is on: the address is for RPC only, +- in service mode with `--service-config`, also serves the built web app (`npm run build` in `web/`), `POST /api/invoice` and `GET /api/invoice/:id`, the BTCPay and Stripe webhook routes, and a payment poller, seeding its price/offer catalog on every start, - owns the `sx_badge_service_`-prefixed tables and its own migrations table (`sx_badge_service_migrations`). -Every other command still answers `unsupported_version`. Ledger writes, invoices and provider webhooks are left for follow-up per the plans; a redemption issues one credential and reports an empty statement. +Every other command answers `unsupported_version`, or `unknown_purchase_key` when the key that +signed it is not one the service has stored — every command but `redeemBadgeCode` needs a +purchase that already exists. ## Build @@ -27,9 +45,11 @@ simplex-badge-service --help ``` - default (no `--run-cli`): background service mode, no interactive terminal. -- `--run-cli`: interactive CLI that also processes service requests (mirrors `simplex-directory-service --run-cli`). +- `--run-cli`: interactive CLI that also processes service requests (mirrors + `simplex-directory-service --run-cli`). This mode is the chat/RPC side and the `//` commands + below: it starts no web listener and no poller, and `[dev] chat_redeem` does not apply to it, + whatever `--service-config` says. - `--no-address`: skip address creation on start-up (for operators who provision the address themselves). - The service cannot sign credentials without an issuer key and refuses to start without one: - `--issuer-key-idx IDX` — the index the apps find the matching public key under (`badgePublicKeys` in `ChatConfig`). @@ -39,6 +59,167 @@ The service checks the secret against the configured public key at that index an if they disagree: credentials signed with the wrong key cannot be verified by any client, and the codes redeemed against them would be spent for nothing. +The keys can come from `badge_service.ini` instead, which is where more than one can be listed: + +```ini +[issuer] +default = key_1 +key_1 = +key_3 = +``` + +`key_` is the index clients verify against (`badgePublicKeys` in `ChatConfig`), and `default` +names the one that signs. Only that key signs; the others are listed so that rotating is a change +to `default` and a restart, with the old key still present to roll back to. Every key in the +section is checked at startup, not just the default, so a key that clients could not verify fails +before anyone rotates onto it. + +The command line wins over the file when both `--issuer-key-idx` and `--issuer-secret` are given. +Note that a secret passed as a flag is visible to every user on the machine through `ps`, where one +in the ini is only as readable as the file: `badge_service.ini` is gitignored and already holds the +provider API keys and webhook secrets. + +Other options: + +- `--service-config INI_FILE`: path to `badge_service.ini`. Omit it to run the chat/RPC side + only; the process never starts a web listener without it, and never starts one under + `--run-cli`, which parses and validates the whole file (`[listener] static_dir` included) but + uses only its `[issuer]` section. An issuer key is still required either way. +- `--service-name NAME`: the bot's display name, without `*`s or spaces (default `SimpleX Badges`). +- `--client-service`: use the client service certificate. +- also accepts the standard SimpleX Chat core options — database path, SMP/XFTP servers, + `--socks-proxy`, `--log-level`/`-l`, and the rest — run `simplex-badge-service --help` + for the complete list. + +### Running the web checkout + +`badge_service.ini` holds the listener bind address and `static_dir`, an optional +`[btcpay]` section (omitting it disables Bitcoin and Monero), an optional `[stripe]` +section (omitting it disables card payments) and the poll cadence. +`badge_service.ini.example` is the committed template; `badge_service.ini` itself is +gitignored, since a real one holds API keys and webhook secrets. + +The full walkthrough is in +[`web/README.md`](web/README.md#running-the-real-service-against-this-build). Short version: + +``` +cd apps/simplex-badge-service/web && npm install && npm run build && cd ../../.. +cp apps/simplex-badge-service/badge_service.ini.example apps/simplex-badge-service/badge_service.ini +cabal run simplex-badge-service -- \ + --issuer-key-idx IDX --issuer-secret SECRET \ + --service-config apps/simplex-badge-service/badge_service.ini +``` + +`IDX` and `SECRET` must be one of the issuer keys clients already ship, not a fresh +`simplex-chat badge keygen` pair: startup refuses a key no client could verify against. + +`trust_forwarded_for` decides what the rate limiter counts. Behind a reverse proxy it must be +`on`, or every request keys on the proxy's address and the whole service shares one bucket of 60 +reads and 5 checkouts a minute. Where the listener is reached directly it must be `off`, because +then the header is whatever the caller wrote. The last entry is the one read, which is the one a +proxy appends. + +The BTCPay API key needs four permissions, each scoped to the one store: +`cancreateinvoice` and `canviewinvoices` for checkout and the poller, +`canviewstoresettings` to log the store's live payment methods at startup, and +`canmodifyinvoices` so `POST /api/invoice/:id/cancel` can invalidate an invoice at BTCPay +rather than only in this store. + +### Card payments (Stripe) + +An optional `[stripe]` section enables the card lane; omitting it disables card payments +and `POST /api/invoice` answers `provider_unavailable` for a card order, the same as an +absent `[btcpay]` does for Bitcoin and Monero. Its keys: + +- `secret_key` — a **restricted** key (`rk_...`), never a full secret key (`sk_...`). Grant it + **Checkout Sessions: write**, plus **PaymentIntents: read** and **Charges: read** — the poller + reads a session with `expand[]=payment_intent.latest_charge`, and Stripe rejects the whole read + if the key lacks read on an expanded object (settlement then falls back to the slower list pass). +- `publishable_key` (`pk_...`) — the public key the browser mounts the Payment Element with. +- `webhook_secret` (`whsec_...`) — the signing secret of the `/webhooks/stripe` endpoint, + configured in the Stripe Dashboard alongside it. +- `receipt_email` — a fixed address sent as the session's `customer_email`. The Checkout Sessions + API requires an email to confirm, so this is prefilled and the buyer never enters one. Use an + address you own (turn receipts off in the Dashboard to keep it quiet); never derive it from the + order id, which is a bearer capability the service never sends Stripe. +- `session_minutes` — minutes until an unpaid checkout session expires; must be between + 31 and 1439, default 60. The bounds sit a minute inside Stripe's own 30-minute-to-24-hour + window, so request latency or clock skew cannot push an at-bound value outside it. + +The service fills `publishable_key` into the shell at boot: the built `index.html` ships +with an empty `` +(`web/public/index.html`), and the listener serves a copy with the configured key +substituted in, so the ini is the only place the key is set. With no `[stripe]` section the +pristine (empty) shell is served and the page shows its development stand-in card form. The +dev mock (`web/mock/server.py`) does the same substitution from `$STRIPE_PUBLISHABLE_KEY`, +since it runs without an ini. + +`POST /webhooks/stripe` verifies `Stripe-Signature` against `webhook_secret` and queues a +read, the same hint-only role as `POST /webhooks/btcpay`: the poller carries authority, so +an unverified or unreadable delivery costs nothing but a log line. + +The reverse proxy in front of this service must send a Content-Security-Policy that +allows Stripe.js and its iframes, since Stripe forbids bundling or self-hosting its +script: + +``` +script-src 'self' https://js.stripe.com https://*.js.stripe.com; +frame-src https://js.stripe.com https://*.js.stripe.com https://hooks.stripe.com +``` + +**Stripe Link must be disabled in the Dashboard.** Left on, it needs `link.com` in the +CSP above and reintroduces an email prompt of its own, which this design otherwise avoids. + +**Enable card only; do not enable redirect-based methods** (iDEAL, Bancontact, PayPal, and +the rest) in the Dashboard. The embedded checkout sends no `return_url`, which Stripe requires +the moment a redirect-based method is offered, so enabling one makes every checkout fail to +create. The service pins the Stripe API version it was built against, so the account's default +version does not affect the card lane. + +### The checkout endpoints + +The browser in `web/` is the only client of the `/api` routes; the two webhooks below are the +providers', one each for BTCPay and Stripe. +The invoice id is the only credential for reading or cancelling an order: it is 16 random bytes, +it travels in the path, and anything that logs request paths logs it. It is also what the buyer +is shown as their reference and asked to quote, so support sees it: losing it lets someone cancel +an invoice, which is why the code, which lets them take the badge, is never printed until the +service says the invoice is paid. The service keeps it out of its own logs, which name the +provider's reference instead. + +| Route | Answers | +|---|---| +| `POST /api/invoice` | `{invoiceId, badgeType, months, amount, currency, expiresAt}` plus a destination: `clientSecret` for a card, or `address`, `cryptoAmount`, `cryptoCurrency`. Refuses with `code_conflict`, `catalog_changed`, `bad_request`, `provider_unavailable` or `rate_limited`. | +| `GET /api/invoice/:id` | `{status, badgeType, months, amount, currency, expiresAt}` and the same destination — no `invoiceId`, since the caller already has it — plus `amountPaid`, `cryptoAmountPaid`, `cryptoAmountDue`, `paidInFull`, `settledAt` and `requiredConfirmations` once each has a value. Never the code, which this service has never seen. | +| `GET /api/invoice/:id?wait=&seenPaid=
&seenFull=<0\|1>` | The same, held for up to 30 seconds while the invoice's status is still `` **and** its payment is the one the caller says it has rendered. `wait=paid` and any value that is not a status answer at once, since neither can change. A status the caller has not seen, or a payment it has not seen, answers at once — the provider's verdict counts as much as the figure, because Monero reports an invoice as confirming while its figures are still zero. A request that omits `seenPaid` holds on the status alone. | +| `POST /api/invoice/:id/cancel` | Invalidates an open invoice at the provider and expires it here. Refuses a settled or expired one with `not_open`, and one that already holds a payment with `funded`. The provider is told first, and a payment landing in between does not keep the invoice open: nothing can reach that address any more, so the row is expired either way and the poller settles or reports what arrived. | +| `POST /webhooks/btcpay` | Verifies `BTCPay-Sig` over the bytes as received and queues a read. A hint only: the poller is what carries authority, so an unverified or unreadable delivery costs nothing but a log line. | +| `POST /webhooks/stripe` | Verifies `Stripe-Signature` over the bytes as received and queues a read. The card lane's equivalent of the row above, and a hint just the same: the poller carries authority, so an unverified or unreadable delivery costs nothing but a log line. | + +Every `/api` refusal is `{"error": ""}`. Besides the codes above, any of them can answer +`internal`, an unknown id answers `not_found`, and a wrong verb answers `method_not_allowed` — +ten codes in all, which is what the browser's `WIRE_ERROR_CODES` lists. The two webhook routes are +the exception: each answers 200, 400 or 413 with an empty body, because its provider is the only +caller and nothing it could read would change what the route does. A wrong verb on any route, those +two included, answers `method_not_allowed`. + +### Redeeming over chat, for local testing + +```ini +[dev] +chat_redeem = on +``` + +With this on, the service accepts contact requests and answers `/redeem ` from a contact +with the credential as one-line JSON, ready to paste into a client as `/badge add `. Off by +default, and only `on`/`off` parse, so a typo cannot silently arm it. It applies to the service +mode only; `--run-cli` ignores it. + +Keep it off anywhere real. The service RPC signs over a master key only the client holds; here +there is no client key, so the service generates one and hands it over with the credential, which +means it can link every badge it issues this way. `simplex-chat badge sign` has the same property +and is the offline equivalent. + ## Issuing codes Issuing a code is an operator command sent to the running service in `--run-cli` mode, not a way @@ -51,10 +232,20 @@ to start it — so codes are issued without a second process touching the servic `months` defaults to 1 and must be between 1 and 255; the status defaults to `free` and records whether the code was sold (`paid`), is awaiting payment (`unpaid`), or was issued by an operator -(`free`) — redemption never reads it. +(`free`). Redemption refuses an `unpaid` code with `payment_pending`: the web checkout writes the +code row when the invoice is created, and settlement is what marks it paid. The code is printed once and only its `SHA-256` is stored, so a code that is not copied when it is shown cannot be recovered. +A code that leaked, or that was refunded, is withdrawn the same way: + +``` +//revoke +``` + +A revoked code answers redemption with `code_invalid`, as if it had never existed, so its holder +learns nothing from trying. Revoking is not repeatable: the second attempt says so. + Core parses `//...` into `CustomChatCommand` and leaves it to the service's `preCmdHook`, which is why issuing codes lives in the service rather than in core. diff --git a/apps/simplex-badge-service/badge_service.ini.example b/apps/simplex-badge-service/badge_service.ini.example new file mode 100644 index 0000000000..b46092eab8 --- /dev/null +++ b/apps/simplex-badge-service/badge_service.ini.example @@ -0,0 +1,56 @@ +[listener] +; bind locally; the reverse proxy terminates TLS. It must pass the query string through: +; the long poll's `wait`, `seenPaid` and `seenFull` all travel in it +host = 127.0.0.1 +port = 8080 +; required: the directory `npm run build` writes in apps/simplex-badge-service/web +static_dir = ./apps/simplex-badge-service/web/dist +; serve the webapp over HTTP. On (default) is the all-in-one deployment. Off is a split deployment +; where a reverse proxy serves the exported folder and this service is only the API and webhooks. +serve_webapp = on +; when set, the webapp is written here at boot with the publishable key injected, copied from +; static_dir, for a reverse proxy to serve. Leave unset in the all-in-one deployment. +; webapp_export_dir = /srv/webapp +; on behind the reverse proxy above: without it every request keys the rate limiter on the +; proxy's own address, so one bucket is shared by everyone. Set it off only where this +; listener is reached directly, since a client can write the header itself. +trust_forwarded_for = on + +; omit this whole section to disable Bitcoin and Monero (the browser shows the provider-unavailable screen) +[btcpay] +host = https://btcpay.example.org +api_key = replace-me +store_id = replace-me +webhook_secret = replace-me +expiry_minutes = 60 +speed_policy = MediumSpeed +payment_tolerance = 0.5 + +; omit this whole section to disable card payments (the browser shows the provider-unavailable screen) +[stripe] +; restricted key (rk_): Payment Intents write + Charges read — never a full secret key (sk_) +secret_key = rk_test_replace-me +publishable_key = pk_test_replace-me +; the signing secret of the /webhooks/stripe endpoint configured in the Dashboard +webhook_secret = whsec_replace-me +; minutes the service holds an unpaid card invoice open before it expires it; 31-1439 +session_minutes = 60 + +[poll] +waiting_seconds = 3 +idle_seconds = 60 + +; the keys this service may sign credentials with. key_ is the index clients verify against, +; and default names the one that signs, so a key here has to be one whose public half already +; ships in the apps: a fresh `simplex-chat badge keygen` pair is refused until it does. +; --issuer-key-idx and --issuer-secret override this section if both are given. +; list a key before rotating onto it: every key here is checked at startup, so this section +; stays commented out until it holds a real key. An unusable one here refuses the boot. +;[issuer] +;default = key_1 +;key_1 = replace-me + +; local testing only: signs a credential for anyone who sends /redeem over chat, +; with a master key this service generates and can therefore link +[dev] +chat_redeem = off diff --git a/apps/simplex-badge-service/src/BadgeService/Catalog.hs b/apps/simplex-badge-service/src/BadgeService/Catalog.hs new file mode 100644 index 0000000000..b15185da68 --- /dev/null +++ b/apps/simplex-badge-service/src/BadgeService/Catalog.hs @@ -0,0 +1,135 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} + +module BadgeService.Catalog + ( OfferInvalid (..), + CatalogRefusal (..), + offerTotal, + PricedOffer (..), + priceOffer, + catalogCurrency, + defaultCatalog, + ) +where + +import Data.List (find) +import Data.Text (Text) +import Data.Time.Clock (UTCTime) +import Data.Word (Word32, Word64, Word8) +import Simplex.Chat.Badges (BadgeType (..)) +import Simplex.Chat.Badges.Service (BadgeOffer (..), BadgePrice (..)) +import Simplex.Chat.Badges.Types (BadgeItemStatus (..), BadgeOfferId (..), BadgePriceId (..), OfferDiscount (..)) +import Simplex.Chat.PaymentService.Types (CurrencyAmount (..)) + +data OfferInvalid = OIZeroMonths | OIFreeMonthsExceedTerm | OIDiscountTooLarge | OIAmountUnsellable + deriving (Eq, Show) + +offerTotal :: CurrencyAmount -> Maybe BadgeOffer -> Either OfferInvalid (Word8, CurrencyAmount, CurrencyAmount) +offerTotal (CurrencyAmount p) = \case + Nothing -> charge 1 (gross 1) + Just BadgeOffer {months, discount} + | months == 0 -> Left OIZeroMonths + | otherwise -> case discount of + ODFreeMonths f + | f >= months -> Left OIFreeMonthsExceedTerm + | otherwise -> charge months (gross (months - f)) + ODDiscount d + | d >= 100 -> Left OIDiscountTooLarge + | otherwise -> charge months (gross months * (100 - fromIntegral d) `div` 100) + where + gross :: Word8 -> Word64 + gross m = fromIntegral p * fromIntegral m + maxAmount :: Word64 -- $1,000,000 in minor units + maxAmount = 100000000 + charge :: Word8 -> Word64 -> Either OfferInvalid (Word8, CurrencyAmount, CurrencyAmount) + charge m c + -- Bound gross too, not just the charge, or a large price wraps the Word32 amount field. + | c == 0 || c > maxAmount || gross m > maxAmount = Left OIAmountUnsellable + | otherwise = Right (m, CurrencyAmount (fromIntegral (gross m)), CurrencyAmount (fromIntegral c)) + +data PricedOffer = PricedOffer + { poBadgeType :: BadgeType, + poMonths :: Word8, + poPrice :: CurrencyAmount, + poAmount :: CurrencyAmount, + poCurrency :: Text + } + deriving (Eq, Show) + +data CatalogRefusal + = CRUnknownPrice + | CRDisabledPrice + | CRUnknownOffer + | CRDisabledOffer + | CROfferNotForPrice + | CRUnsoldBadgeType BadgeType + | CRUnpriced OfferInvalid + deriving (Eq, Show) + +priceOffer :: [BadgePrice] -> [BadgeOffer] -> BadgePriceId -> Maybe BadgeOfferId -> Either CatalogRefusal PricedOffer +priceOffer prices offers wantedPriceId wantedOfferId = do + BadgePrice {badgeType, monthPrice, currency, status = priceStatus} <- known CRUnknownPrice (findPrice wantedPriceId) + soldBadgeType badgeType + active CRDisabledPrice priceStatus + chosenOffer <- resolveOffer wantedPriceId wantedOfferId + (months, price, amount) <- either (Left . CRUnpriced) Right (offerTotal monthPrice chosenOffer) + pure PricedOffer {poBadgeType = badgeType, poMonths = months, poPrice = price, poAmount = amount, poCurrency = currency} + where + known refusal = maybe (Left refusal) Right + findPrice p = find (\BadgePrice {priceId} -> priceId == p) prices + findOffer o = find (\BadgeOffer {offerId} -> offerId == o) offers + soldBadgeType bt + | bt == BTSupporter || bt == BTLegend = Right () + | otherwise = Left (CRUnsoldBadgeType bt) + active _ BISActive = Right () + active _ BISDeprecated = Right () + active refusal BISDisabled = Left refusal + resolveOffer _ Nothing = Right Nothing + resolveOffer p (Just o) = do + chosen@BadgeOffer {priceId = offerPriceId, status = offerStatus} <- known CRUnknownOffer (findOffer o) + active CRDisabledOffer offerStatus + case offerPriceId of + Nothing -> Right (Just chosen) + Just op + | op == p -> Right (Just chosen) + | otherwise -> Left CROfferNotForPrice + +catalogCurrency :: Text +catalogCurrency = "usd" + +-- | Mirrors web/src/catalog.ts; seeded insert-only, so repricing needs a new price id. +defaultCatalog :: UTCTime -> ([BadgePrice], [BadgeOffer]) +defaultCatalog seededAt = (prices, offers) + where + prices = + [ mkPrice "price_supporter" BTSupporter 700, + mkPrice "price_legend" BTLegend 7000 + ] + offers = + [ mkOffer "offer_3m" "price_legend" 3 (ODFreeMonths 1), + mkOffer "offer_12m" "price_legend" 12 (ODDiscount 50), + mkOffer "offer_3m_s" "price_supporter" 3 (ODFreeMonths 1), + mkOffer "offer_12m_s" "price_supporter" 12 (ODDiscount 50) + ] + mkPrice :: Text -> BadgeType -> Word32 -> BadgePrice + mkPrice pId bType mPrice = + BadgePrice + { priceId = BadgePriceId pId, + badgeType = bType, + monthPrice = CurrencyAmount mPrice, + currency = catalogCurrency, + status = BISActive, + createdAt = seededAt + } + mkOffer :: Text -> Text -> Word8 -> OfferDiscount -> BadgeOffer + mkOffer oId pId mMonths mDiscount = + BadgeOffer + { offerId = BadgeOfferId oId, + priceId = Just (BadgePriceId pId), + months = mMonths, + discount = mDiscount, + status = BISActive, + createdAt = seededAt + } diff --git a/apps/simplex-badge-service/src/BadgeService/Config.hs b/apps/simplex-badge-service/src/BadgeService/Config.hs new file mode 100644 index 0000000000..7b0f554438 --- /dev/null +++ b/apps/simplex-badge-service/src/BadgeService/Config.hs @@ -0,0 +1,312 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module BadgeService.Config + ( ListenerConfig (..), + BTCPayConfig (..), + StripeConfig (..), + SpeedPolicy (..), + speedPolicyName, + PollConfig (..), + IssuerConfig (..), + ServiceConfig (..), + defaultExpiryMinutes, + defaultSessionMinutes, + readServiceConfig, + unknownKeys, + ) +where + +import qualified Control.Exception as E +import BadgeService.Log (logWarn) +import Data.Attoparsec.Text (Parser, endOfInput, isEndOfLine, parseOnly, satisfy, skipMany, skipSpace, skipWhile) +import qualified Data.ByteString.Char8 as B +import Data.Ini (Ini, iniGlobals, iniParser, keys, lookupValue, sections) +import Data.List (sort) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as M +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.IO as TIO +import Simplex.Messaging.Crypto.BBS (BBSSecretKey) +import Simplex.Messaging.Encoding.String (strDecode) +import System.IO.Error (ioeGetErrorString) +import Text.Read (readMaybe) + +data ListenerConfig = ListenerConfig + { lHost :: Text, + lPort :: Int, + lStaticDir :: FilePath, + lServeWebapp :: Bool, + lWebappExportDir :: Maybe FilePath, + lTrustForwardedFor :: Bool + } + deriving (Eq, Show) + +-- | Sent by name, since BTCPay's numbering is not in speed order. +data SpeedPolicy = HighSpeed | MediumSpeed | LowMediumSpeed | LowSpeed + deriving (Bounded, Enum, Eq, Show) + +speedPolicies :: [SpeedPolicy] +speedPolicies = [minBound .. maxBound] + +speedPolicyName :: SpeedPolicy -> Text +speedPolicyName = \case + HighSpeed -> "HighSpeed" + MediumSpeed -> "MediumSpeed" + LowMediumSpeed -> "LowMediumSpeed" + LowSpeed -> "LowSpeed" + +data BTCPayConfig = BTCPayConfig + { bHost :: Text, + bApiKey :: Text, + bStoreId :: Text, + bWebhookSecret :: Text, + bExpiryMinutes :: Int, + bSpeedPolicy :: SpeedPolicy, + bPaymentTolerance :: Double + } + deriving (Eq) + +-- Hand-written to keep the api key and webhook secret out of logs. +instance Show BTCPayConfig where + show BTCPayConfig {bHost, bStoreId} = "btcpay " <> T.unpack bHost <> " store " <> T.unpack bStoreId + +data StripeConfig = StripeConfig + { sSecretKey :: Text, + sPublishableKey :: Text, + sWebhookSecret :: Text, + sSessionMinutes :: Int, + sHost :: Text + } + deriving (Eq) + +-- Hand-written to keep the restricted key and signing secret out of logs. +instance Show StripeConfig where + show StripeConfig {sHost} = "stripe " <> T.unpack sHost + +data PollConfig = PollConfig {pWaitingSeconds :: Int, pIdleSeconds :: Int} + deriving (Eq, Show) + +-- | Only iDefaultIdx signs; the rest are listed so rotation is a config change. +data IssuerConfig = IssuerConfig + { iKeys :: Map Int BBSSecretKey, + iDefaultIdx :: Int + } + deriving (Eq) + +-- Hand-written, since BBSSecretKey's derived Show would print the secrets. +instance Show IssuerConfig where + show IssuerConfig {iKeys, iDefaultIdx} = + "issuer keys " <> show (M.keys iKeys) <> ", signing with " <> show iDefaultIdx + +data ServiceConfig = ServiceConfig + { listener :: ListenerConfig, + btcpay :: Maybe BTCPayConfig, + stripe :: Maybe StripeConfig, + poll :: PollConfig, + issuer :: Maybe IssuerConfig, + -- Local testing only; signs credentials with a master key this service can link. + devChatRedeem :: Bool + } + deriving (Eq, Show) + +defaultExpiryMinutes :: Int +defaultExpiryMinutes = 60 + +defaultStripeHost :: Text +defaultStripeHost = "https://api.stripe.com" + +defaultSessionMinutes :: Int +defaultSessionMinutes = 60 + +-- | Stripe bounds session expiry to 30 minutes through 24 hours; these sit a minute inside, +-- so request latency or a service clock ahead of Stripe's cannot 400 an at-bound create. +minSessionMinutes, maxSessionMinutes :: Int +minSessionMinutes = 31 +maxSessionMinutes = 1439 + +-- | An http host would carry the API key in the clear on every call. +requireHttps :: Text -> Either String Text +requireHttps u + | "https://" `T.isPrefixOf` u = Right u + | otherwise = Left "btcpay.host must be an absolute https URL" + +-- | Well below 100, where BTCPay settles an invoice for one satoshi. +maxTolerance :: Double +maxTolerance = 10 + +readServiceConfig :: FilePath -> IO (Either String ServiceConfig) +readServiceConfig path = + E.try (TIO.readFile path) >>= \case + Left (e :: E.IOException) -> pure (Left (ioeGetErrorString e)) + -- Data.Ini stops at the first unparseable line and keeps what it has, so a missing `=` silently drops every section below. + Right text -> case parseOnly (iniParser <* trailingNoise <* endOfInput) text of + Left _ -> pure (Left "could not be read as an ini file: a line is malformed") + Right ini -> do + mapM_ (\k -> logWarn (T.pack path <> ": nothing reads " <> k <> ", so it was ignored")) (unknownKeys ini) + pure (parseConfig ini) + +-- | iniParser stops before a trailing comment, so endOfInput alone would reject a valid file. +trailingNoise :: Parser () +trailingNoise = skipSpace *> skipMany (comment *> skipSpace) + where + comment = satisfy (\c -> c == ';' || c == '#') *> skipWhile (not . isEndOfLine) + +-- | [issuer] is absent because its keys are key_ and it does its own stricter check. +knownSettings :: [(Text, [Text])] +knownSettings = + [ ("listener", ["host", "port", "static_dir", "serve_webapp", "webapp_export_dir", "trust_forwarded_for"]), + ("btcpay", ["host", "api_key", "store_id", "webhook_secret", "expiry_minutes", "speed_policy", "payment_tolerance"]), + ("stripe", ["secret_key", "publishable_key", "webhook_secret", "session_minutes"]), + ("poll", ["waiting_seconds", "idle_seconds"]), + ("dev", ["chat_redeem"]) + ] + +unknownKeys :: Ini -> [Text] +unknownKeys ini = beforeAnySection <> unknownSections <> settings + where + beforeAnySection = [k <> ", written above the first section header" | (k, _) <- iniGlobals ini] + ours = map fst knownSettings <> ["issuer"] + unknownSections = ["[" <> s <> "]" | s <- sections ini, T.strip s `notElem` ours] + settings = + [ section <> "." <> key + | (section, known) <- knownSettings, + key <- either (const []) id (keys section ini), + T.strip key `notElem` known + ] + +parseConfig :: Ini -> Either String ServiceConfig +parseConfig ini = do + lStaticDir <- T.unpack <$> required "listener" "static_dir" + lHost <- optional "listener" "host" "127.0.0.1" + lPort <- do + p <- num "listener" "port" 8080 + if 1 <= p && p <= 65535 then Right p else Left "listener.port must be between 1 and 65535" + lServeWebapp <- bool "listener" "serve_webapp" True + let lWebappExportDir = case fmap T.strip (look "listener" "webapp_export_dir") of + Just v | not (T.null v) -> Just (T.unpack v) + _ -> Nothing + lTrustForwardedFor <- bool "listener" "trust_forwarded_for" False + btc <- btcpaySection + str <- stripeSection + iss <- issuerSection + pWaitingSeconds <- cadence "waiting_seconds" 3 + pIdleSeconds <- cadence "idle_seconds" 60 + devRedeem <- bool "dev" "chat_redeem" False + pure + ServiceConfig + { listener = ListenerConfig {lHost, lPort, lStaticDir, lServeWebapp, lWebappExportDir, lTrustForwardedFor}, + btcpay = btc, + stripe = str, + poll = PollConfig {pWaitingSeconds, pIdleSeconds}, + issuer = iss, + devChatRedeem = devRedeem + } + where + hasSection s = s `elem` sections ini + look s k = either (const Nothing) Just (lookupValue s k ini) + required s k = case look s k of + Just v | not (T.null (T.strip v)) -> Right (T.strip v) + _ -> Left (T.unpack s <> "." <> T.unpack k <> " is required") + optional s k d = case fmap T.strip (look s k) of + Just v | not (T.null v) -> Right v + _ -> Right d + -- Integer, because readMaybe at Int wraps silently, reading 2^64+4 as 4. + num s k d = case look s k of + Nothing -> Right d + Just v -> case readMaybe (T.unpack (T.strip v)) of + Just n | n >= toInteger (minBound :: Int), n <= toInteger (maxBound :: Int) -> Right (fromInteger n) + _ -> Left (T.unpack k <> " must be a whole number") + bool s k d = case fmap (T.toLower . T.strip) (look s k) of + Nothing -> Right d + Just "on" -> Right True + Just "off" -> Right False + Just other -> Left (T.unpack k <> " must be on or off, not " <> T.unpack other) + -- num accepts 0 and negatives, and a zero cadence is a busy loop. + cadence k d = do + v <- num "poll" k d + if v >= 1 then Right v else Left ("poll." <> T.unpack k <> " must be at least 1 second") + issuerSection + | not (hasSection "issuer") = Right Nothing + | otherwise = do + entries <- either (const (Left "[issuer] could not be read")) Right (keys "issuer" ini) + let named = sort [T.strip e | e <- entries] + mapM_ knownEntry named + ks <- M.fromList <$> mapM issuerKey [e | e <- named, e /= "default"] + if M.null ks + then Left "[issuer] lists no key_, so the service has nothing to sign with" + else do + d <- required "issuer" "default" + idx <- keyIndex d + if M.member idx ks + then Right (Just IssuerConfig {iKeys = ks, iDefaultIdx = idx}) + else Left ("issuer.default names " <> T.unpack d <> ", which is not listed in [issuer]") + -- Refuse anything else, so a mistyped key_1 fails at boot instead of signing with an unintended key. + knownEntry e + | e == "default" = Right () + | "key_" `T.isPrefixOf` e = () <$ keyIndex e + | otherwise = Left ("[issuer] has no setting " <> T.unpack e <> "; expected default or key_") + -- key_01 and key_1 would otherwise both read as 1 and collapse in the map, dropping a secret. + keyIndex :: Text -> Either String Int + keyIndex e = case T.stripPrefix "key_" e of + Just written + | Just n <- readMaybe (T.unpack written), + n > 0, + n <= toInteger (maxBound :: Int), + T.pack (show n) == written -> + Right (fromInteger n) + _ -> Left ("[issuer] " <> T.unpack e <> " must be named key_, with n a positive whole number") + issuerKey e = do + idx <- keyIndex e + raw <- required "issuer" e + case strDecode (B.pack (T.unpack raw)) of + Right sk -> Right (idx, sk) + Left _ -> Left ("issuer." <> T.unpack e <> " is not a valid issuer secret; use the value from `simplex-chat badge keygen`") + btcpaySection + | not (hasSection "btcpay") = Right Nothing + | otherwise = do + bHost <- required "btcpay" "host" >>= requireHttps + bApiKey <- required "btcpay" "api_key" + bStoreId <- required "btcpay" "store_id" + bWebhookSecret <- required "btcpay" "webhook_secret" + bExpiryMinutes <- expiryMinutes + bSpeedPolicy <- speedPolicy + bPaymentTolerance <- tolerance + pure (Just BTCPayConfig {bHost, bApiKey, bStoreId, bWebhookSecret, bExpiryMinutes, bSpeedPolicy, bPaymentTolerance}) + -- A negative window puts BTCPay's startDate in the future, so every poll comes back empty. + expiryMinutes = do + v <- num "btcpay" "expiry_minutes" defaultExpiryMinutes + if v >= 1 then Right v else Left "btcpay.expiry_minutes must be at least 1 minute" + speedPolicy = case look "btcpay" "speed_policy" of + Nothing -> Right MediumSpeed + Just v -> case lookup (T.strip v) [(speedPolicyName p, p) | p <- speedPolicies] of + Just p -> Right p + Nothing -> + Left + ( "btcpay.speed_policy must be one of " + <> T.unpack (T.intercalate ", " (map speedPolicyName speedPolicies)) + <> ", not " + <> T.unpack (T.strip v) + ) + tolerance = case look "btcpay" "payment_tolerance" of + Nothing -> Right 0.5 + Just v -> case readMaybe (T.unpack (T.strip v)) of + Just d | d >= 0 && d <= maxTolerance -> Right d + _ -> Left ("btcpay.payment_tolerance must be a percentage between 0 and " <> show maxTolerance) + stripeSection + | not (hasSection "stripe") = Right Nothing + | otherwise = do + sSecretKey <- required "stripe" "secret_key" + sPublishableKey <- required "stripe" "publishable_key" + sWebhookSecret <- required "stripe" "webhook_secret" + sSessionMinutes <- sessionMinutes + let sHost = defaultStripeHost + pure (Just StripeConfig {sSecretKey, sPublishableKey, sWebhookSecret, sSessionMinutes, sHost}) + sessionMinutes = do + v <- num "stripe" "session_minutes" defaultSessionMinutes + if v >= minSessionMinutes && v <= maxSessionMinutes + then Right v + else Left ("stripe.session_minutes must be between " <> show minSessionMinutes <> " and " <> show maxSessionMinutes <> " minutes") diff --git a/apps/simplex-badge-service/src/BadgeService/Log.hs b/apps/simplex-badge-service/src/BadgeService/Log.hs new file mode 100644 index 0000000000..a2f54f4420 --- /dev/null +++ b/apps/simplex-badge-service/src/BadgeService/Log.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | The SMP agent logs unconditionally at info on the global logger, so the service keeps its own info lines on this separate channel when that logger is raised to Warn. +module BadgeService.Log + ( logInfo, + logWarn, + logError, + ) +where + +import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.IO as T +import Data.Time.Format (defaultTimeLocale, formatTime) +import Data.Time.LocalTime (getZonedTime) +import GHC.Stack (CallStack, HasCallStack, callStack, getCallStack, srcLocFile, srcLocStartLine) +import System.IO (stderr) + +logInfo :: (HasCallStack, MonadIO m) => Text -> m () +logInfo = logAt "INFO" callStack + +logWarn :: (HasCallStack, MonadIO m) => Text -> m () +logWarn = logAt "WARN" callStack + +logError :: (HasCallStack, MonadIO m) => Text -> m () +logError = logAt "ERROR" callStack + +logAt :: MonadIO m => Text -> CallStack -> Text -> m () +logAt tag cs msg = liftIO $ do + ts <- formatTime defaultTimeLocale "%Y-%m-%d %H:%M:%S %z" <$> getZonedTime + T.hPutStrLn stderr $ "[" <> tag <> " " <> T.pack ts <> " " <> loc <> "] " <> msg + where + loc = case getCallStack cs of + ((_, l) : _) -> T.pack (srcLocFile l) <> ":" <> T.pack (show (srcLocStartLine l)) + [] -> "unknown" diff --git a/apps/simplex-badge-service/src/BadgeService/Options.hs b/apps/simplex-badge-service/src/BadgeService/Options.hs index a2cd46fd84..80990b0e23 100644 --- a/apps/simplex-badge-service/src/BadgeService/Options.hs +++ b/apps/simplex-badge-service/src/BadgeService/Options.hs @@ -26,12 +26,11 @@ data BadgeServiceOpts = BadgeServiceOpts clientService :: Bool, noAddress :: Bool, runCLI :: Bool, - -- the service refuses to start without this: it cannot sign a credential - issuerKey :: Maybe BadgeIssuerKey, + serviceConfigFile :: Maybe FilePath, + issuerKey :: Either String (Maybe BadgeIssuerKey), testing :: Bool } --- | The issuer secret that signs credentials, and the index the apps find its public half under. data BadgeIssuerKey = BadgeIssuerKey { keyIdx :: Int, secretKey :: BBSSecretKey @@ -66,6 +65,14 @@ badgeServiceOpts appDir defaultDbName = do ( long "run-cli" <> help "Run badge service as CLI" ) + serviceConfigFile <- + optional + ( strOption + ( long "service-config" + <> metavar "INI_FILE" + <> help "Path to badge_service.ini: parsed in full in every mode, but --run-cli starts no web listener" + ) + ) issuerKeyIdx <- optional $ option @@ -89,7 +96,11 @@ badgeServiceOpts appDir defaultDbName = do clientService, noAddress, runCLI, - issuerKey = BadgeIssuerKey <$> issuerKeyIdx <*> issuerSecret, + serviceConfigFile, + issuerKey = case (issuerKeyIdx, issuerSecret) of + (Just idx, Just secret) -> Right (Just (BadgeIssuerKey idx secret)) + (Nothing, Nothing) -> Right Nothing + _ -> Left "--issuer-key-idx and --issuer-secret are given together or not at all", testing = False } diff --git a/apps/simplex-badge-service/src/BadgeService/Orders.hs b/apps/simplex-badge-service/src/BadgeService/Orders.hs new file mode 100644 index 0000000000..63359b0880 --- /dev/null +++ b/apps/simplex-badge-service/src/BadgeService/Orders.hs @@ -0,0 +1,117 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} + +module BadgeService.Orders (settleOrder, decide, codeLifetime) where + +import BadgeService.Providers (Funded (..), PaymentSignal (..), Received (..)) +import BadgeService.Store.Invoices (InvoicePayment (..), InvoiceRow (..), markCodePaid, paymentStatusText, settlementCodeHash, settlementInvoice, truncateToSecond, updateInvoiceStatus, upsertPayment) +import BadgeService.Waiters (Waiters, publish, publishPayment) +import Control.Concurrent.STM (atomically) +import Control.Monad (when) +import Data.ByteString (ByteString) +import Data.Maybe (fromMaybe) +import Data.Text (Text) +import Data.Time.Clock (NominalDiffTime, UTCTime, addUTCTime) +import Simplex.Chat.PaymentService.Types (CurrencyAmount (..), InvoiceId, InvoiceStatus (..), PaymentStatus (..)) +import Simplex.Messaging.Agent.Store.Common (DBStore, withTransaction) +import qualified Simplex.Messaging.Agent.Store.DB as DB + +-- | Written onto the row at settlement and read back, so changing it moves only codes sold afterwards. +codeLifetime :: NominalDiffTime +codeLifetime = 365 * 24 * 60 * 60 + +data Write = Write + { wStatus :: Maybe InvoiceStatus, + wPayment :: PaymentStatus, + wCode :: Bool + } + +decide :: InvoiceStatus -> PaymentSignal -> Maybe Write +decide ISPaid _ = Nothing +decide _ SigSettled {} = Just Write {wStatus = Just ISPaid, wPayment = PSSettled, wCode = True} +decide _ SigFunded {} = Just Write {wStatus = Nothing, wPayment = PSPending, wCode = False} +decide ISOpen SigClosed {} = Just Write {wStatus = Just ISExpired, wPayment = PSPending, wCode = False} +decide ISExpired SigClosed {} = Just Write {wStatus = Nothing, wPayment = PSPending, wCode = False} + +paidInFull :: PaymentSignal -> Bool +paidInFull = \case + SigFunded _ f -> f == PaidInFull + SigSettled {} -> True + SigClosed {} -> False + +received :: PaymentSignal -> Received +received = \case + SigFunded r _ -> r + SigSettled r _ -> r + SigClosed r -> r + +-- | Uses the provider's settlement instant, not now, so an outage does not push deadlines out; +-- an implausible value (zero, milliseconds, negative) falls back to now. +settledInstant :: PaymentSignal -> UTCTime -> UTCTime +settledInstant signal now = case signal of + SigSettled _ at | at <= now, at >= addUTCTime (negate maxBackdate) now -> at + _ -> now + +-- | Longer than any outage the poller must survive, far short of the code's lifetime. +maxBackdate :: NominalDiffTime +maxBackdate = 30 * 24 * 60 * 60 + +data Published = PubNothing | PubStatus InvoiceStatus | PubPayment + +settleOrder :: DBStore -> Waiters -> InvoiceId -> PaymentSignal -> UTCTime -> IO (Either Text InvoiceStatus) +settleOrder st waiters invId signal now' = do + outcome <- withTransaction st $ \db -> + settlementInvoice db invId >>= \case + Nothing -> pure (Left "no such invoice") + Just row@InvoiceRow {irStatus} -> case decide irStatus signal of + Nothing -> pure (Right (irStatus, PubNothing)) + -- look up the code first, so an invoice with none leaves the transaction empty, not paid with an unpaid code + Just w -> codeToMark db w >>= either (pure . Left) (settle db row w) + case outcome of + Left e -> pure (Left e) + Right (status, toPublish) -> do + -- after the commit, or a woken reader will not see the write + atomically $ case toPublish of + PubStatus s -> publish waiters invId s + PubPayment -> publishPayment waiters invId + PubNothing -> pure () + pure (Right status) + where + now = truncateToSecond now' + at = truncateToSecond (settledInstant signal now) + codeToMark :: DB.Connection -> Write -> IO (Either Text (Maybe ByteString)) + codeToMark db Write {wCode} + | not wCode = pure (Right Nothing) + | otherwise = maybe (Left "settled invoice has no code hash") (Right . Just) <$> settlementCodeHash db invId + newPayment :: InvoiceRow -> Write -> Bool + newPayment InvoiceRow {irPayment} Write {wPayment} + -- Monero reports an invoice as confirming while its figures are still zero, so a funded verdict earns a row + | not (paidInFull signal) && rcvCrypto == Nothing && rcvAmount == CurrencyAmount 0 = False + | otherwise = case irPayment of + Nothing -> True + -- the write is monotonic, so a lower figure or withdrawn verdict is not a new payment + Just InvoicePayment {ipAmount, ipCryptoPaid, ipPaidInFull, ipStatus} + | ipStatus == paymentStatusText PSSettled -> False + | otherwise -> + maybe True (\(CurrencyAmount held) -> held < minor) ipAmount + || (ipCryptoPaid == Nothing && rcvCrypto /= Nothing) + || (paidInFull signal && not ipPaidInFull) + || ipStatus /= paymentStatusText wPayment + where + Received {rcvAmount, rcvCrypto} = received signal + CurrencyAmount minor = rcvAmount + settle :: DB.Connection -> InvoiceRow -> Write -> Maybe ByteString -> IO (Either Text (InvoiceStatus, Published)) + settle db row@InvoiceRow {irStatus} w@Write {wStatus, wPayment} codeHash = do + let Received {rcvAmount, rcvCrypto, rcvDue} = received signal + wrotePayment = newPayment row w + when wrotePayment $ upsertPayment db row wPayment rcvAmount rcvCrypto rcvDue (paidInFull signal) at + moved <- maybe (pure True) (\new -> updateInvoiceStatus db invId irStatus new at) wStatus + if moved + then do + mapM_ (\h -> markCodePaid db h (addUTCTime codeLifetime at)) codeHash + pure (Right (fromMaybe irStatus wStatus, maybe (if wrotePayment then PubPayment else PubNothing) PubStatus wStatus)) + else do + -- another writer moved the row first, so publish what we found + current <- maybe irStatus (\InvoiceRow {irStatus = s} -> s) <$> settlementInvoice db invId + pure (Right (current, PubStatus current)) diff --git a/apps/simplex-badge-service/src/BadgeService/Poller.hs b/apps/simplex-badge-service/src/BadgeService/Poller.hs new file mode 100644 index 0000000000..f09c856806 --- /dev/null +++ b/apps/simplex-badge-service/src/BadgeService/Poller.hs @@ -0,0 +1,313 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module BadgeService.Poller + ( PollerEnv (..), + ReadHints, + newReadHints, + queueReadHint, + hintQueueSize, + newPollerEnv, + runOnePass, + drainHints, + passDue, + runPoller, + passDelay, + SkipOwner (..), + skipOwner, + dueToWarn, + expiryGrace, + readsPerPass, + skipWarnInterval, + maxSkipReasons, + ) +where + +import BadgeService.Config (PollConfig (..)) +import BadgeService.Orders (decide, settleOrder) +import BadgeService.Providers (ListPass (..), PaymentSignal (..), Provider (..), ProviderError (..), Received (..), settleWindow) +import BadgeService.Store.Invoices (InvoiceRow (..), expireOverdue, getInvoiceByProviderRef, providerText, unpaidRefs) +import BadgeService.Waiters (Waiters, publish, waitingCount, waitingCountSTM) +import Control.Concurrent.STM +import Control.Exception (SomeAsyncException, SomeException, fromException, throwIO, try) +import BadgeService.Log (logError, logInfo, logWarn) +import Control.Monad (forever, unless, void, when) +import Data.List (find, sortOn) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as M +import Data.Maybe (fromMaybe, isJust) +import Data.Text (Text) +import Data.Time.Clock (NominalDiffTime, UTCTime, addUTCTime, diffUTCTime, getCurrentTime) +import Numeric.Natural (Natural) +import Simplex.Chat.PaymentService.Types (InvoiceStatus (..), PaymentProvider) +import Simplex.Messaging.Agent.Store.Common (DBStore) +import Simplex.Messaging.Util (tshow) + +-- | Allows for our clock running ahead of the provider's; an expired invoice can still be marked paid. +expiryGrace :: NominalDiffTime +expiryGrace = 600 + +skipWarnInterval :: NominalDiffTime +skipWarnInterval = 3600 + +maxSkipReasons :: Int +maxSkipReasons = 4096 + +-- | A queue, not a call, so settlement stays on this one thread. +newtype ReadHints = ReadHints (TBQueue Text) + +hintQueueSize :: Natural +hintQueueSize = 256 + +newReadHints :: IO ReadHints +newReadHints = ReadHints <$> newTBQueueIO hintQueueSize + +queueReadHint :: ReadHints -> Text -> IO Bool +queueReadHint (ReadHints q) ref = atomically $ do + full <- isFullTBQueue q + if full then pure False else True <$ writeTBQueue q ref + +minCadenceSeconds :: Int +minCadenceSeconds = 1 + +data PollerEnv = PollerEnv + { peStore :: DBStore, + peWaiters :: Waiters, + peHints :: ReadHints, + peProviders :: [Provider], + pePoll :: PollConfig, + peSkipped :: TVar (Map Text UTCTime), + peListedAt :: TVar (Maybe UTCTime), + peStrayEvery :: NominalDiffTime + } + +newPollerEnv :: DBStore -> Waiters -> ReadHints -> [Provider] -> PollConfig -> IO PollerEnv +newPollerEnv peStore peWaiters peHints peProviders pePoll = do + peSkipped <- newTVarIO M.empty + peListedAt <- newTVarIO Nothing + pure PollerEnv {peStore, peWaiters, peHints, peProviders, pePoll, peSkipped, peListedAt, peStrayEvery = strayListInterval} + +-- | Read providers before the sweep, and skip the sweep entirely when a read failed, so an +-- invoice with money in it is never expired. +runOnePass :: PollerEnv -> IO () +runOnePass env@PollerEnv {peStore, peProviders} = do + now <- getCurrentTime + rows <- unpaidRefs peStore (addUTCTime (negate settleWindow) now) + let bulk = length rows > readsPerPass + listNow <- listDue env now bulk + accounted <- + if bulk + then do + covered <- and <$> mapM (rowIsCovered env now) rows + (covered &&) . and <$> mapM (listPass env now) peProviders + else do + read' <- readRows env now rows + when listNow $ mapM_ (listPass env now) peProviders + pure read' + pruneSkipLog env now + when (accounted && not (null peProviders)) $ sweepExpired env now + +-- | The cases the stray list catches are rare and not urgent, so minutes, not the pass cadence. +strayListInterval :: NominalDiffTime +strayListInterval = 60 + +listDue :: PollerEnv -> UTCTime -> Bool -> IO Bool +listDue PollerEnv {peListedAt, peStrayEvery} now forced = atomically $ do + last' <- readTVar peListedAt + let due = forced || maybe True (\at -> diffUTCTime now at >= peStrayEvery) last' + when due $ writeTVar peListedAt (Just now) + pure due + +-- | Past this many open invoices one list is fewer bytes and requests than reading each. +readsPerPass :: Int +readsPerPass = 25 + +coveringProvider :: PollerEnv -> UTCTime -> (Text, Text) -> IO (Maybe Provider) +coveringProvider env@PollerEnv {peProviders} now (provider, ref) = + case find ((== provider) . providerText . pProvider) peProviders of + Just p -> pure (Just p) + Nothing -> do + due <- dueToWarn env now ("no provider for " <> provider) + when due $ logError ("badge poller: invoice " <> ref <> " names provider " <> provider <> ", which this build has none of") + pure Nothing + +rowIsCovered :: PollerEnv -> UTCTime -> (Text, Text) -> IO Bool +rowIsCovered env now row = isJust <$> coveringProvider env now row + +readRows :: PollerEnv -> UTCTime -> [(Text, Text)] -> IO Bool +readRows env now rows = + and <$> mapM (\r -> safelyWith (readWhat r) False (readRow r)) rows + where + readWhat (provider, ref) = "reading " <> provider <> " invoice " <> ref + readRow row@(_, ref) = coveringProvider env now row >>= maybe (pure False) (`readOne` ref) + readOne p ref = + pReadInvoice p ref >>= \case + Left (ProviderError e) -> do + due <- dueToWarn env now ("read failed: " <> tshow (pProvider p)) + when due $ logWarn ("badge poller: " <> tshow (pProvider p) <> " reads are failing; every invoice waits for the next pass: " <> e) + pure False + Right Nothing -> pure True + Right (Just signal) -> True <$ settleMoved env (pProvider p) now (ref, signal) + +-- | False when the pass cannot account for every invoice sold, so the sweep does not expire one +-- over money it missed. +listPass :: PollerEnv -> UTCTime -> Provider -> IO Bool +listPass env now p = + pListOpen p >>= \case + Left (ProviderError e) -> do + due <- dueToWarn env now ("list failed: " <> tshow (pProvider p)) + when due $ logWarn ("badge poller: " <> tshow (pProvider p) <> " list failed; every invoice waits for the next pass: " <> e) + pure False + Right ListPass {lpMoved, lpSkipped} -> do + owners <- mapM (\s -> safelyWith (skipWhat s) SkipUnaccounted (reportSkip env (pProvider p) now s)) lpSkipped + settled <- mapM (\m -> safely (settleWhat m) (settleMoved env (pProvider p) now m)) lpMoved + pure (all (== SkipStranger) owners && and settled) + where + settleWhat (ref, _) = "settling " <> tshow (pProvider p) <> " invoice " <> ref + skipWhat (ref, _) = "reading the skipped " <> tshow (pProvider p) <> " invoice " <> fromMaybe "the provider did not name" ref + +-- | provider_ref is unique table-wide, not per provider, so check the provider too. +settleMoved :: PollerEnv -> PaymentProvider -> UTCTime -> (Text, PaymentSignal) -> IO () +settleMoved env@PollerEnv {peStore, peWaiters} provider now (ref, signal) = + getInvoiceByProviderRef peStore ref >>= \case + Just InvoiceRow {irInvoiceId, irStatus, irProvider} | irProvider == provider -> + when (isJust (decide irStatus signal)) $ + settleOrder peStore peWaiters irInvoiceId signal now >>= \case + Left e -> logError ("badge poller: settling order " <> ref <> " failed: " <> e) + Right status -> reportSettled irStatus status + _ -> pure () + where + reportSettled before after + -- checked before the no-change case, so a refund still alerts when money lands after expiry + | after == ISExpired, SigClosed Received {rcvCrypto = Just paid} <- signal = do + let alert = "badge poller: order " <> ref <> " expired holding " <> paid <> ", which needs a refund" + due <- dueToWarn env now alert + when due $ logError alert + | before == after = pure () + | otherwise = logInfo ("badge poller: order " <> ref <> " " <> tshow before <> " -> " <> tshow after) + +serveHint :: PollerEnv -> Text -> IO () +serveHint env ref = do + now <- getCurrentTime + hintSafely env now ref + +readHint :: PollerEnv -> UTCTime -> Text -> IO () +readHint env@PollerEnv {peStore, peProviders} now ref = + getInvoiceByProviderRef peStore ref >>= \case + Nothing -> pure () + Just InvoiceRow {irProvider} -> case find ((== irProvider) . pProvider) peProviders of + Nothing -> pure () + Just p -> + pReadInvoice p ref >>= \case + Left (ProviderError e) -> + logWarn ("badge poller: the hinted read of " <> ref <> " failed; the next pass will run: " <> e) + Right Nothing -> pure () + Right (Just signal) -> settleMoved env irProvider now (ref, signal) + +sweepExpired :: PollerEnv -> UTCTime -> IO () +sweepExpired PollerEnv {peStore, peWaiters} now = do + expired <- expireOverdue peStore (addUTCTime (negate expiryGrace) now) + -- publish only after the write commits, or a woken reader will not see it + unless (null expired) $ do + atomically $ mapM_ (\invId -> publish peWaiters invId ISExpired) expired + logInfo ("badge poller: expired " <> tshow (length expired) <> " invoice(s) past their window") + +data SkipOwner + = SkipOurs + | SkipStranger + | -- | The provider named no invoice, so this skip could be any of ours. + SkipUnaccounted + deriving (Eq, Show) + +skipOwner :: PollerEnv -> PaymentProvider -> Maybe Text -> IO SkipOwner +skipOwner PollerEnv {peStore} provider = \case + Nothing -> pure SkipUnaccounted + Just ref -> + getInvoiceByProviderRef peStore ref >>= \case + Just InvoiceRow {irProvider} | irProvider == provider -> pure SkipOurs + _ -> pure SkipStranger + +reportSkip :: PollerEnv -> PaymentProvider -> UTCTime -> (Maybe Text, Text) -> IO SkipOwner +reportSkip env provider now (ref, reason) = do + owner <- skipOwner env provider ref + due <- dueToWarn env now reason + when due $ case owner of + SkipOurs -> logError ("badge poller: an invoice this service sold was not read, so its payment cannot be detected: " <> reason) + SkipUnaccounted -> logError ("badge poller: part of the window was not read, so a payment to any invoice in it cannot be detected: " <> reason) + SkipStranger -> logWarn ("badge poller: the list pass could not read everything: " <> reason) + pure owner + +dueToWarn :: PollerEnv -> UTCTime -> Text -> IO Bool +dueToWarn PollerEnv {peSkipped} now reason = atomically $ do + seen <- readTVar peSkipped + let due = case M.lookup reason seen of + Nothing -> True + Just at -> diffUTCTime now at >= skipWarnInterval + when due $ writeTVar peSkipped (M.insert reason now seen) + pure due + +pruneSkipLog :: PollerEnv -> UTCTime -> IO () +pruneSkipLog PollerEnv {peSkipped} now = atomically $ modifyTVar' peSkipped prune + where + prune seen + | M.size seen <= maxSkipReasons = seen + | M.size fresh <= maxSkipReasons = fresh + | otherwise = M.fromList (drop (M.size fresh - maxSkipReasons) (sortOn snd (M.toList fresh))) + where + fresh = M.filter (\at -> diffUTCTime now at < skipWarnInterval) seen + +passDelay :: PollConfig -> Int -> Int +passDelay PollConfig {pWaitingSeconds, pIdleSeconds} waiting = + 1000000 * max minCadenceSeconds (if waiting > 0 then pWaitingSeconds else pIdleSeconds) + +waitingDelay :: PollConfig -> Int +waitingDelay cfg = passDelay cfg 1 + +-- | Both timers start now, not when a browser arrives, so browsers cannot make us poll faster than the short cadence. +passDue :: PollerEnv -> IO (STM ()) +passDue PollerEnv {peWaiters, pePoll} = do + waiting <- waitingCount peWaiters + soonest <- registerDelay (waitingDelay pePoll) + full <- registerDelay (passDelay pePoll waiting) + pure $ + (readTVar full >>= check) + `orElse` ( do + readTVar soonest >>= check + waitingCountSTM peWaiters >>= \n -> check (n > 0) + ) + +runPoller :: PollerEnv -> IO () +runPoller env = forever $ do + passSafely env + passDue env >>= serveHints env + +-- | The deadline is checked per hint, not per batch, so a redelivery backlog cannot block the pass for the sum of their timeouts. +serveHints :: PollerEnv -> STM () -> IO () +serveHints env@PollerEnv {peHints = ReadHints q} due = do + next <- atomically ((Nothing <$ due) `orElse` (Just <$> readTBQueue q)) + case next of + Nothing -> pure () + Just ref -> serveHint env ref >> serveHints env due + +drainHints :: PollerEnv -> IO () +drainHints env@PollerEnv {peHints = ReadHints q} = serveHints env (isEmptyTBQueue q >>= check) + +passSafely :: PollerEnv -> IO () +passSafely env = void $ safely "the pass" (runOnePass env) + +hintSafely :: PollerEnv -> UTCTime -> Text -> IO () +hintSafely env now ref = void $ safely ("the hinted read of " <> ref) (readHint env now ref) + +safely :: Text -> IO () -> IO Bool +safely what action = safelyWith what False (True <$ action) + +-- | Asynchronous exceptions are rethrown, since that is how the race stops this thread. +safelyWith :: Text -> a -> IO a -> IO a +safelyWith what fallback action = + try action >>= \case + Right a -> pure a + Left (e :: SomeException) -> case fromException e :: Maybe SomeAsyncException of + Just _ -> throwIO e + Nothing -> fallback <$ logError ("badge poller: " <> what <> " failed; the next pass will run: " <> tshow e) diff --git a/apps/simplex-badge-service/src/BadgeService/Providers.hs b/apps/simplex-badge-service/src/BadgeService/Providers.hs new file mode 100644 index 0000000000..b3fd706afc --- /dev/null +++ b/apps/simplex-badge-service/src/BadgeService/Providers.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE NamedFieldPuns #-} + +module BadgeService.Providers + ( ProviderError (..), + WebhookError (..), + Received (..), + PaymentSignal (..), + ProviderInvoice (..), + Funded (..), + OrderDraft (..), + ListPass (..), + settleWindow, + Provider (..), + ) +where + +import Data.ByteString (ByteString) +import Data.Text (Text) +import Data.Time.Clock (NominalDiffTime, UTCTime) +import Network.HTTP.Types.Header (Header) +import Simplex.Chat.PaymentService.Types (CurrencyAmount, PaymentProvider, ServicePaymentDestination, ServicePaymentMethod) + +newtype ProviderError = ProviderError Text deriving (Eq, Show) + +newtype WebhookError = WebhookError Text deriving (Eq, Show) + +-- rcvAmount is the total received on the invoice so far, not the amount of one payment. +-- rcvDue is the provider's figure for what is still owed. +data Received = Received {rcvAmount :: CurrencyAmount, rcvCrypto :: Maybe Text, rcvDue :: Maybe Text} + deriving (Eq, Show) + +-- The provider applies its own tolerance, so this cannot be recomputed from the amounts. +data Funded = PaidInFull | PaidInPart + deriving (Eq, Show) + +data PaymentSignal + = SigFunded Received Funded + | SigSettled Received UTCTime + | SigClosed Received + deriving (Eq, Show) + +data ProviderInvoice = ProviderInvoice + { piProviderRef :: Text, + piDestination :: ServicePaymentDestination + } + deriving (Eq, Show) + +-- A payment can land after the buyer's checkout window closes, so the poller keeps asking about an invoice for this long after it was created. +settleWindow :: NominalDiffTime +settleWindow = 72 * 3600 + +data OrderDraft = OrderDraft + { odAmount :: CurrencyAmount, + odCurrency :: Text + } + deriving (Eq, Show) + +data ListPass = ListPass + { lpMoved :: [(Text, PaymentSignal)], + lpSkipped :: [(Maybe Text, Text)] + } + deriving (Eq, Show) + +data Provider = Provider + { pProvider :: PaymentProvider, + pCreateInvoice :: ServicePaymentMethod -> OrderDraft -> IO (Either ProviderError ProviderInvoice), + pReadInvoice :: Text -> IO (Either ProviderError (Maybe PaymentSignal)), + -- Stops the provider accepting payment; cancelling only in our store leaves its invoice open until expiry. + pCancelInvoice :: Text -> IO (Either ProviderError ()), + pListOpen :: IO (Either ProviderError ListPass), + pVerifyWebhook :: [Header] -> ByteString -> Either WebhookError (Maybe Text) + } diff --git a/apps/simplex-badge-service/src/BadgeService/Providers/BTCPay.hs b/apps/simplex-badge-service/src/BadgeService/Providers/BTCPay.hs new file mode 100644 index 0000000000..e85852d3e9 --- /dev/null +++ b/apps/simplex-badge-service/src/BadgeService/Providers/BTCPay.hs @@ -0,0 +1,519 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module BadgeService.Providers.BTCPay + ( btcpayProvider, + btcMethodId, + xmrMethodId, + minorToDecimal, + paymentMethodsSignal, + listSignals, + verifyBTCPaySig, + listPageSize, + maxListPages, + ) +where + +import BadgeService.Config (BTCPayConfig (..), speedPolicyName) +import BadgeService.Providers + ( ListPass (..), + OrderDraft (..), + PaymentSignal (..), + Provider (..), + ProviderError (..), + ProviderInvoice (..), + Funded (..), + Received (..), + settleWindow, + WebhookError (..), + ) +import Control.Exception (try) +import BadgeService.Log (logError, logInfo, logWarn) +import Control.Monad (unless) +import Crypto.Hash (Digest, SHA256) +import Crypto.MAC.HMAC (HMAC, hmac, hmacGetDigest) +import qualified Data.Aeson as J +import qualified Data.Aeson.KeyMap as KM +import qualified Data.Aeson.Types as JT +import Data.ByteArray (constEq) +import Data.ByteArray.Encoding (Base (Base16), convertFromBase) +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as B8 +import qualified Data.ByteString.Lazy as LB +import Data.Char (toLower) +import Data.Int (Int64) +import Data.List (find) +import Data.Maybe (fromMaybe, mapMaybe) +import Data.Scientific (FPFormat (Fixed), Scientific, base10Exponent, formatScientific) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import Data.Time.Clock (UTCTime, addUTCTime, getCurrentTime) +import Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds) +import Data.Word (Word32) +import Network.HTTP.Client + ( HttpException, + Manager, + Request (..), + RequestBody (..), + Response (..), + brReadSome, + parseRequest, + withResponse, + ) +import Network.HTTP.Client.TLS (newTlsManager) +import Network.HTTP.Types (Header, HeaderName, Method, Query, Status (..), methodGet, methodPost, renderQuery, urlEncode) +import Simplex.Chat.PaymentService.Types + ( CryptoCurrency (..), + CurrencyAmount (..), + PaymentProvider (..), + ServicePaymentDestination (..), + ServicePaymentMethod (..), + ) +import Simplex.Messaging.Util (safeDecodeUtf8, tshow) + +btcMethodId, xmrMethodId :: Text +btcMethodId = "BTC-CHAIN" +xmrMethodId = "XMR-CHAIN" + +knownMethodIds :: [Text] +knownMethodIds = [btcMethodId, xmrMethodId] + +actedOnEventTypes :: [Text] +actedOnEventTypes = ["InvoiceProcessing", "InvoiceSettled", "InvoiceExpired", "InvoiceInvalid"] + +maxErrorBytes :: Int64 +maxErrorBytes = 4000 + +-- Far above any BTCPay response, far below what would exhaust the poller thread. +maxProviderBytes :: Int64 +maxProviderBytes = 10 * 1024 * 1024 + +listPageSize :: Int +listPageSize = 100 + +-- Caps a server that ignores @take@, so the poller still reaches its expiry sweep. +maxListPages :: Int +maxListPages = 50 + +pageCapReason :: Text +pageCapReason = + "btcpay: the list stopped at " + <> tshow maxListPages + <> " pages, so any open invoice past the first " + <> tshow (maxListPages * listPageSize) + <> " was not read — and will not be read by a later pass either" + +minorToDecimal :: CurrencyAmount -> Text +minorToDecimal (CurrencyAmount a) = + T.pack (show (a `div` 100)) <> "." <> T.justifyRight 2 '0' (T.pack (show (a `mod` 100))) + +cryptoTarget :: ServicePaymentMethod -> Either ProviderError (Text, CryptoCurrency) +cryptoTarget = \case + SPMCrypto CCBtc -> Right (btcMethodId, CCBtc) + SPMCrypto CCXmr -> Right (xmrMethodId, CCXmr) + SPMCard _ -> Left (ProviderError "btcpay offers no card payment method") + +-- BTCPay sends numbers as JSON strings; keep the exact text as sent, plus a decimal to compute with. +data WireNum = WireNum {wnText :: Text, wnValue :: Scientific} + deriving (Eq, Show) + +instance J.FromJSON WireNum where + parseJSON = \case + J.String t -> case J.decodeStrict (TE.encodeUtf8 t) of + Just v | inRange v -> pure WireNum {wnText = t, wnValue = v} + Just v -> outOfRange v + Nothing -> fail ("not a decimal number: " <> show t) + J.Number v + | inRange v -> pure WireNum {wnText = T.pack (formatScientific Fixed (Just (wireDecimals v)) v), wnValue = v} + | otherwise -> outOfRange v + v -> JT.typeMismatch "numeric string" v + where + -- Check the exponent before formatting: 1e1000000000 parses but then demands a billion digits. + inRange v = base10Exponent v >= minExponent && base10Exponent v <= maxExponent + outOfRange v = fail ("decimal exponent out of range: " <> show (base10Exponent v)) + +-- Bounds the magnitude only, so no number demands more digits than a machine can hold. +minExponent, maxExponent :: Int +minExponent = -64 +maxExponent = 64 + +wireDecimals :: Scientific -> Int +wireDecimals = max 0 . negate . base10Exponent + +data GInvoice = GInvoice + { giId :: Text, + giStatus :: Text, + giAdditionalStatus :: Maybe Text, + giPaymentMethods :: Maybe [GPaymentMethod] + } + deriving (Show) + +instance J.FromJSON GInvoice where + parseJSON = J.withObject "invoice" $ \o -> + GInvoice + <$> o J..: "id" + <*> o J..: "status" + <*> o J..:? "additionalStatus" + <*> o J..:? "paymentMethods" + +-- totalPaid is not decoded because it counts every method's payment in this currency, so it is non-zero +-- even when this method got nothing. +data GPaymentMethod = GPaymentMethod + { gpmId :: Text, + gpmDestination :: Maybe Text, + gpmAmount :: Maybe WireNum, + gpmRate :: Maybe WireNum, + gpmPaid :: Maybe WireNum, + gpmDue :: Maybe WireNum, + gpmPayments :: [GPayment] + } + deriving (Show) + +instance J.FromJSON GPaymentMethod where + parseJSON = J.withObject "payment method" $ \o -> + GPaymentMethod + <$> o J..: "paymentMethodId" + <*> o J..:? "destination" + <*> o J..:? "amount" + <*> o J..:? "rate" + <*> o J..:? "paymentMethodPaid" + <*> o J..:? "due" + <*> (fromMaybe [] <$> o J..:? "payments") + +data GPayment = GPayment + { gpStatus :: Text, + gpReceivedDate :: WireNum + } + deriving (Show) + +instance J.FromJSON GPayment where + parseJSON = J.withObject "payment" $ \o -> + GPayment <$> o J..: "status" <*> o J..: "receivedDate" + +newtype GCreated = GCreated {gcId :: Text} + deriving (Show) + +instance J.FromJSON GCreated where + parseJSON = J.withObject "created invoice" $ \o -> GCreated <$> o J..: "id" + +newtype GStoreMethod = GStoreMethod {gsmId :: Text} + deriving (Show) + +instance J.FromJSON GStoreMethod where + parseJSON = J.withObject "store payment method" $ \o -> GStoreMethod <$> o J..: "paymentMethodId" + +data GEvent = GEvent {geType :: Text, geInvoiceId :: Text} + deriving (Show) + +instance J.FromJSON GEvent where + parseJSON = J.withObject "webhook event" $ \o -> GEvent <$> o J..: "type" <*> o J..: "invoiceId" + +data BTCPayEnv = BTCPayEnv {beCfg :: BTCPayConfig, beManager :: Manager} + +btcpayProvider :: BTCPayConfig -> IO Provider +btcpayProvider cfg = do + beManager <- newTlsManager + let env = BTCPayEnv {beCfg = cfg, beManager} + logStoreMethods env + pure + Provider + { pProvider = PPCrypto, + pCreateInvoice = createInvoice env, + pReadInvoice = readInvoice env, + pCancelInvoice = cancelInvoice env, + pListOpen = listOpen env, + pVerifyWebhook = verifyBTCPaySig (bWebhookSecret cfg) + } + +-- enabledOnly returns only enabled methods, so the boot log shows what the store can actually use. +logStoreMethods :: BTCPayEnv -> IO () +logStoreMethods env@BTCPayEnv {beCfg} = do + r <- greenfield env what methodGet ["payment-methods"] [("enabledOnly", Just "true")] Nothing + case r >>= decodeGreenfield what of + Left (ProviderError e) -> do + logWarn ("btcpay: could not read the payment methods of store " <> bStoreId beCfg <> ": " <> e) + logInfo ("btcpay: this build offers " <> T.intercalate ", " knownMethodIds) + Right ms -> do + let enabled = map gsmId ms + missing = filter (`notElem` enabled) knownMethodIds + logInfo ("btcpay: store " <> bStoreId beCfg <> " has enabled " <> T.intercalate ", " enabled) + unless (null missing) $ + logError $ + "btcpay: this build offers " + <> T.intercalate ", " missing + <> ", which the store has not enabled; every checkout on those will be refused" + where + what = "read store payment methods" + +createInvoice :: BTCPayEnv -> ServicePaymentMethod -> OrderDraft -> IO (Either ProviderError ProviderInvoice) +createInvoice env@BTCPayEnv {beCfg} spm OrderDraft {odAmount, odCurrency} = + case cryptoTarget spm of + Left e -> pure (Left e) + Right (methodId, cc) -> do + created <- greenfield env what methodPost ["invoices"] [] (Just (body methodId)) + case created >>= decodeGreenfield what of + Left e@(ProviderError m) -> do + logWarn ("btcpay: the refused request was " <> safeDecodeUtf8 (LB.toStrict (J.encode (body methodId))) <> " -- " <> m) + pure (Left e) + Right GCreated {gcId} -> do + ms <- greenfield env what methodGet ["invoices", gcId, "payment-methods"] [] Nothing + pure (ms >>= destination methodId cc gcId) + where + what = "create invoice" + body methodId = + J.object + [ "amount" J..= minorToDecimal odAmount, + "currency" J..= T.toUpper odCurrency, + "checkout" + J..= J.object + [ -- the listener derives the row's expires_at from this same key + "expirationMinutes" J..= bExpiryMinutes beCfg, + "speedPolicy" J..= speedPolicyName (bSpeedPolicy beCfg), + "paymentTolerance" J..= bPaymentTolerance beCfg, + "paymentMethods" J..= [methodId] + ] + ] + destination methodId cc ref ms = do + m <- findMethod what ref methodId ms + addr <- required "destination" (gpmDestination m) + payable <- required "amount" (gpmAmount m) + pure + ProviderInvoice + { piProviderRef = ref, + piDestination = SPDCrypto cc addr (wnText payable) + } + where + required field = + maybe (Left (ProviderError (what <> ": " <> methodId <> " on invoice " <> ref <> " has no " <> field))) Right + +-- | Needs the API key's canmodifyinvoices permission, which the read and create calls do not. +cancelInvoice :: BTCPayEnv -> Text -> IO (Either ProviderError ()) +cancelInvoice env ref = + fmap (fmap (const ())) $ greenfield env what methodPost ["invoices", ref, "status"] [] (Just body) + where + what = "cancel invoice" + -- Invalid, not Archive: archiving only hides the invoice, and BTCPay keeps crediting + -- payments to it + body = J.object ["status" J..= ("Invalid" :: Text)] + +readInvoice :: BTCPayEnv -> Text -> IO (Either ProviderError (Maybe PaymentSignal)) +readInvoice env ref = do + inv <- greenfield env what methodGet ["invoices", ref] [] Nothing + case inv >>= decodeGreenfield what of + Left e -> pure (Left e) + Right GInvoice {giStatus, giAdditionalStatus} -> do + logAdditionalStatus ref giAdditionalStatus + ms <- greenfield env what methodGet ["invoices", ref, "payment-methods"] [] Nothing + now <- getCurrentTime + pure (ms >>= paymentMethodsSignal now ref giStatus) + where + what = "read invoice" + +listOpen :: BTCPayEnv -> IO (Either ProviderError ListPass) +listOpen env@BTCPayEnv {beCfg} = do + now <- getCurrentTime + let oldest = addUTCTime (negate (settleWindow + fromIntegral (60 * bExpiryMinutes beCfg))) now + fetch now (B8.pack (show (unixSeconds oldest))) 0 maxListPages (ListPass {lpMoved = [], lpSkipped = []}) + where + unixSeconds :: UTCTime -> Integer + unixSeconds = floor . utcTimeToPOSIXSeconds + query startDate skip = + [ ("includePaymentMethods", Just "true"), + ("startDate", Just startDate), + ("take", Just (B8.pack (show listPageSize))), + ("skip", Just (B8.pack (show skip))) + ] + fetch :: UTCTime -> B.ByteString -> Int -> Int -> ListPass -> IO (Either ProviderError ListPass) + fetch now startDate skip pagesLeft acc + | pagesLeft <= 0 = pure (Right acc {lpSkipped = lpSkipped acc <> [(Nothing, pageCapReason)]}) + | otherwise = do + listed <- greenfield env listWhat methodGet ["invoices"] (query startDate skip) Nothing + case listed >>= decodeGreenfield listWhat of + Left e -> pure (Left e) + Right invs -> case invoicesPass now invs of + Left e -> pure (Left e) + Right pass + | length invs < listPageSize -> pure (Right (merge acc pass)) + | otherwise -> fetch now startDate (skip + listPageSize) (pagesLeft - 1) (merge acc pass) + merge a b = ListPass {lpMoved = lpMoved a <> lpMoved b, lpSkipped = lpSkipped a <> lpSkipped b} + +listWhat :: Text +listWhat = "list invoices" + +listSignals :: UTCTime -> LB.ByteString -> Either ProviderError ListPass +listSignals now body = decodeGreenfield listWhat body >>= invoicesPass now + +-- When paymentMethods is absent or null the pass fails, because that means includePaymentMethods was ignored, and a +-- skip would report a healthy empty pass. Every other unreadable invoice is skipped, not failed. +invoicesPass :: UTCTime -> [J.Value] -> Either ProviderError ListPass +invoicesPass now invs = foldr add (Right ListPass {lpMoved = [], lpSkipped = []}) invs + where + add _ (Left e) = Left e + add v (Right pass) = case J.fromJSON v of + J.Error e -> Right pass {lpSkipped = (invoiceIdOf v, T.pack e) : lpSkipped pass} + J.Success gi -> addInvoice gi pass + addInvoice GInvoice {giId, giStatus, giPaymentMethods} pass = case giPaymentMethods of + Nothing -> + Left . ProviderError $ + listWhat <> ": invoice " <> giId <> " carries no paymentMethods, so includePaymentMethods was not honoured" + Just ms -> case invoiceSignal now giId giStatus ms of + Left (ProviderError e) -> Right pass {lpSkipped = (Just giId, e) : lpSkipped pass} + Right Nothing -> Right pass + Right (Just sig) -> Right pass {lpMoved = (giId, sig) : lpMoved pass} + +invoiceIdOf :: J.Value -> Maybe Text +invoiceIdOf v = case J.fromJSON v :: J.Result (KM.KeyMap J.Value) of + J.Success o -> case KM.lookup "id" o of + Just (J.String i) -> Just i + _ -> Nothing + J.Error _ -> Nothing + +logAdditionalStatus :: Text -> Maybe Text -> IO () +logAdditionalStatus ref = \case + Just s | s /= "None" -> logInfo ("btcpay: invoice " <> ref <> " additionalStatus " <> s) + _ -> pure () + +paymentMethodsSignal :: UTCTime -> Text -> Text -> LB.ByteString -> Either ProviderError (Maybe PaymentSignal) +paymentMethodsSignal now ref status body = + decodeGreenfield "read invoice" body >>= invoiceSignal now ref status + +-- Complete is the old API's status name and never matches, so it has no case here. +invoiceSignal :: UTCTime -> Text -> Text -> [GPaymentMethod] -> Either ProviderError (Maybe PaymentSignal) +invoiceSignal now ref status ms = do + m@GPaymentMethod {gpmRate, gpmPaid, gpmDue} <- chooseMethod ref ms + rate <- priced "rate" gpmRate + paid <- priced "paymentMethodPaid" gpmPaid + let received = receivedOf rate paid gpmDue + case status of + "Settled" -> Right (Just (SigSettled received (fromMaybe now (latestSettledAt m)))) + "Processing" -> Right (Just (SigFunded received PaidInFull)) + "Expired" -> Right (Just (SigClosed received)) + "Invalid" -> Right (Just (SigClosed received)) + "New" -> Right (SigFunded received PaidInPart <$ rcvCrypto received) + other -> Left (ProviderError ("btcpay invoice " <> ref <> ": unknown status " <> other)) + where + priced field = + maybe (Left (ProviderError ("btcpay invoice " <> ref <> ": its payment method carries no " <> field))) Right + +chooseMethod :: Text -> [GPaymentMethod] -> Either ProviderError GPaymentMethod +chooseMethod ref ms = case filter ((`elem` knownMethodIds) . gpmId) ms of + m : _ -> Right m + [] -> + Left . ProviderError $ + "btcpay invoice " + <> ref + <> ": no known payment method in [" + <> T.intercalate ", " (map gpmId ms) + <> "]; this build knows " + <> T.intercalate ", " knownMethodIds + +findMethod :: Text -> Text -> Text -> LB.ByteString -> Either ProviderError GPaymentMethod +findMethod what ref methodId body = do + ms <- decodeGreenfield what body + case find ((methodId ==) . gpmId) ms of + Just m -> Right m + Nothing -> + Left . ProviderError $ + what + <> ": invoice " + <> ref + <> " offers no " + <> methodId + <> ", only [" + <> T.intercalate ", " (map gpmId ms) + <> "]" + +receivedOf :: WireNum -> WireNum -> Maybe WireNum -> Received +receivedOf rate paid due = + Received + { rcvAmount = toMinorUnits (wnValue paid * wnValue rate), + rcvCrypto = if wnValue paid > 0 then Just (wnText paid) else Nothing, + rcvDue = wnText <$> due + } + +-- Clamp stops a wildly wrong figure wrapping Word32 and coming out small. +toMinorUnits :: Scientific -> CurrencyAmount +toMinorUnits s = CurrencyAmount (fromInteger (max 0 (min largestAmount (round (s * 100))))) + where + largestAmount = toInteger (maxBound :: Word32) + +latestSettledAt :: GPaymentMethod -> Maybe UTCTime +latestSettledAt GPaymentMethod {gpmPayments} = case mapMaybe settledAt gpmPayments of + [] -> Nothing + ts -> Just (posixSecondsToUTCTime (maximum ts)) + where + settledAt GPayment {gpStatus, gpReceivedDate} + | gpStatus == "Settled" = Just (fromRational (toRational (wnValue gpReceivedDate))) + | otherwise = Nothing + +sigHeaderName :: HeaderName +sigHeaderName = "BTCPay-Sig" + +sigPrefix :: B.ByteString +sigPrefix = "sha256=" + +-- Constant-time, over the bytes as they arrived: BTCPay indents its payload, so re-encoding would not match. +verifyBTCPaySig :: Text -> [Header] -> B.ByteString -> Either WebhookError (Maybe Text) +verifyBTCPaySig secret hdrs body = do + provided <- note "missing BTCPay-Sig header" (lookup sigHeaderName hdrs) + hex <- note "BTCPay-Sig is not sha256=" (B.stripPrefix sigPrefix provided) + given <- case convertFromBase Base16 (B8.map toLower hex) of + Right (bs :: B.ByteString) -> Right bs + Left (_ :: String) -> Left (WebhookError "BTCPay-Sig is not hex") + if constEq expected given + then Right actedOn + else Left (WebhookError "BTCPay-Sig does not verify") + where + expected :: Digest SHA256 + expected = hmacGetDigest (hmac (TE.encodeUtf8 secret) body :: HMAC SHA256) + note e = maybe (Left (WebhookError e)) Right + actedOn = do + GEvent {geType, geInvoiceId} <- J.decodeStrict' body + if geType `elem` actedOnEventTypes then Just geInvoiceId else Nothing + +greenfield :: BTCPayEnv -> Text -> Method -> [Text] -> Query -> Maybe J.Value -> IO (Either ProviderError LB.ByteString) +greenfield BTCPayEnv {beCfg, beManager} what verb segments query body = do + r <- try $ do + req <- parseRequest (T.unpack url) + let asked = + req + { method = verb, + requestHeaders = + [ ("Authorization", "token " <> TE.encodeUtf8 (bApiKey beCfg)), + ("Accept", "application/json"), + ("Content-Type", "application/json") + ], + requestBody = RequestBodyLBS (maybe LB.empty J.encode body) + } + -- Read to a bound, not the whole body, so an enormous response cannot exhaust the poller thread. + withResponse asked beManager $ \resp -> do + taken <- brReadSome (responseBody resp) (fromIntegral maxProviderBytes + 1) + pure (statusCode (responseStatus resp), taken) + pure $ case r of + -- http-client hides the Authorization header when showing a Request + Left (e :: HttpException) -> Left (ProviderError (what <> " failed: " <> tshow e)) + Right (code, taken) + | LB.length taken > maxProviderBytes -> + Left . ProviderError $ + what <> " failed: HTTP " <> tshow code <> ", and the answer is over " <> tshow maxProviderBytes <> " bytes" + | code >= 200 && code < 300 -> Right taken + | otherwise -> + Left . ProviderError $ + what <> " failed: HTTP " <> tshow code <> " " <> snippet taken + where + url = + T.dropWhileEnd (== '/') (bHost beCfg) + <> "/api/v1/stores/" + <> T.intercalate "/" (map escape (bStoreId beCfg : segments)) + <> TE.decodeUtf8 (renderQuery True query) + escape = TE.decodeUtf8 . urlEncode False . TE.encodeUtf8 + -- BTCPay puts the refusal reason at the end of an inline log, so keep enough bytes to reach it. + snippet = TE.decodeUtf8With (\_ _ -> Just '?') . LB.toStrict . LB.take maxErrorBytes + +decodeGreenfield :: J.FromJSON a => Text -> LB.ByteString -> Either ProviderError a +decodeGreenfield what body = case J.eitherDecode' body of + Right v -> Right v + Left e -> Left (ProviderError (what <> ": could not read the response: " <> T.pack e)) diff --git a/apps/simplex-badge-service/src/BadgeService/Providers/Stripe.hs b/apps/simplex-badge-service/src/BadgeService/Providers/Stripe.hs new file mode 100644 index 0000000000..2f6f93810b --- /dev/null +++ b/apps/simplex-badge-service/src/BadgeService/Providers/Stripe.hs @@ -0,0 +1,345 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module BadgeService.Providers.Stripe + ( stripeProvider, + signalOf, + IntentRead (..), + ) +where + +import BadgeService.Config (StripeConfig (..)) +import BadgeService.Providers + ( ListPass (..), + OrderDraft (..), + PaymentSignal (..), + Provider (..), + ProviderError (..), + ProviderInvoice (..), + Received (..), + settleWindow, + WebhookError (..), + ) +import Control.Exception (try) +import Crypto.Hash (Digest, SHA256) +import Crypto.MAC.HMAC (HMAC, hmac, hmacGetDigest) +import qualified Data.Aeson as J +import qualified Data.Aeson.KeyMap as KM +import Data.ByteArray (constEq) +import Data.ByteArray.Encoding (Base (Base16), convertFromBase) +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as B8 +import qualified Data.ByteString.Lazy as LB +import Data.Char (toLower) +import Data.Functor ((<&>)) +import Data.Int (Int64) +import Data.Maybe (isJust) +import Data.Scientific (floatingOrInteger) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import Data.Time.Clock (UTCTime, addUTCTime, getCurrentTime) +import Data.Time.Clock.POSIX (POSIXTime, posixSecondsToUTCTime, utcTimeToPOSIXSeconds) +import Data.Word (Word32) +import Network.HTTP.Client + ( HttpException, + Manager, + Request (..), + RequestBody (..), + Response (..), + applyBasicAuth, + brReadSome, + parseRequest, + withResponse, + ) +import Network.HTTP.Client.TLS (newTlsManager) +import Network.HTTP.Types (Header, HeaderName, Method, Query, Status (..), methodGet, methodPost, renderQuery, renderSimpleQuery) +import Simplex.Chat.PaymentService.Types + ( CardProvider (..), + CurrencyAmount (..), + PaymentProvider (..), + ServicePaymentDestination (..), + ServicePaymentMethod (..), + ) +import Simplex.Messaging.Util (safeDecodeUtf8, tshow) + +maxErrorBytes :: Int64 +maxErrorBytes = 4000 + +-- Far above any Stripe response, far below what would exhaust the poller thread. +maxProviderBytes :: Int64 +maxProviderBytes = 10 * 1024 * 1024 + +secondsPerMinute :: Int +secondsPerMinute = 60 + +listPageSize :: Int +listPageSize = 100 + +-- Caps a server that ignores @limit@, so the poller still reaches its expiry sweep. +maxListPages :: Int +maxListPages = 50 + +pageCapReason :: Text +pageCapReason = + "stripe: the list stopped at " + <> tshow maxListPages + <> " pages, so any intent past the first " + <> tshow (maxListPages * listPageSize) + <> " was not read — and will not be read by a later pass either" + +untraversableReason :: Text +untraversableReason = + "stripe: the list reports more pages but the last row carries no id to page from, so any intent past this page was not read" + +actedOnStripeEvents :: [Text] +actedOnStripeEvents = ["payment_intent.succeeded", "payment_intent.payment_failed", "payment_intent.canceled"] + +sigHeaderName :: HeaderName +sigHeaderName = "Stripe-Signature" + +listWhat :: Text +listWhat = "list intents" + +-- Pin the API version so response shapes this adapter parses do not shift under it. +stripeApiVersion :: ByteString +stripeApiVersion = "2026-03-25.dahlia" + +data StripeEnv = StripeEnv {seCfg :: StripeConfig, seManager :: Manager} + +stripeProvider :: StripeConfig -> IO Provider +stripeProvider cfg = do + seManager <- newTlsManager + let env = StripeEnv {seCfg = cfg, seManager} + pure + Provider + { pProvider = PPStripe, + pCreateInvoice = createInvoice env, + pReadInvoice = readInvoice env, + pCancelInvoice = cancelInvoice env, + pListOpen = listOpen env, + pVerifyWebhook = verifyStripeSig (sWebhookSecret cfg) + } + +listOpen :: StripeEnv -> IO (Either ProviderError ListPass) +listOpen env@StripeEnv {seCfg} = do + now <- getCurrentTime + let oldest = addUTCTime (negate (settleWindow + fromIntegral (sSessionMinutes seCfg * secondsPerMinute))) now + createdGte = B8.pack (show (unixSeconds oldest)) + go now createdGte Nothing maxListPages (ListPass [] []) + where + unixSeconds :: UTCTime -> Integer + unixSeconds = floor . utcTimeToPOSIXSeconds + go now createdGte after pagesLeft acc + | pagesLeft <= 0 = pure (Right acc {lpSkipped = lpSkipped acc <> [(Nothing, pageCapReason)]}) + | otherwise = do + let q = + [("created[gte]", Just createdGte), ("limit", Just (B8.pack (show listPageSize)))] + <> maybe [] (\a -> [("starting_after", Just (TE.encodeUtf8 a))]) after + got <- stripeApi env listWhat methodGet ["v1", "payment_intents"] q Nothing + case got >>= decodeStripe listWhat of + Left e -> pure (Left e) + Right IntentList {ilData, ilHasMore} -> + let acc' = merge acc (intentsPass now ilData) + in if ilHasMore + then case lastId ilData of + Just next -> go now createdGte (Just next) (pagesLeft - 1) acc' + Nothing -> pure (Right acc' {lpSkipped = lpSkipped acc' <> [(Nothing, untraversableReason)]}) + else pure (Right acc') + merge a b = ListPass {lpMoved = lpMoved a <> lpMoved b, lpSkipped = lpSkipped a <> lpSkipped b} + +intentsPass :: UTCTime -> [J.Value] -> ListPass +intentsPass now = foldr add (ListPass [] []) + where + add v pass = case J.fromJSON v :: J.Result IntentRead of + J.Error e -> pass {lpSkipped = (intentIdOf v, T.pack e) : lpSkipped pass} + J.Success ir -> case signalOf now ir of + Left (ProviderError e) -> pass {lpSkipped = (Just (irId ir), e) : lpSkipped pass} + Right Nothing -> pass + Right (Just sig) -> pass {lpMoved = (irId ir, sig) : lpMoved pass} + +intentIdOf :: J.Value -> Maybe Text +intentIdOf v = case J.fromJSON v :: J.Result (KM.KeyMap J.Value) of + J.Success o -> case KM.lookup "id" o of + Just (J.String i) -> Just i + _ -> Nothing + J.Error _ -> Nothing + +lastId :: [J.Value] -> Maybe Text +lastId vs = case vs of + [] -> Nothing + _ -> intentIdOf (last vs) + +data IntentList = IntentList {ilData :: [J.Value], ilHasMore :: Bool} + +instance J.FromJSON IntentList where + parseJSON = J.withObject "intent list" $ \o -> + IntentList <$> o J..: "data" <*> o J..:? "has_more" J..!= False + +-- Constant-time over the raw bytes. Stripe signs "{t}.{body}", so hash the timestamp, a dot, then the body as it arrived. +verifyStripeSig :: Text -> [Header] -> ByteString -> Either WebhookError (Maybe Text) +verifyStripeSig secret hdrs body = do + raw <- note "missing Stripe-Signature header" (lookup sigHeaderName hdrs) + (t, v1hexes) <- note "Stripe-Signature is not t=..,v1=.." (parseStripeSig raw) + givens <- mapM decodeHex v1hexes + let expected :: Digest SHA256 + expected = hmacGetDigest (hmac (TE.encodeUtf8 secret) (t <> "." <> body) :: HMAC SHA256) + -- during signing-secret rotation Stripe sends one v1 per active secret; any match verifies + if any (constEq expected) givens + then Right actedOn + else Left (WebhookError "Stripe-Signature does not verify") + where + note e = maybe (Left (WebhookError e)) Right + decodeHex v1hex = case convertFromBase Base16 (B8.map toLower v1hex) of + Right (bs :: ByteString) -> Right bs + Left (_ :: String) -> Left (WebhookError "Stripe-Signature v1 is not hex") + actedOn = do + SEvent {seType, seRef} <- J.decodeStrict' body + if seType `elem` actedOnStripeEvents then Just seRef else Nothing + +parseStripeSig :: ByteString -> Maybe (ByteString, [ByteString]) +parseStripeSig raw = do + let pairs = [(k, B8.drop 1 rest) | part <- B8.split ',' raw, let (k, rest) = B8.break (== '=') part, not (B8.null rest)] + t <- lookup "t" pairs + case [v | ("v1", v) <- pairs] of + [] -> Nothing + v1s -> Just (t, v1s) + +data SEvent = SEvent {seType :: Text, seRef :: Text} + +instance J.FromJSON SEvent where + parseJSON = J.withObject "stripe event" $ \o -> do + seType <- o J..: "type" + dataO <- o J..: "data" + obj <- dataO J..: "object" + seRef <- obj J..: "id" + pure SEvent {seType, seRef} + +data CreatedIntent = CreatedIntent {ciId :: Text, ciClientSecret :: Text} + +instance J.FromJSON CreatedIntent where + parseJSON = J.withObject "payment_intent" $ \o -> + CreatedIntent <$> o J..: "id" <*> o J..: "client_secret" + +createInvoice :: StripeEnv -> ServicePaymentMethod -> OrderDraft -> IO (Either ProviderError ProviderInvoice) +createInvoice _ (SPMCrypto _) _ = pure (Left (ProviderError "stripe offers no crypto payment method")) +createInvoice env (SPMCard CPStripe) OrderDraft {odAmount = CurrencyAmount minor, odCurrency} = do + let form = + [ ("amount", B8.pack (show minor)), + ("currency", TE.encodeUtf8 (T.toLower odCurrency)), + -- Only card is offered, because a redirect-based method would navigate the top window out of the embedded frame. + ("allowed_payment_method_types[]", "card") + ] + created <- stripeApi env what methodPost ["v1", "payment_intents"] [] (Just form) + pure $ created >>= decodeStripe what <&> \CreatedIntent {ciId, ciClientSecret} -> + ProviderInvoice {piProviderRef = ciId, piDestination = SPDCard CPStripe ciClientSecret} + where + what = "create intent" + +cancelInvoice :: StripeEnv -> Text -> IO (Either ProviderError ()) +cancelInvoice env pid = + fmap (fmap (const ())) $ stripeApi env "cancel intent" methodPost ["v1", "payment_intents", pid, "cancel"] [] (Just []) + +readInvoice :: StripeEnv -> Text -> IO (Either ProviderError (Maybe PaymentSignal)) +readInvoice env pid = do + now <- getCurrentTime + got <- stripeApi env what methodGet ["v1", "payment_intents", pid] [("expand[]", Just "latest_charge")] Nothing + pure $ got >>= decodeStripe what >>= signalOf now + where + what = "read intent " <> pid + +signalOf :: UTCTime -> IntentRead -> Either ProviderError (Maybe PaymentSignal) +signalOf now IntentRead {irStatus, irAmountReceived, irChargeCreated} = + case irStatus of + "succeeded" -> Right (Just (SigSettled (received irAmountReceived) settledAt)) + "canceled" -> Right (Just (SigClosed (received 0))) + s | s `elem` openStatuses -> Right Nothing + | otherwise -> Left (ProviderError ("stripe payment_intent: unknown status " <> s)) + where + openStatuses = ["requires_payment_method", "requires_confirmation", "requires_action", "processing", "requires_capture"] + received amt = Received {rcvAmount = amountFrom amt, rcvCrypto = Nothing, rcvDue = Nothing} + settledAt = maybe now posixSecondsToUTCTime irChargeCreated + +-- Clamp stops a wildly wrong figure wrapping Word32 and coming out small. +amountFrom :: Int64 -> CurrencyAmount +amountFrom n = CurrencyAmount (fromInteger (max 0 (min largestAmount (toInteger n)))) + where + largestAmount = toInteger (maxBound :: Word32) + +data IntentRead = IntentRead + { irId :: Text, + irStatus :: Text, + irAmountReceived :: Int64, + irChargeCreated :: Maybe POSIXTime + } + +instance J.FromJSON IntentRead where + parseJSON = J.withObject "payment_intent" $ \o -> do + irId <- o J..: "id" + irStatus <- o J..: "status" + irAmountReceived <- o J..:? "amount_received" J..!= 0 + -- expand[]=latest_charge makes this the charge object; unexpanded it is a string id we ignore + latest <- o J..:? "latest_charge" + let irChargeCreated = fmap fromInteger (chargeCreated latest) + pure IntentRead {irId, irStatus, irAmountReceived, irChargeCreated} + +chargeCreated :: Maybe J.Value -> Maybe Integer +chargeCreated = \case + Just (J.Object c) -> KM.lookup "created" c >>= asInteger + _ -> Nothing + +asInteger :: J.Value -> Maybe Integer +asInteger = \case + J.Number n -> either (const Nothing) Just (floatingOrInteger n :: Either Double Integer) + _ -> Nothing + +stripeApi :: + StripeEnv -> + Text -> + Method -> + [Text] -> + Query -> + Maybe [(ByteString, ByteString)] -> + IO (Either ProviderError LB.ByteString) +stripeApi StripeEnv {seCfg, seManager} what verb segments query form = do + r <- try $ do + req0 <- parseRequest (T.unpack url) + -- applyBasicAuth must wrap the record update, because updating requestHeaders after it would drop the header it adds. + let req = + applyBasicAuth (TE.encodeUtf8 (sSecretKey seCfg)) "" $ + req0 + { method = verb, + requestHeaders = + ("Accept", "application/json") + : ("Stripe-Version", stripeApiVersion) + : [("Content-Type", "application/x-www-form-urlencoded") | isJust form], + requestBody = RequestBodyBS (maybe "" (renderSimpleQuery False) form) + } + withResponse req seManager $ \resp -> do + taken <- brReadSome (responseBody resp) (fromIntegral maxProviderBytes + 1) + pure (statusCode (responseStatus resp), taken) + pure $ case r of + -- http-client hides the Authorization header when showing a Request + Left (e :: HttpException) -> Left (ProviderError (what <> " failed: " <> tshow e)) + Right (code, taken) + | LB.length taken > maxProviderBytes -> + Left . ProviderError $ + what <> " failed: HTTP " <> tshow code <> ", and the answer is over " <> tshow maxProviderBytes <> " bytes" + | code >= 200 && code < 300 -> Right taken + | otherwise -> + Left . ProviderError $ + what <> " failed: HTTP " <> tshow code <> " " <> snippet taken + where + url = + T.dropWhileEnd (== '/') (sHost seCfg) + <> "/" + <> T.intercalate "/" segments + <> TE.decodeUtf8 (renderQuery True query) + snippet = safeDecodeUtf8 . LB.toStrict . LB.take maxErrorBytes + +decodeStripe :: J.FromJSON a => Text -> LB.ByteString -> Either ProviderError a +decodeStripe what body = case J.eitherDecode' body of + Right v -> Right v + Left e -> Left (ProviderError (what <> ": could not read the response: " <> T.pack e)) diff --git a/apps/simplex-badge-service/src/BadgeService/Service.hs b/apps/simplex-badge-service/src/BadgeService/Service.hs index 8337f672a4..d145562b2f 100644 --- a/apps/simplex-badge-service/src/BadgeService/Service.hs +++ b/apps/simplex-badge-service/src/BadgeService/Service.hs @@ -1,4 +1,6 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} @@ -18,23 +20,32 @@ module BadgeService.Service ) where +import BadgeService.Catalog (defaultCatalog) +import BadgeService.Config (IssuerConfig (..), ServiceConfig (..), readServiceConfig) import BadgeService.Options +import BadgeService.Poller (newPollerEnv, newReadHints, runPoller) +import BadgeService.Providers.BTCPay (btcpayProvider) +import BadgeService.Providers.Stripe (stripeProvider) import BadgeService.Store +import BadgeService.Store.Invoices (seedCatalog, truncateToSecond) import BadgeService.Store.Migrate (runBadgeServiceMigrations) +import BadgeService.Waiters (Waiters, newWaiters) +import BadgeService.Web.Server (exportWebapp, newWebEnv, runWebListener) import Control.Applicative (optional) import Control.Concurrent.STM -import Control.Logger.Simple +import BadgeService.Log (logError, logInfo, logWarn) import Control.Monad import Control.Monad.IO.Class (liftIO) import qualified Data.Aeson as J import qualified Data.Aeson.KeyMap as KM import qualified Data.Attoparsec.ByteString.Char8 as A import Data.ByteString.Char8 (ByteString) +import qualified Data.ByteString.Lazy.Char8 as LB import Data.Char (isSpace) import Data.Either (fromRight) import Data.Functor (($>)) -import Data.Maybe (fromMaybe, maybeToList) import qualified Data.Map.Strict as M +import Data.Maybe (fromMaybe, maybeToList) import qualified Data.Text as T import Data.Time.Clock (UTCTime, getCurrentTime) import Data.Word (Word32) @@ -43,32 +54,37 @@ import Simplex.Chat.Badges.Code import Simplex.Chat.Badges.Ledger import Simplex.Chat.Badges.Service import Simplex.Chat.Badges.Types (BadgeCodePaymentStatus (..)) -import Simplex.Chat.Bot (initializeBotAddress') +import Simplex.Chat.Bot (initializeBotAddress', sendMessage) import Simplex.Chat.Bot.Store (withDB, withDB') import Simplex.Chat.Controller import Simplex.Chat.Core (sendChatCmd, simplexChatCore) +import Simplex.Chat.Messages +import Simplex.Chat.Messages.CIContent (CIContent (..), SMsgDirection (..), ciContentToText) import Simplex.Chat.Options (printDbOpts) import Simplex.Chat.Terminal (terminalChatConfig) import Simplex.Chat.Terminal.Main (simplexChatCLI') -import Simplex.Chat.Types (AgentInvId (..), User (..)) +import Simplex.Chat.Types (AgentInvId (..), Contact, User (..)) +import Simplex.Messaging.Agent.Store.Common (DBStore) import qualified Simplex.Messaging.Crypto as C import Simplex.Messaging.Crypto.BBS (bbsPublicKey) -import Simplex.Messaging.Encoding.String (TextEncoding, strEncode, textDecode) -import Simplex.Messaging.Version (isCompatible) +import Simplex.Messaging.Encoding.String (TextEncoding, strEncode, textDecode, textEncode) import Simplex.Messaging.Util (raceAny_, safeDecodeUtf8, tshow) +import Simplex.Messaging.Version (isCompatible) import System.Directory (getAppUserDataDirectory) import System.Exit (exitFailure) data ServiceState = ServiceState { serviceCC :: TMVar ChatController, - serviceRequestQ :: TQueue (User, AgentInvId, Maybe C.PublicKeyEd25519, J.Object) + serviceRequestQ :: TQueue (User, AgentInvId, Maybe C.PublicKeyEd25519, J.Object), + chatRedeemQ :: TQueue (Contact, T.Text) } newServiceState :: IO ServiceState newServiceState = do serviceCC <- newEmptyTMVarIO serviceRequestQ <- newTQueueIO - pure ServiceState {serviceCC, serviceRequestQ} + chatRedeemQ <- newTQueueIO + pure ServiceState {serviceCC, serviceRequestQ, chatRedeemQ} welcomeGetOpts :: IO BadgeServiceOpts welcomeGetOpts = do @@ -80,45 +96,94 @@ welcomeGetOpts = do putStrLn $ "Service name: " ++ T.unpack serviceName pure opts --- | Check the secret is the key trusted at its index: otherwise every code redeemed is burned. -checkIssuerKey :: BadgeServiceOpts -> ChatConfig -> IO (Either String BadgeIssuerKey) -checkIssuerKey BadgeServiceOpts {issuerKey} ChatConfig {badgePublicKeys} = case issuerKey of - Nothing -> pure $ Left "an issuer key is required - pass both --issuer-key-idx and --issuer-secret (see `simplex-chat badge keygen`)" - Just k@BadgeIssuerKey {keyIdx, secretKey} -> - bbsPublicKey secretKey >>= \case - Left e -> pure $ Left $ "issuer secret is not a valid key: " <> e - Right pk -> pure $ case M.lookup keyIdx badgePublicKeys of - Just pk' | pk' == pk -> Right k - Just _ -> Left $ "issuer secret does not match the configured key at index " <> show keyIdx <> ", its public key is " <> T.unpack (safeDecodeUtf8 $ strEncode pk) - Nothing -> Left $ "no configured badge key at index " <> show keyIdx <> ", clients could not verify what this service signs" +-- Every key in [issuer] is verified, not only the signing one, so a key clients cannot verify fails at boot. +checkIssuerKey :: BadgeServiceOpts -> Maybe ServiceConfig -> ChatConfig -> IO (Either String BadgeIssuerKey) +checkIssuerKey BadgeServiceOpts {issuerKey} serviceCfg cfg = case issuerKey of + Left e -> pure (Left e) + Right (Just k) -> checkOne cfg k + Right Nothing -> case serviceCfg >>= issuer of + Nothing -> pure $ Left "an issuer key is required - pass --issuer-key-idx and --issuer-secret, or add an [issuer] section to badge_service.ini (see `simplex-chat badge keygen`)" + Just IssuerConfig {iKeys, iDefaultIdx} -> do + checked <- mapM (checkOne cfg . uncurry BadgeIssuerKey) (M.toList iKeys) + pure $ case [e | Left e <- checked] of + e : _ -> Left e + [] -> maybe (Left $ "no issuer key at index " <> show iDefaultIdx) Right $ + BadgeIssuerKey iDefaultIdx <$> M.lookup iDefaultIdx iKeys -requireIssuerKey :: BadgeServiceOpts -> ChatConfig -> IO BadgeIssuerKey -requireIssuerKey opts cfg = - checkIssuerKey opts cfg >>= either (\e -> putStrLn ("Error: " <> e) >> exitFailure) pure +checkOne :: ChatConfig -> BadgeIssuerKey -> IO (Either String BadgeIssuerKey) +checkOne ChatConfig {badgePublicKeys} k@BadgeIssuerKey {keyIdx, secretKey} = + bbsPublicKey secretKey >>= \case + Left e -> pure $ Left $ "issuer secret at index " <> show keyIdx <> " is not a valid key: " <> e + Right pk -> pure $ case M.lookup keyIdx badgePublicKeys of + Just pk' | pk' == pk -> Right k + Just _ -> Left $ "issuer secret does not match the configured key at index " <> show keyIdx <> ", its public key is " <> T.unpack (safeDecodeUtf8 $ strEncode pk) + Nothing -> Left $ "no configured badge key at index " <> show keyIdx <> ", clients could not verify what this service signs" + +requireIssuerKey :: BadgeServiceOpts -> Maybe ServiceConfig -> ChatConfig -> IO BadgeIssuerKey +requireIssuerKey opts serviceCfg cfg = + checkIssuerKey opts serviceCfg cfg >>= either (\e -> putStrLn ("Error: " <> e) >> exitFailure) pure + +readConfigOrExit :: FilePath -> IO ServiceConfig +readConfigOrExit path = + readServiceConfig path >>= \case + Left e -> putStrLn (path <> ": " <> e) >> exitFailure + Right sc -> pure sc badgeService :: BadgeServiceOpts -> ChatConfig -> ServiceState -> IO () -badgeService opts cfg env = do - key <- requireIssuerKey opts cfg - let chatHooks = +badgeService opts@BadgeServiceOpts {serviceConfigFile} cfg env = do + serviceCfg <- traverse readConfigOrExit serviceConfigFile + key <- requireIssuerKey opts serviceCfg cfg + waiters <- newWaiters + let devRedeem = maybe False devChatRedeem serviceCfg + chatHooks = defaultChatHooks { preStartHook = Just $ badgePreStartHook opts, - postStartHook = Just $ badgePostStartHook opts env, + postStartHook = Just $ badgePostStartHook opts devRedeem env, preCmdHook = Just badgeCmdHook } - -- the reader must not block: outputQ carries every chat event - simplexChatCore cfg {chatHooks} (mkChatOpts opts) $ \_ cc -> - raceAny_ + when devRedeem $ logWarn "[dev] chat_redeem is on: /redeem over chat hands out credentials this service can link" + -- The reader must not block, since outputQ carries every chat event. + simplexChatCore cfg {chatHooks} (mkChatOpts opts) $ \_ cc -> do + lanes <- maybe (pure []) (serviceLanes waiters cc) serviceCfg + raceAny_ $ [ forever $ atomically (readTBQueue $ outputQ cc) >>= \case (_, Right (CEvtServiceRequest u reqId sigKey reqData)) -> atomically $ writeTQueue (serviceRequestQ env) (u, reqId, sigKey, reqData) + (_, Right CEvtNewChatItems {chatItems = AChatItem _ SMDRcv (DirectChat ct) ChatItem {content = mc@CIRcvMsgContent {}} : _}) + | devRedeem -> atomically $ writeTQueue (chatRedeemQ env) (ct, ciContentToText mc) _ -> pure (), processQueuedRequests key env ] + <> [processChatRedeems key env | devRedeem] + <> lanes + where + serviceLanes :: Waiters -> ChatController -> ServiceConfig -> IO [IO ()] + serviceLanes ws ChatController {chatStore} sc = do + -- Seed before the listener accepts anything, since every checkout is priced from these. + seedServiceCatalog chatStore + btc <- maybe (pure []) (fmap (: []) . btcpayProvider) (btcpay sc) + str <- maybe (pure []) (fmap (: []) . stripeProvider) (stripe sc) + let providers = btc <> str + hints <- newReadHints + webEnv <- newWebEnv chatStore sc ws hints providers + exportWebapp (listener sc) (stripe sc) + pollerEnv <- newPollerEnv chatStore ws hints providers (poll sc) + pure [runWebListener webEnv, runPoller pollerEnv] + +seedServiceCatalog :: DBStore -> IO () +seedServiceCatalog st = do + now <- truncateToSecond <$> getCurrentTime + let (prices, offers) = defaultCatalog now + (seededPrices, seededOffers) <- seedCatalog st prices offers + logInfo $ + "badge catalog: " <> tshow (length prices) <> " prices and " <> tshow (length offers) <> " offers compiled in, " + <> tshow seededPrices <> " prices and " <> tshow seededOffers <> " offers inserted" badgeServiceCLI :: BadgeServiceOpts -> IO () -badgeServiceCLI opts = do - key <- requireIssuerKey opts terminalChatConfig +badgeServiceCLI opts@BadgeServiceOpts {serviceConfigFile} = do + serviceCfg <- traverse readConfigOrExit serviceConfigFile + key <- requireIssuerKey opts serviceCfg terminalChatConfig env <- newServiceState let eventHook _cc ev = do case ev of @@ -129,7 +194,7 @@ badgeServiceCLI opts = do chatHooks = defaultChatHooks { preStartHook = Just $ badgePreStartHook opts, - postStartHook = Just $ badgePostStartHook opts env, + postStartHook = Just $ badgePostStartHook opts False env, preCmdHook = Just badgeCmdHook, eventHook = Just eventHook } @@ -138,34 +203,49 @@ badgeServiceCLI opts = do processQueuedRequests key env ] --- | issuing codes lives here rather than in core: every user's app would otherwise ship it badgeCmdHook :: ChatController -> ChatCommand -> IO (Either (Either ChatError ChatResponse) ChatCommand) badgeCmdHook cc = \case CustomChatCommand cmd -> Left <$> runBadgeCmd cc cmd cmd -> pure $ Right cmd runBadgeCmd :: ChatController -> ByteString -> IO (Either ChatError ChatResponse) -runBadgeCmd cc cmd = case A.parseOnly issueCmdP cmd of - Left _ -> pure $ chatCmdError "use: //issue supporter|legend|investor [months 1-255] [paid|unpaid|free]" - Right issueOpts -> - issueBadgeCode cc issueOpts >>= \case - Right code -> pure $ Right CRCustomChatResponse {user_ = Nothing, response = "code " <> formatBadgeCode code} - Left e -> pure $ chatCmdError $ "issuing code: " <> e +runBadgeCmd cc cmd + | Right issueOpts <- A.parseOnly issueCmdP cmd = + issueBadgeCode cc issueOpts >>= \case + Right code -> pure $ Right CRCustomChatResponse {user_ = Nothing, response = "code " <> formatBadgeCode code} + Left e -> pure $ chatCmdError $ "issuing code: " <> e + | Right code <- A.parseOnly revokeCmdP cmd = + revokeBadgeCode cc code >>= \case + Right True -> pure $ Right CRCustomChatResponse {user_ = Nothing, response = "revoked"} + Right False -> pure $ chatCmdError "no such code, or it was revoked already" + Left e -> pure $ chatCmdError $ "revoking code: " <> e + | otherwise = pure $ chatCmdError "use: //issue supporter|legend|investor [months 1-255] [paid|unpaid|free], or //revoke " + +revokeCmdP :: A.Parser BadgeCode +revokeCmdP = + "revoke " *> (A.takeWhile1 (not . isSpace) >>= maybe (fail "not a badge code") pure . parseBadgeCode . safeDecodeUtf8) + <* (A.skipSpace *> A.endOfInput) + +revokeBadgeCode :: ChatController -> BadgeCode -> IO (Either String Bool) +revokeBadgeCode cc code = do + now <- truncateToSecond <$> getCurrentTime + withDB' "revokeBadgeCode" cc $ \db -> revokeCode db (badgeCodeHash code) now issueCmdP :: A.Parser IssueCodeOpts issueCmdP = "issue " *> do badgeType <- badgeTypeP - months_ <- optional (A.space *> A.decimal) - -- outside `optional`, which would otherwise backtrack past a bad count + months_ <- optional (A.space *> (A.decimal :: A.Parser Integer)) + -- Kept outside optional, which would otherwise backtrack past a bad count. months <- maybe (pure 1) checkMonths months_ paymentStatus <- fromMaybe CPSFree <$> optional (A.space *> textTokenP) A.skipSpace A.endOfInput pure IssueCodeOpts {badgeType, months, paymentStatus} where + -- Integer, because attoparsec's decimal wraps silently at Int, so the guard would check a truncated count. checkMonths n - | n >= 1 && n <= (255 :: Int) = pure n + | n >= 1 && n <= 255 = pure (fromInteger n) | otherwise = fail "months must be between 1 and 255" -- BadgeType decodes anything to BTUnknown, so a typo would issue an unusable code badgeTypeP = @@ -198,19 +278,38 @@ processQueuedRequests key env = do (u, reqId, sigKey, reqData) <- atomically $ readTQueue $ serviceRequestQ env handleServiceRequest key cc u reqId sigKey reqData +processChatRedeems :: BadgeIssuerKey -> ServiceState -> IO () +processChatRedeems key env = do + cc <- atomically $ readTMVar $ serviceCC env + forever $ do + (ct, msg) <- atomically $ readTQueue $ chatRedeemQ env + chatRedeem key cc ct msg + +-- | Here the service generates the master key and can link the badge, so [dev] chat_redeem gates this. +chatRedeem :: BadgeIssuerKey -> ChatController -> Contact -> T.Text -> IO () +chatRedeem key cc ct msg = case T.stripPrefix "/redeem" (T.strip msg) of + Just rest | not (T.null (T.strip rest)) -> do + masterKey <- generateMasterKey (random cc) + (purchaseKey, _) <- atomically $ C.generateKeyPair (random cc) :: IO (C.KeyPair 'C.Ed25519) + resp <- redeemCode key cc purchaseKey masterKey (T.strip rest) + sendMessage cc ct $ case resp of + BSPBadgeCredential {credential = Just cred} -> safeDecodeUtf8 $ LB.toStrict $ J.encode cred + BSPError {code} -> "error: " <> textEncode code + _ -> "unexpected response" + _ -> sendMessage cc ct "send: /redeem " + badgePreStartHook :: BadgeServiceOpts -> ChatController -> IO () badgePreStartHook opts ChatController {config, chatStore} = runBadgeServiceMigrations opts config chatStore -badgePostStartHook :: BadgeServiceOpts -> ServiceState -> ChatController -> IO () -badgePostStartHook BadgeServiceOpts {noAddress, testing} env cc = do - -- SREQ delivery gates on this flag; Core starts serviceRequests=False, so the hook must set it. +badgePostStartHook :: BadgeServiceOpts -> Bool -> ServiceState -> ChatController -> IO () +badgePostStartHook BadgeServiceOpts {noAddress, testing} devRedeem env cc = do + -- Core starts this False and gates service request delivery on it, so the hook must set it. atomically $ writeTVar (processServiceRequests cc) True readTVarIO (currentUser cc) >>= \case Nothing -> putStrLn "No current user" >> exitFailure - -- DR required for service RPC; autoAccept off because badge service ignores contact events. Just _ -> do - unless noAddress $ initializeBotAddress' (not testing) (Just True) False cc + unless noAddress $ initializeBotAddress' (not testing) (Just True) devRedeem cc void $ atomically $ tryPutTMVar (serviceCC env) cc handleServiceRequest :: BadgeIssuerKey -> ChatController -> User -> AgentInvId -> Maybe C.PublicKeyEd25519 -> J.Object -> IO () @@ -230,8 +329,6 @@ responseObject r = case J.toJSON r of errorResponse :: BadgeServiceErrorCode -> BadgeServiceResponse errorResponse code = BSPError {code, message = Nothing, retryAfter = badgeErrorRetryAfter code} --- | Seconds, for the three codes badges-rpc.md marks transient. Every other code is terminal for --- the command attempted - internal included, which would otherwise press a failing service. badgeErrorRetryAfter :: BadgeServiceErrorCode -> Maybe Word32 badgeErrorRetryAfter = \case BSEPaymentPending -> Just 300 @@ -240,8 +337,7 @@ badgeErrorRetryAfter = \case _ -> Nothing --- | The agent verified the signature, so sigKey is a key the sender holds - a purchaseKey that --- differs would let a client claim a purchase it cannot sign for. +-- | The agent verified the signature, so sigKey is a key the sender holds; a differing purchaseKey would let a client claim a purchase it cannot sign for. badgeServiceResponse :: BadgeIssuerKey -> ChatController -> Maybe C.PublicKeyEd25519 -> J.Object -> IO BadgeServiceResponse badgeServiceResponse key cc sigKey reqData = case J.fromJSON (J.Object reqData) of J.Error _ -> pure $ errorResponse BSEBadRequest @@ -255,8 +351,7 @@ badgeServiceResponse key cc sigKey reqData = case J.fromJSON (J.Object reqData) BSCIssueBadge {balance} -> case purchaseKey of Just k -> issueBadgeCmd key cc k balance Nothing -> pure $ errorResponse BSEBadRequest - -- every command but redeemBadgeCode needs a key the service already knows: that one - -- creates the purchase, so its key is unknown on a first redemption + -- Every command but redeemBadgeCode needs a key the service already knows; that one creates the purchase, so its key is unknown on a first redemption. _ -> case purchaseKey of Nothing -> pure $ errorResponse BSEUnsupportedVersion Just k -> @@ -265,21 +360,18 @@ badgeServiceResponse key cc sigKey reqData = case J.fromJSON (J.Object reqData) Right False -> pure $ errorResponse BSEUnknownPurchaseKey Left _ -> pure $ errorResponse BSEInternal --- | The only clock the service reads, so a test can move both sides of a request together. badgeNow :: ChatController -> IO UTCTime badgeNow ChatController {config = ChatConfig {badgeCurrentTime}} = badgeCurrentTime randomId :: ChatController -> IO T.Text randomId cc = safeDecodeUtf8 . strEncode <$> atomically (C.randomBytes 16 (random cc)) --- | Neither value comes from the caller: the badge type is the entry's, the expiry is derived --- from the period end it carries. +-- | Neither the badge type nor the expiry comes from the caller; both derive from the entry. credentialForEntry :: BadgeIssuerKey -> BadgeMasterKey -> StatementEntry -> IO (Either String (StatementEntry, BadgeCredential)) credentialForEntry BadgeIssuerKey {keyIdx, secretKey} masterKey e@StatementEntry {balanceStartTs = periodEnd, balanceBadgeType} = do let badgeInfo = BadgeInfo {badgeType = balanceBadgeType, badgeExpiry = endOfMondayAfter periodEnd, badgeExtra = ""} fmap (e,) <$> issueBadge keyIdx secretKey (VerifiedBadgeRequest BadgeRequest {masterKey, badgeInfo}) --- | Pairs the issued entry with the one before it, which the writer needs for the period start. issuanceAfter :: StatementEntry -> (StatementEntry, BadgeCredential) -> (StatementEntry, StatementEntry, BadgeCredential) issuanceAfter previous (issued, credential) = (previous, issued, credential) @@ -287,31 +379,29 @@ credentialResponse :: Maybe BadgeCredential -> Maybe T.Text -> [StatementEntry] credentialResponse credential previousEntryId entries = BSPBadgeCredential {credential, receipt = Nothing, statement = BadgeStatement {entries, previousEntryId}} --- | Nothing is written until the credential is signed, so a signing failure leaves the code --- unspent rather than spent with nothing behind it. +-- | Nothing is written until the credential is signed, so a signing failure leaves the code unspent. redeemCode :: BadgeIssuerKey -> ChatController -> C.PublicKeyEd25519 -> BadgeMasterKey -> T.Text -> IO BadgeServiceResponse redeemCode key cc purchaseKey masterKey codeText = case parseBadgeCode codeText of Nothing -> pure $ errorResponse BSECodeInvalid - Just code -> - withDB "getBadgeCode" cc (readCode code) >>= \case + Just code -> do + now <- badgeNow cc + withDB "getBadgeCode" cc (readCode now code) >>= \case Left _ -> pure $ errorResponse BSEInternal Right (Left resp) -> pure resp Right (Right IssuedCode {badgeCodeId, badgeType, months}) -> do - now <- badgeNow cc (grantUuid, issueUuid) <- (,) <$> randomId cc <*> randomId cc - -- the purchase is created here, so there is no ledger to lapse -- TODO [badges] a top-up grants onto an existing ledger, and must lapse before it or the -- months it adds are counted from a start already in the past let granted = grantEntry now grantUuid months SCCode $ emptyEntry now badgeType - -- a grant of at least one month starting now always has a month to issue + -- A grant of at least one month starting now always has a month to issue. case issueEntry now issueUuid granted of Nothing -> pure $ errorResponse BSEInternal Just issued -> credentialForEntry key masterKey issued >>= \case Left e -> logError ("badge service signing failed: " <> T.pack e) $> errorResponse BSEInternal Right signed -> do - -- re-read: a concurrent redemption may have landed while this one was signing + -- Re-read, since a redemption or revoke may have landed while this one was signing. r <- withDB "writeCodeRedemption" cc $ \db -> - readCode code db >>= \case + readCode now code db >>= \case Left resp -> pure resp Right _ -> liftIO $ do purchaseId <- createCodePurchase db NewCodePurchase {badgeCodeId, purchaseKey, masterKey, badgeType} now @@ -320,18 +410,26 @@ redeemCode key cc purchaseKey masterKey codeText = case parseBadgeCode codeText pure $ maybe (errorResponse BSEInternal) (credentialResponse (Just $ snd signed) Nothing) entries_ pure $ fromRight (errorResponse BSEInternal) r where - -- used before signing and again inside the write transaction; every Left is a finished - -- response, an unknown code included - readCode code db = liftIO $ + -- Re-run before signing and again inside the write transaction, since a revoke may land between the two reads. + readCode now code db = liftIO $ getBadgeCode db (badgeCodeHash code) >>= \case Nothing -> pure $ Left $ errorResponse BSECodeInvalid - Just c@IssuedCode {redemption} -> fmap (const c) <$> checkUnspent db redemption + Just c@IssuedCode {revokedAt, paymentStatus, expiresAt, redemption} + -- Revoked is checked first, so it answers as if the code never existed. + | Just _ <- revokedAt -> pure $ Left $ errorResponse BSECodeInvalid + -- Redeeming an unpaid code would issue a free badge, so unpaid is refused. + | CPSUnpaid <- paymentStatus -> pure $ Left $ errorResponse BSEPaymentPending + | otherwise -> + checkUnspent db redemption >>= \case + Left resp -> pure $ Left resp + Right () + | maybe False (now >=) expiresAt -> pure $ Left $ errorResponse BSECodeExpired + | otherwise -> pure $ Right c checkUnspent db = \case CodeUnredeemed -> pure $ Right () CodeRedeemedUnreadable -> pure $ Left $ errorResponse BSEInternal CodeRedeemed RedeemedCode {purchaseKey = k, badgePurchaseId, credential} | k /= purchaseKey -> pure $ Left $ errorResponse BSECodeUsed - -- the whole ledger, so a client that lost the first response still ends holding it | otherwise -> maybe (Left $ errorResponse BSEInternal) (Left . credentialResponse (Just credential) Nothing) <$> getLedgerEntries db badgePurchaseId 0 @@ -359,21 +457,19 @@ issueBadgeCmd key cc purchaseKey BadgeBalance {lastEntry} = do Right signed -> writeIssued badgePurchaseId tip (maybeToList lapsed) now $ Just $ issuanceAfter current signed where - -- the rows were computed from a tip that another request may have moved, and an issuance was - -- signed against it - so write only if it is still the tip + -- Write only if the tip has not moved, since another request may have advanced it. writeIssued purchaseId tip rows t issuance_ = do r <- withDB "issueBadge" cc $ \db -> liftIO $ do tip' <- getLedgerTip db purchaseId when (fmap entryId tip' == fmap entryId tip) $ appendLedgerPlan db purchaseId rows issuance_ issueResponse db purchaseId t pure $ fromRight (errorResponse BSEInternal) r - -- entries after the one asserted, or the whole ledger when this purchase does not hold it. -- Only the asserted entry's identity is read, never the months it claims. issueResponse db purchaseId t = do let StatementEntry {entryId = assertedUuid} = lastEntry assertedId <- getLedgerEntryId db purchaseId assertedUuid -- TODO [badges] when the assertion does not resolve, heal the ledger and restate it as a - -- single opening credit (badges-rpc.md), rather than resending the whole history + -- 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_ diff --git a/apps/simplex-badge-service/src/BadgeService/Store.hs b/apps/simplex-badge-service/src/BadgeService/Store.hs index dac51a5793..fc54ce0a08 100644 --- a/apps/simplex-badge-service/src/BadgeService/Store.hs +++ b/apps/simplex-badge-service/src/BadgeService/Store.hs @@ -21,9 +21,11 @@ module BadgeService.Store appendLedgerPlan, createCodePurchase, insertBadgeCode, + revokeCode, ) where +import BadgeService.Store.Invoices (executeChanging) import qualified Data.Aeson as J import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Lazy.Char8 as LB @@ -52,11 +54,12 @@ data IssuedCode = IssuedCode { badgeCodeId :: Int64, badgeType :: BadgeType, months :: Int, + paymentStatus :: BadgeCodePaymentStatus, + revokedAt :: Maybe UTCTime, + expiresAt :: Maybe UTCTime, redemption :: CodeRedemption } --- A code that has a purchase is spent, even if its credential cannot be read. Treating that as --- an unredeemed code would issue a second credential for it. data CodeRedemption = CodeUnredeemed | CodeRedeemed RedeemedCode @@ -68,8 +71,6 @@ data RedeemedCode = RedeemedCode credential :: BadgeCredential } --- Its rows and issuance are appended by 'appendLedgerPlan' in the same transaction: a code marked --- redeemed while another write failed would be spent with no credential, and nothing reissues it. data NewCodePurchase = NewCodePurchase { badgeCodeId :: Int64, purchaseKey :: C.PublicKeyEd25519, @@ -89,7 +90,8 @@ getBadgeCode db codeHash = DB.query db [sql| - SELECT c.badge_code_id, c.badge_type, c.months, p.badge_purchase_id, p.purchase_key, i.credential + SELECT c.badge_code_id, c.badge_type, c.months, c.code_payment_status, c.revoked_at, + c.expires_at, p.badge_purchase_id, p.purchase_key, i.credential FROM sx_badge_service_badge_codes c LEFT JOIN sx_badge_service_badge_purchases p ON p.badge_code_id = c.badge_code_id LEFT JOIN sx_badge_service_badge_issuances i ON i.badge_purchase_id = p.badge_purchase_id @@ -99,8 +101,8 @@ getBadgeCode db codeHash = |] (Only (Binary codeHash)) where - toCode (badgeCodeId, badgeType, months, purchaseId_, purchaseKey_, credential_) = - IssuedCode {badgeCodeId, badgeType, months, redemption = codeRedemption purchaseId_ purchaseKey_ credential_} + toCode (badgeCodeId, badgeType, months, paymentStatus, revokedAt, expiresAt, purchaseId_, purchaseKey_, credential_) = + IssuedCode {badgeCodeId, badgeType, months, paymentStatus, revokedAt, expiresAt, redemption = codeRedemption purchaseId_ purchaseKey_ credential_} codeRedemption purchaseId_ purchaseKey_ credential_ = case (purchaseId_, purchaseKey_) of (Just badgePurchaseId, Just purchaseKey) -> case decodeCredential =<< credential_ of Just credential -> CodeRedeemed RedeemedCode {badgePurchaseId, purchaseKey, credential} @@ -113,7 +115,6 @@ purchaseKeyExists db key = maybeFirstRow' False (\(Only (_ :: Int64)) -> True) $ DB.query db "SELECT badge_purchase_id FROM sx_badge_service_badge_purchases WHERE purchase_key = ?" (Only key) --- | The only route from a command to a purchase, so a client cannot name one it cannot sign for. getPurchaseByKey :: DB.Connection -> C.PublicKeyEd25519 -> IO (Maybe ServicePurchase) getPurchaseByKey db key = maybeFirstRow toPurchase $ @@ -144,8 +145,6 @@ getLedgerTip db purchaseId = |] (Only purchaseId) --- | The uuid is the client's claim about its last held entry, so the lookup is scoped to its own --- purchase - an entry_id taken from another ledger would silently skip rows of this one. getLedgerEntryId :: DB.Connection -> Int64 -> Text -> IO (Maybe Int64) getLedgerEntryId db purchaseId entryUuid = maybeFirstRow fromOnly $ @@ -154,8 +153,7 @@ getLedgerEntryId db purchaseId entryUuid = "SELECT entry_id FROM sx_badge_service_badge_ledger WHERE badge_purchase_id = ? AND entry_uuid = ?" (purchaseId, entryUuid) --- | 0 for the whole ledger, as entry_id starts at 1. 'Nothing' when a stored row has a type this --- version cannot represent, rather than sending it changed into another. +-- | 0 returns the whole ledger, as entry_id starts at 1. getLedgerEntries :: DB.Connection -> Int64 -> Int64 -> IO (Maybe [StatementEntry]) getLedgerEntries db purchaseId afterEntryId = mapM toEntry @@ -175,7 +173,6 @@ toEntry (entryId, changeMonths, balanceMonths, balanceStartTs, balanceAnchorTs, (\entryType -> StatementEntry {entryId, changeMonths, balanceMonths, balanceStartTs, balanceAnchorTs, balanceBadgeType, wasPausedSince = Nothing, createdAt, entryType}) <$> entryTypeFromColumns entryType_ credit_ debit_ --- | Answers a repeat inside an issued month, rather than signing the same content twice. getCurrentIssuance :: DB.Connection -> Int64 -> UTCTime -> IO (Maybe BadgeCredential) getCurrentIssuance db purchaseId now = do rs <- @@ -192,10 +189,7 @@ getCurrentIssuance db purchaseId now = do [Only (Binary bs)] -> J.decodeStrict' bs _ -> Nothing --- | The issuance is the entry that spends the month and the one before it, which give the period. --- TODO [badges] also write the reference columns - payment_id, charge_id, from_purchase_id, --- to_purchase_id - for the entry types that carry one. Only the tag is written today, so a --- payment, charge, transferIn, upgrade or transferOut row would be stored without its reference. +-- TODO write the reference columns (payment_id, charge_id, from_purchase_id, to_purchase_id) for entry types that carry one; only the tag is written today. appendLedgerPlan :: DB.Connection -> Int64 -> [StatementEntry] -> Maybe (StatementEntry, StatementEntry, BadgeCredential) -> IO () appendLedgerPlan db purchaseId rows issuance_ = do mapM_ appendRow rows @@ -210,8 +204,6 @@ appendLedgerPlan db purchaseId rows issuance_ = do (issuance_id, badge_purchase_id, entry_id, badge_type, period_start, period_end, expiry, credential, created_at) VALUES (?,?,?,?,?,?,?,?,?) |] - -- the issued entry's uuid is the issuance id: one issuance per such entry, and entry uuids - -- are already unique across the ledger, so nothing has to be drawn for it ( (entryId, purchaseId, rowId, balanceBadgeType) :. (balanceStartTs previous, periodEnd, endOfMondayAfter periodEnd, Binary (LB.toStrict $ J.encode credential), createdAt) ) @@ -229,8 +221,7 @@ appendLedgerPlan db purchaseId rows issuance_ = do ((entryId, purchaseId, changeMonths, balanceMonths, balanceStartTs, balanceAnchorTs) :. (balanceBadgeType, createdAt, createdAt, entryTypeT, creditType, debitType)) insertedRowId db --- redeemed_at is stamped here, so this must share a transaction with the credential's rows: --- a code marked spent without one can never be reissued +-- redeemed_at is stamped here, so this must run in the same transaction as the credential rows. createCodePurchase :: DB.Connection -> NewCodePurchase -> UTCTime -> IO Int64 createCodePurchase db NewCodePurchase {badgeCodeId, purchaseKey, masterKey = BadgeMasterKey mk, badgeType} now = do DB.execute @@ -245,6 +236,14 @@ createCodePurchase db NewCodePurchase {badgeCodeId, purchaseKey, masterKey = Bad DB.execute db "UPDATE sx_badge_service_badge_codes SET redeemed_at = ? WHERE badge_code_id = ?" (now, badgeCodeId) pure purchaseId +revokeCode :: DB.Connection -> ByteString -> UTCTime -> IO Bool +revokeCode db codeHash now = + (> 0) + <$> executeChanging + db + "UPDATE sx_badge_service_badge_codes SET revoked_at = ? WHERE code_hash = ? AND revoked_at IS NULL" + (now, Binary codeHash) + insertBadgeCode :: DB.Connection -> ByteString -> BadgeType -> Int -> BadgeCodePaymentStatus -> UTCTime -> IO () insertBadgeCode db codeHash badgeType months paymentStatus now = DB.execute diff --git a/apps/simplex-badge-service/src/BadgeService/Store/Invoices.hs b/apps/simplex-badge-service/src/BadgeService/Store/Invoices.hs new file mode 100644 index 0000000000..5660892f07 --- /dev/null +++ b/apps/simplex-badge-service/src/BadgeService/Store/Invoices.hs @@ -0,0 +1,594 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeOperators #-} + +module BadgeService.Store.Invoices + ( InvoiceRow (..), + InvoicePayment (..), + paymentHolds, + NewInvoice (..), + CreateError (..), + StoreDecodeError (..), + createInvoiceRows, + executeChanging, + getInvoice, + getInvoiceByProviderRef, + unpaidRefs, + providerText, + codeHashExists, + expireOverdue, + cancelOpenInvoice, + newInvoiceId, + readCatalogRows, + seedCatalog, + truncateToSecond, + settlementInvoice, + settlementCodeHash, + upsertPayment, + paymentStatusText, + cryptoCurrencyText, + textToInvoiceStatus, + invoiceStatusText, + updateInvoiceStatus, + markCodePaid, + ) +where + +import Control.Exception (Exception) +import qualified Control.Exception as E +import Control.Monad (unless) +import Crypto.Random (getRandomBytes) +import Data.ByteString (ByteString) +import qualified Data.ByteString.Base64.URL as B64U +import qualified Data.ByteString.Char8 as BC8 +import Data.String (fromString) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time.Clock (UTCTime) +import Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds) +import Data.Word (Word8, Word32) +import Simplex.Chat.Badges (BadgeType (..)) +import Simplex.Chat.Badges.Service (BadgePrice (..), BadgeOffer (..)) +import Simplex.Chat.Badges.Types (BadgeCodePaymentStatus (..), BadgeItemStatus (..), BadgeOfferId (..), BadgePriceId (..), OfferDiscount (..)) +import Simplex.Chat.Store.Shared (insertedRowId) +import Simplex.Chat.PaymentService.Types (CardProvider (..), CryptoCurrency (..), CurrencyAmount (..), InvoiceId (..), InvoiceStatus (..), PaymentProvider (..), PaymentStatus (..), ServicePaymentDestination (..)) +import Simplex.Messaging.Agent.Store.Common (DBStore, withConnection, withTransaction) +import qualified Simplex.Messaging.Agent.Store.DB as DB +import Simplex.Messaging.Encoding.String (textEncode) +import Simplex.Messaging.Util (safeDecodeUtf8, tshow) + +#if defined(dbPostgres) +import BadgeService.Store.Postgres.Migrations (servicePrefix, withPrefix) +import Database.PostgreSQL.Simple (Only (..), Query, ToRow, (:.) (..)) +import qualified Database.PostgreSQL.Simple as PSQL +import Database.PostgreSQL.Simple.Errors (ConstraintViolation (..), constraintViolation) +#else +import BadgeService.Store.SQLite.Migrations (servicePrefix, withPrefix) +import Database.SQLite.Simple (Only (..), Query, ToRow, (:.) (..)) +import qualified Database.SQLite.Simple as SQL +#endif + +data InvoiceRow = InvoiceRow + { irInvoiceId :: InvoiceId, + irProvider :: PaymentProvider, + irProviderRef :: Text, + irBadgeType :: BadgeType, + irMonths :: Word8, + irPrice :: CurrencyAmount, + irAmount :: CurrencyAmount, + irCurrency :: Text, + irDestination :: ServicePaymentDestination, + irExpiresAt :: UTCTime, + irStatus :: InvoiceStatus, + irCreatedAt :: UTCTime, + irPayment :: Maybe InvoicePayment + } + deriving (Eq, Show) + +paymentHolds :: InvoicePayment -> Bool +paymentHolds InvoicePayment {ipAmount, ipCryptoPaid, ipPaidInFull} = + maybe False (\(CurrencyAmount a) -> a > 0) ipAmount || ipCryptoPaid /= Nothing || ipPaidInFull + +data InvoicePayment = InvoicePayment + { ipAmount :: Maybe CurrencyAmount, + ipCryptoPaid :: Maybe Text, + ipCryptoDue :: Maybe Text, + ipPaidInFull :: Bool, + ipStatus :: Text, + ipUpdatedAt :: UTCTime + } + deriving (Eq, Show) + +data NewInvoice = NewInvoice + { niInvoiceId :: InvoiceId, + niProviderRef :: Text, + niCodeHash :: ByteString, + niPriceId :: BadgePriceId, + niOfferId :: Maybe BadgeOfferId, + niBadgeType :: BadgeType, + niMonths :: Word8, + niPrice :: CurrencyAmount, + niAmount :: CurrencyAmount, + niCurrency :: Text, + niProvider :: PaymentProvider, + niDestination :: ServicePaymentDestination, + niExpiresAt :: UTCTime, + niCreatedAt :: UTCTime + } + +data CreateError = CECodeConflict | CERefConflict | CEOther Text + deriving (Eq, Show) + +newtype StoreDecodeError = StoreDecodeError Text + deriving (Eq, Show) + +instance Exception StoreDecodeError + +-- | SQLite stores timestamps as text, so `expires_at < ?` compares as strings and only sorts chronologically when every value has the same width. +truncateToSecond :: UTCTime -> UTCTime +truncateToSecond = posixSecondsToUTCTime . fromInteger . truncate . utcTimeToPOSIXSeconds + +#if defined(dbPostgres) +mkQuery :: Text -> Query +mkQuery raw = fromString (T.unpack (withPrefix servicePrefix raw)) +#else +mkQuery :: Text -> Query +mkQuery raw = withPrefix servicePrefix (fromString (T.unpack raw)) +#endif + +-- Backslash-newline string gaps do not survive CPP, so these queries are joined with <>. +qInsertInvoice :: Query +qInsertInvoice = + mkQuery $ + "INSERT INTO @invoices " + <> "(invoice_id, provider, price, discount_amount, credit_amount, amount, currency, " + <> "payment_url, payment_address, payment_crypto_currency, payment_crypto_amount, " + <> "expires_at, status, created_at, updated_at) " + <> "VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)" + +qInsertBadgeCodeInvoice :: Query +qInsertBadgeCodeInvoice = + mkQuery $ + "INSERT INTO @badge_code_invoices " + <> "(invoice_id, badge_code_id, price_id, offer_id, provider_ref, created_at) " + <> "VALUES (?,?,?,?,?,?)" + +qInsertBadgeCode :: Query +qInsertBadgeCode = + mkQuery $ + "INSERT INTO @badge_codes (code_hash, badge_type, months, code_payment_status, created_at) " + <> "VALUES (?,?,?,?,?)" + +invoiceRowSelect :: Text +invoiceRowSelect = + "SELECT i.invoice_id, i.provider, ci.provider_ref, bc.badge_type, bc.months, " + <> "i.price, i.amount, i.currency, i.payment_url, i.payment_address, i.payment_crypto_currency, " + <> "i.payment_crypto_amount, i.expires_at, i.status, i.created_at, " + <> "p.amount, p.crypto_paid, p.crypto_due, p.paid_in_full, p.status, p.updated_at " + <> "FROM @invoices i " + <> "JOIN @badge_code_invoices ci ON ci.invoice_id = i.invoice_id " + <> "JOIN @badge_codes bc ON bc.badge_code_id = ci.badge_code_id " + <> "LEFT JOIN @payments p ON p.invoice_id = i.invoice_id " + +qGetInvoice :: Query +qGetInvoice = mkQuery (invoiceRowSelect <> "WHERE i.invoice_id = ?") + +qGetInvoiceByProviderRef :: Query +qGetInvoiceByProviderRef = mkQuery (invoiceRowSelect <> "WHERE ci.provider_ref = ?") + +qUnpaidRefs :: Query +qUnpaidRefs = + mkQuery $ + "SELECT i.provider, ci.provider_ref FROM @invoices i " + <> "JOIN @badge_code_invoices ci ON ci.invoice_id = i.invoice_id " + <> "WHERE i.status <> 'paid' AND i.created_at >= ? " + <> "ORDER BY i.created_at" + +qCodeHashExists :: Query +qCodeHashExists = mkQuery "SELECT 1 FROM @badge_codes WHERE code_hash = ? LIMIT 1" + +unfundedOnly :: Text +unfundedOnly = + "AND NOT EXISTS (SELECT 1 FROM @payments p " + <> "WHERE p.invoice_id = @invoices.invoice_id AND (" + <> "COALESCE(p.amount, 0) > 0 OR p.crypto_paid IS NOT NULL OR p.paid_in_full = 1)) " + +qOverdueInvoiceIds :: Query +qOverdueInvoiceIds = + mkQuery $ + "SELECT invoice_id FROM @invoices " + <> "WHERE status = 'open' AND expires_at < ? " + <> unfundedOnly + <> "AND EXISTS (SELECT 1 FROM @badge_code_invoices ci WHERE ci.invoice_id = @invoices.invoice_id)" + +qExpireOverdue :: Query +qExpireOverdue = + mkQuery $ + "UPDATE @invoices SET status = 'expired', updated_at = ? " + <> "WHERE status = 'open' AND expires_at < ? " + <> unfundedOnly + <> "AND EXISTS (SELECT 1 FROM @badge_code_invoices ci WHERE ci.invoice_id = @invoices.invoice_id)" + +qCodeHashForInvoice :: Query +qCodeHashForInvoice = + mkQuery $ + "SELECT bc.code_hash FROM @badge_code_invoices ci " + <> "JOIN @badge_codes bc ON bc.badge_code_id = ci.badge_code_id " + <> "WHERE ci.invoice_id = ?" + +-- | SQLite's two-argument MAX is GREATEST in Postgres, where MAX is an aggregate. +largerOf :: Text +#if defined(dbPostgres) +largerOf = "GREATEST" +#else +largerOf = "MAX" +#endif + +-- Once a row is settled it stays settled, so a later pending update cannot overwrite it. +qUpsertPayment :: Query +qUpsertPayment = + mkQuery $ + "INSERT INTO @payments " + <> "(payment_id, invoice_id, provider, provider_ref, amount, currency, crypto_paid, crypto_due, paid_in_full, status, created_at, updated_at) " + <> "VALUES (?,?,?,?,?,?,?,?,?,?,?,?) " + <> "ON CONFLICT (payment_id) DO UPDATE SET " + <> "amount = " + <> largerOf + <> "(COALESCE(@payments.amount, 0), excluded.amount), " + <> "crypto_paid = CASE WHEN excluded.amount > COALESCE(@payments.amount, 0) OR @payments.crypto_paid IS NULL " + <> "THEN excluded.crypto_paid ELSE @payments.crypto_paid END, " + <> "crypto_due = COALESCE(excluded.crypto_due, @payments.crypto_due), " + <> "paid_in_full = " + <> largerOf + <> "(@payments.paid_in_full, excluded.paid_in_full), " + <> "status = CASE WHEN " + <> alreadySettled + <> " THEN @payments.status ELSE excluded.status END, " + <> "updated_at = CASE WHEN " + <> alreadySettled + <> " THEN @payments.updated_at ELSE excluded.updated_at END" + where + alreadySettled = "@payments.status = '" <> paymentStatusText PSSettled <> "'" + +qUpdateInvoiceStatus :: Query +qUpdateInvoiceStatus = + mkQuery "UPDATE @invoices SET status = ?, updated_at = ? WHERE invoice_id = ? AND status = ?" + +qMarkCodePaid :: Query +qMarkCodePaid = + mkQuery $ + "UPDATE @badge_codes SET code_payment_status = ?, expires_at = ? " + <> "WHERE code_hash = ? AND code_payment_status = ?" + +qBadgePrices :: Query +qBadgePrices = + mkQuery $ + "SELECT price_id, badge_type, month_price, currency, status, created_at " + <> "FROM @badge_prices WHERE status <> 'disabled'" + +qBadgeOffers :: Query +qBadgeOffers = + mkQuery $ + "SELECT offer_id, price_id, months, free_months, discount, status, created_at " + <> "FROM @badge_offers WHERE status <> 'disabled'" + +qSeedBadgePrice :: Query +qSeedBadgePrice = + mkQuery $ + "INSERT INTO @badge_prices (price_id, badge_type, month_price, currency, status, created_at) " + <> "VALUES (?,?,?,?,?,?) ON CONFLICT (price_id) DO NOTHING" + +qSeedBadgeOffer :: Query +qSeedBadgeOffer = + mkQuery $ + "INSERT INTO @badge_offers (offer_id, price_id, months, free_months, discount, status, created_at) " + <> "VALUES (?,?,?,?,?,?,?) ON CONFLICT (offer_id) DO NOTHING" + +providerText :: PaymentProvider -> Text +providerText = \case + PPApple -> "apple" + PPGoogle -> "google" + PPStripe -> "stripe" + PPCrypto -> "crypto" + PPCode -> "code" + PPReceipt -> "receipt" + +textToProvider :: Text -> Maybe PaymentProvider +textToProvider = \case + "apple" -> Just PPApple + "google" -> Just PPGoogle + "stripe" -> Just PPStripe + "crypto" -> Just PPCrypto + "code" -> Just PPCode + "receipt" -> Just PPReceipt + _ -> Nothing + +cryptoCurrencyText :: CryptoCurrency -> Text +cryptoCurrencyText CCBtc = "btc" +cryptoCurrencyText CCXmr = "xmr" + +textToCryptoCurrency :: Text -> Maybe CryptoCurrency +textToCryptoCurrency "btc" = Just CCBtc +textToCryptoCurrency "xmr" = Just CCXmr +textToCryptoCurrency _ = Nothing + +invoiceStatusText :: InvoiceStatus -> Text +invoiceStatusText ISOpen = "open" +invoiceStatusText ISPaid = "paid" +invoiceStatusText ISExpired = "expired" + +textToInvoiceStatus :: Text -> Maybe InvoiceStatus +textToInvoiceStatus "open" = Just ISOpen +textToInvoiceStatus "paid" = Just ISPaid +textToInvoiceStatus "expired" = Just ISExpired +textToInvoiceStatus _ = Nothing + +itemStatusText :: BadgeItemStatus -> Text +itemStatusText BISActive = "active" +itemStatusText BISDeprecated = "deprecated" +itemStatusText BISDisabled = "disabled" + +textToItemStatus :: Text -> Maybe BadgeItemStatus +textToItemStatus "active" = Just BISActive +textToItemStatus "deprecated" = Just BISDeprecated +textToItemStatus "disabled" = Just BISDisabled +textToItemStatus _ = Nothing + +paymentStatusText :: PaymentStatus -> Text +paymentStatusText = \case + PSPending -> "pending" + PSSettled -> "settled" + PSFailed _ -> "failed" + +decodeDiscount :: Maybe Word8 -> Maybe Word8 -> Maybe OfferDiscount +decodeDiscount (Just f) _ = Just (ODFreeMonths f) +decodeDiscount Nothing (Just d) = Just (ODDiscount d) +decodeDiscount Nothing Nothing = Nothing + +discountCols :: OfferDiscount -> (Maybe Word32, Maybe Word32) +discountCols (ODFreeMonths f) = (Just (fromIntegral f), Nothing) +discountCols (ODDiscount d) = (Nothing, Just (fromIntegral d)) + +mkDestination :: Maybe Text -> Maybe Text -> Maybe Text -> Maybe Text -> Maybe ServicePaymentDestination +mkDestination (Just url) _ _ _ = Just (SPDCard CPStripe url) +mkDestination Nothing (Just addr) (Just curTxt) (Just amt) = (\cur -> SPDCrypto cur addr amt) <$> textToCryptoCurrency curTxt +mkDestination _ _ _ _ = Nothing + +destinationCols :: ServicePaymentDestination -> (Maybe Text, Maybe Text, Maybe Text, Maybe Text) +destinationCols (SPDCard _ url) = (Just url, Nothing, Nothing, Nothing) +destinationCols (SPDCrypto cur addr amt) = (Nothing, Just addr, Just (cryptoCurrencyText cur), Just amt) + +note :: Text -> Maybe a -> Either Text a +note ctx = maybe (Left ctx) Right + +type InvoiceCols = + (Text, Text, Text, BadgeType, Word32) + :. (Word32, Word32, Text, Maybe Text, Maybe Text, Maybe Text) + :. (Maybe Text, UTCTime, Text, UTCTime) + :. (Maybe Word32, Maybe Text, Maybe Text, Maybe Int, Maybe Text, Maybe UTCTime) + +mkInvoiceRow :: InvoiceCols -> Either Text InvoiceRow +mkInvoiceRow + ( (invId, providerTxt, providerRef, badgeType, months) + :. (price, amount, currency, url, addr, cryptoCur) + :. (cryptoAmt, expiresAt, statusTxt, createdAt) + :. (pAmount, pCryptoPaid, pCryptoDue, pPaidInFull, pStatus, pUpdatedAt) + ) = do + provider <- note "invoices.provider" (textToProvider providerTxt) + status <- note "invoices.status" (textToInvoiceStatus statusTxt) + destination <- note "invoice payment destination" (mkDestination url addr cryptoCur cryptoAmt) + pure + InvoiceRow + { irInvoiceId = InvoiceId invId, + irProvider = provider, + irProviderRef = providerRef, + irBadgeType = badgeType, + irMonths = fromIntegral months, + irPrice = CurrencyAmount price, + irAmount = CurrencyAmount amount, + irCurrency = currency, + irDestination = destination, + irExpiresAt = expiresAt, + irStatus = status, + irCreatedAt = createdAt, + irPayment = mkPayment pAmount pCryptoPaid pCryptoDue pPaidInFull pStatus pUpdatedAt + } + +mkPayment :: Maybe Word32 -> Maybe Text -> Maybe Text -> Maybe Int -> Maybe Text -> Maybe UTCTime -> Maybe InvoicePayment +mkPayment amt cryptoPaid cryptoDue paidInFull status updatedAt = + InvoicePayment (CurrencyAmount <$> amt) cryptoPaid cryptoDue (paidInFull == Just 1) <$> status <*> updatedAt + +selectInvoiceRow :: DB.Connection -> Query -> Text -> IO (Maybe InvoiceRow) +selectInvoiceRow db q param = do + rows <- DB.query db q (Only param) + case rows of + [] -> pure Nothing + (row : _) -> either (E.throwIO . StoreDecodeError) (pure . Just) (mkInvoiceRow row) + +type BadgePriceCols = (Text, BadgeType, Word32, Text, Text, UTCTime) + +mkBadgePrice :: BadgePriceCols -> Either Text BadgePrice +mkBadgePrice (priceId, badgeType, monthPrice, currency, statusTxt, createdAt) = do + status <- note "badge_prices.status" (textToItemStatus statusTxt) + pure + BadgePrice + { priceId = BadgePriceId priceId, + badgeType, + monthPrice = CurrencyAmount monthPrice, + currency, + status, + createdAt + } + +type BadgeOfferCols = (Text, Maybe Text, Word32, Maybe Word32, Maybe Word32, Text, UTCTime) + +mkBadgeOffer :: BadgeOfferCols -> Either Text BadgeOffer +mkBadgeOffer (offerId, priceId, months, freeMonths, discountPct, statusTxt, createdAt) = do + status <- note "badge_offers.status" (textToItemStatus statusTxt) + discount <- note "badge_offers discount" (decodeDiscount (fromIntegral <$> freeMonths) (fromIntegral <$> discountPct)) + pure + BadgeOffer + { offerId = BadgeOfferId offerId, + priceId = BadgePriceId <$> priceId, + months = fromIntegral months, + discount, + status, + createdAt + } + +createInvoiceRows :: DBStore -> NewInvoice -> IO (Either CreateError ()) +createInvoiceRows st ni = + (Right <$> withTransaction st (`insertInvoiceRows` ni)) + `E.catch` (pure . Left . classifyCreateError) + +insertInvoiceRows :: DB.Connection -> NewInvoice -> IO () +insertInvoiceRows db NewInvoice {..} = do + let InvoiceId invId = niInvoiceId + CurrencyAmount price = niPrice + CurrencyAmount amount = niAmount + discountAmount = price - amount + (url, addr, cryptoCur, cryptoAmt) = destinationCols niDestination + expiresAt = truncateToSecond niExpiresAt + createdAt = truncateToSecond niCreatedAt + BadgePriceId priceId = niPriceId + offerId = (\(BadgeOfferId o) -> o) <$> niOfferId + months = fromIntegral niMonths :: Word32 + DB.execute + db + qInsertInvoice + ( (invId, providerText niProvider, price, discountAmount, Nothing :: Maybe Word32, amount, niCurrency) + :. (url, addr, cryptoCur, cryptoAmt, expiresAt, invoiceStatusText ISOpen, createdAt, createdAt) + ) + DB.execute + db + qInsertBadgeCode + (DB.Binary niCodeHash, niBadgeType, months, textEncode CPSUnpaid, createdAt) + badgeCodeId <- insertedRowId db + DB.execute + db + qInsertBadgeCodeInvoice + (invId, badgeCodeId, priceId, offerId, niProviderRef, createdAt) + +#if defined(dbPostgres) +classifyCreateError :: DB.SQLError -> CreateError +classifyCreateError e = case constraintViolation e of + Just (UniqueViolation name) + | "code_hash" `T.isInfixOf` nameText -> CECodeConflict + | "provider_ref" `T.isInfixOf` nameText -> CERefConflict + | otherwise -> CEOther (tshow e) + where + nameText = safeDecodeUtf8 name + _ -> CEOther (tshow e) +#else +classifyCreateError :: DB.SQLError -> CreateError +classifyCreateError e + | SQL.sqlError e == SQL.ErrorConstraint = + if "code_hash" `T.isInfixOf` details + then CECodeConflict + else + if "provider_ref" `T.isInfixOf` details + then CERefConflict + else CEOther details + | otherwise = CEOther (tshow e) + where + details = SQL.sqlErrorDetails e +#endif + +getInvoice :: DBStore -> InvoiceId -> IO (Maybe InvoiceRow) +getInvoice st (InvoiceId invId) = withConnection st $ \db -> selectInvoiceRow db qGetInvoice invId + +getInvoiceByProviderRef :: DBStore -> Text -> IO (Maybe InvoiceRow) +getInvoiceByProviderRef st ref = withConnection st $ \db -> selectInvoiceRow db qGetInvoiceByProviderRef ref + +unpaidRefs :: DBStore -> UTCTime -> IO [(Text, Text)] +unpaidRefs st since = withConnection st $ \db -> DB.query db qUnpaidRefs (Only since) + +codeHashExists :: DBStore -> ByteString -> IO Bool +codeHashExists st codeHash = withConnection st $ \db -> + not . null <$> (DB.query db qCodeHashExists (Only (DB.Binary codeHash)) :: IO [Only Int]) + +expireOverdue :: DBStore -> UTCTime -> IO [InvoiceId] +expireOverdue st cutoff' = withTransaction st $ \db -> do + let cutoff = truncateToSecond cutoff' + ids <- DB.query db qOverdueInvoiceIds (Only cutoff) :: IO [Only Text] + unless (null ids) $ DB.execute db qExpireOverdue (cutoff, cutoff) + pure (map (\(Only i) -> InvoiceId i) ids) + +cancelOpenInvoice :: DBStore -> InvoiceId -> UTCTime -> IO Bool +cancelOpenInvoice st invId at = withTransaction st $ \db -> updateInvoiceStatus db invId ISOpen ISExpired at + +readCatalogRows :: DBStore -> IO ([BadgePrice], [BadgeOffer]) +readCatalogRows st = withConnection st $ \db -> do + priceRows <- DB.query_ db qBadgePrices + offerRows <- DB.query_ db qBadgeOffers + prices <- either (E.throwIO . StoreDecodeError) pure (traverse mkBadgePrice priceRows) + offers <- either (E.throwIO . StoreDecodeError) pure (traverse mkBadgeOffer offerRows) + pure (prices, offers) + +seedCatalog :: DBStore -> [BadgePrice] -> [BadgeOffer] -> IO (Int, Int) +seedCatalog st prices offers = withTransaction st $ \db -> do + seededPrices <- sum <$> mapM (seedPrice db) prices + seededOffers <- sum <$> mapM (seedOffer db) offers + pure (seededPrices, seededOffers) + where + seedPrice db BadgePrice {priceId = BadgePriceId pId, badgeType = bType, monthPrice = CurrencyAmount mPrice, currency = cur, status = pStatus, createdAt = at} = + executeChanging db qSeedBadgePrice (pId, bType, mPrice, cur, itemStatusText pStatus, truncateToSecond at) + seedOffer db BadgeOffer {offerId = BadgeOfferId oId, priceId = oPriceId, months = mMonths, discount = disc, status = oStatus, createdAt = at} = + let (freeMonths, discountPct) = discountCols disc + in executeChanging + db + qSeedBadgeOffer + ( oId, + (\(BadgePriceId p) -> p) <$> oPriceId, + fromIntegral mMonths :: Word32, + freeMonths, + discountPct, + itemStatusText oStatus, + truncateToSecond at + ) + +executeChanging :: ToRow q => DB.Connection -> Query -> q -> IO Int +#if defined(dbPostgres) +executeChanging db q params = fromIntegral <$> PSQL.execute db q params +#else +executeChanging db q params = DB.execute db q params >> SQL.changes (DB.conn db) +#endif + +settlementInvoice :: DB.Connection -> InvoiceId -> IO (Maybe InvoiceRow) +settlementInvoice db (InvoiceId invId) = selectInvoiceRow db qGetInvoice invId + +settlementCodeHash :: DB.Connection -> InvoiceId -> IO (Maybe ByteString) +settlementCodeHash db (InvoiceId invId) = do + rows <- DB.query db qCodeHashForInvoice (Only invId) :: IO [Only (Maybe (DB.Binary ByteString))] + pure $ case rows of + (Only codeHash : _) -> DB.fromBinary <$> codeHash + [] -> Nothing + +upsertPayment :: DB.Connection -> InvoiceRow -> PaymentStatus -> CurrencyAmount -> Maybe Text -> Maybe Text -> Bool -> UTCTime -> IO () +upsertPayment db InvoiceRow {irInvoiceId, irProvider, irProviderRef, irCurrency} status (CurrencyAmount amount) cryptoAmount cryptoDue paidInFull at' = + DB.execute + db + qUpsertPayment + ( (invId, invId, providerText irProvider, irProviderRef, amount) + :. (irCurrency, cryptoAmount, cryptoDue, if paidInFull then 1 :: Int else 0, paymentStatusText status, at, at) + ) + where + InvoiceId invId = irInvoiceId + at = truncateToSecond at' + +updateInvoiceStatus :: DB.Connection -> InvoiceId -> InvoiceStatus -> InvoiceStatus -> UTCTime -> IO Bool +updateInvoiceStatus db (InvoiceId invId) observed new at = + (> 0) <$> executeChanging db qUpdateInvoiceStatus (invoiceStatusText new, truncateToSecond at, invId, invoiceStatusText observed) + +markCodePaid :: DB.Connection -> ByteString -> UTCTime -> IO () +markCodePaid db codeHash expiresAt = + DB.execute + db + qMarkCodePaid + (textEncode CPSPaid, truncateToSecond expiresAt, DB.Binary codeHash, textEncode CPSUnpaid) + +newInvoiceId :: IO InvoiceId +newInvoiceId = InvoiceId . safeDecodeUtf8 . BC8.filter (/= '=') . B64U.encode <$> getRandomBytes 16 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 e8b62c2d53..c8179d5df2 100644 --- a/apps/simplex-badge-service/src/BadgeService/Store/Postgres/Migrations.hs +++ b/apps/simplex-badge-service/src/BadgeService/Store/Postgres/Migrations.hs @@ -2,7 +2,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} -module BadgeService.Store.Postgres.Migrations (badgeServiceSchemaMigrations) where +module BadgeService.Store.Postgres.Migrations (badgeServiceSchemaMigrations, servicePrefix, withPrefix) where import Data.List (sortOn) import Data.Text (Text) @@ -17,19 +17,29 @@ badgeServiceSchemaMigrations = sortOn name $ map migration schemaMigrations schemaMigrations :: [(String, Text, Maybe Text)] schemaMigrations = - [ ("20260806_badge_service_schema", m20260806_badge_service_schema, Just down_m20260806_badge_service_schema) + [ ("20260915_badge_service_schema", m20260915_badge_service_schema, Just down_m20260915_badge_service_schema) ] --- the client tables are in the same database, so the service tables are the same names with this prefix +-- | The client tables share this database, so the service tables are the same names behind a prefix. servicePrefix :: Text servicePrefix = "sx_badge_service_" -m20260806_badge_service_schema :: Text -m20260806_badge_service_schema = +m20260915_badge_service_schema :: Text +m20260915_badge_service_schema = badgeSchema servicePrefix <> withPrefix servicePrefix + -- The payment columns are added to @payments, which badgeSchema owns. crypto_paid, + -- crypto_due and paid_in_full record the provider's own figures: it applies a payment + -- tolerance and adds a network fee after a partial payment, so what is owed and whether + -- an invoice is settled are its verdicts, not amounts recomputable from what we store. [r| +ALTER TABLE @payments ADD COLUMN crypto_paid TEXT; + +ALTER TABLE @payments ADD COLUMN crypto_due TEXT; + +ALTER TABLE @payments ADD COLUMN paid_in_full SMALLINT NOT NULL DEFAULT 0; + CREATE TABLE @badge_codes( badge_code_id BIGINT GENERATED ALWAYS AS IDENTITY PRIMARY KEY, code_hash BYTEA NOT NULL, @@ -37,6 +47,8 @@ CREATE TABLE @badge_codes( months SMALLINT NOT NULL, code_payment_status TEXT NOT NULL, redeemed_at TIMESTAMPTZ, + expires_at TIMESTAMPTZ, + revoked_at TIMESTAMPTZ, created_at TIMESTAMPTZ NOT NULL, UNIQUE(code_hash) ); @@ -47,22 +59,43 @@ CREATE UNIQUE INDEX @idx_badge_purchases_code ON @badge_purchases(badge_code_id) CREATE TABLE @badge_code_invoices( invoice_id TEXT NOT NULL PRIMARY KEY REFERENCES @invoices ON DELETE CASCADE, + badge_code_id BIGINT NOT NULL REFERENCES @badge_codes, price_id TEXT NOT NULL REFERENCES @badge_prices, offer_id TEXT REFERENCES @badge_offers, - months SMALLINT NOT NULL, + provider_ref TEXT NOT NULL, created_at TIMESTAMPTZ NOT NULL ); CREATE INDEX @idx_badge_code_invoices_offer ON @badge_code_invoices(offer_id); CREATE INDEX @idx_badge_code_invoices_price ON @badge_code_invoices(price_id); + +-- provider_ref is the provider's own id for the invoice; unique so a webhook or poller read +-- resolves a payment to exactly one invoice. +CREATE UNIQUE INDEX @idx_badge_code_invoices_provider_ref ON @badge_code_invoices(provider_ref); +|] + -- Two filters run on every poller pass and neither may read the whole table, or the pass + -- lengthens for as long as the service keeps selling: the expiry sweep, on (status, expires_at), + -- and the read lane, which takes a window of created_at. Status leads the first because it is + -- matched by equality there; the second matches it with <>, which no index can seek, so it seeks + -- the window and filters what little that leaves. + <> withPrefix + servicePrefix + [r| +CREATE INDEX @idx_invoices_status_expires_at ON @invoices(status, expires_at); + +CREATE INDEX @idx_invoices_created ON @invoices(created_at); |] -down_m20260806_badge_service_schema :: Text -down_m20260806_badge_service_schema = +down_m20260915_badge_service_schema :: Text +down_m20260915_badge_service_schema = withPrefix servicePrefix [r| +DROP INDEX @idx_invoices_created; +DROP INDEX @idx_invoices_status_expires_at; + +DROP INDEX @idx_badge_code_invoices_provider_ref; DROP INDEX @idx_badge_code_invoices_offer; DROP INDEX @idx_badge_code_invoices_price; DROP TABLE @badge_code_invoices; 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 ce08db0c7a..bf022f189c 100644 --- a/apps/simplex-badge-service/src/BadgeService/Store/SQLite/Migrations.hs +++ b/apps/simplex-badge-service/src/BadgeService/Store/SQLite/Migrations.hs @@ -2,7 +2,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} -module BadgeService.Store.SQLite.Migrations (badgeServiceSchemaMigrations) where +module BadgeService.Store.SQLite.Migrations (badgeServiceSchemaMigrations, servicePrefix, withPrefix) where import Data.List (sortOn) import Data.Text (Text) @@ -18,19 +18,29 @@ badgeServiceSchemaMigrations = sortOn name $ map migration schemaMigrations schemaMigrations :: [(String, Query, Maybe Query)] schemaMigrations = - [ ("20260806_badge_service_schema", m20260806_badge_service_schema, Just down_m20260806_badge_service_schema) + [ ("20260915_badge_service_schema", m20260915_badge_service_schema, Just down_m20260915_badge_service_schema) ] --- the client tables are in the same database, so the service tables are the same names with this prefix +-- | The client tables share this database, so the service tables are the same names behind a prefix. servicePrefix :: Text servicePrefix = "sx_badge_service_" -m20260806_badge_service_schema :: Query -m20260806_badge_service_schema = +m20260915_badge_service_schema :: Query +m20260915_badge_service_schema = badgeSchema servicePrefix <> withPrefix servicePrefix + -- The payment columns are added to @payments, which badgeSchema owns. crypto_paid, + -- crypto_due and paid_in_full record the provider's own figures: it applies a payment + -- tolerance and adds a network fee after a partial payment, so what is owed and whether + -- an invoice is settled are its verdicts, not amounts recomputable from what we store. [sql| +ALTER TABLE @payments ADD COLUMN crypto_paid TEXT; + +ALTER TABLE @payments ADD COLUMN crypto_due TEXT; + +ALTER TABLE @payments ADD COLUMN paid_in_full INTEGER NOT NULL DEFAULT 0; + CREATE TABLE @badge_codes( badge_code_id INTEGER PRIMARY KEY AUTOINCREMENT, code_hash BLOB NOT NULL, @@ -38,6 +48,8 @@ CREATE TABLE @badge_codes( months INTEGER NOT NULL, code_payment_status TEXT NOT NULL, redeemed_at TEXT, + expires_at TEXT, + revoked_at TEXT, created_at TEXT NOT NULL, UNIQUE(code_hash) ) STRICT; @@ -48,22 +60,43 @@ CREATE UNIQUE INDEX @idx_badge_purchases_code ON @badge_purchases(badge_code_id) CREATE TABLE @badge_code_invoices( invoice_id TEXT NOT NULL PRIMARY KEY REFERENCES @invoices ON DELETE CASCADE, + badge_code_id INTEGER NOT NULL REFERENCES @badge_codes, price_id TEXT NOT NULL REFERENCES @badge_prices, offer_id TEXT REFERENCES @badge_offers, - months INTEGER NOT NULL, + provider_ref TEXT NOT NULL, created_at TEXT NOT NULL ) STRICT; CREATE INDEX @idx_badge_code_invoices_offer ON @badge_code_invoices(offer_id); CREATE INDEX @idx_badge_code_invoices_price ON @badge_code_invoices(price_id); + +-- provider_ref is the provider's own id for the invoice; unique so a webhook or poller read +-- resolves a payment to exactly one invoice. +CREATE UNIQUE INDEX @idx_badge_code_invoices_provider_ref ON @badge_code_invoices(provider_ref); +|] + -- Two filters run on every poller pass and neither may read the whole table, or the pass + -- lengthens for as long as the service keeps selling: the expiry sweep, on (status, expires_at), + -- and the read lane, which takes a window of created_at. Status leads the first because it is + -- matched by equality there; the second matches it with <>, which no index can seek, so it seeks + -- the window and filters what little that leaves. + <> withPrefix + servicePrefix + [sql| +CREATE INDEX @idx_invoices_status_expires_at ON @invoices(status, expires_at); + +CREATE INDEX @idx_invoices_created ON @invoices(created_at); |] -down_m20260806_badge_service_schema :: Query -down_m20260806_badge_service_schema = +down_m20260915_badge_service_schema :: Query +down_m20260915_badge_service_schema = withPrefix servicePrefix [sql| +DROP INDEX @idx_invoices_created; +DROP INDEX @idx_invoices_status_expires_at; + +DROP INDEX @idx_badge_code_invoices_provider_ref; DROP INDEX @idx_badge_code_invoices_offer; DROP INDEX @idx_badge_code_invoices_price; DROP TABLE @badge_code_invoices; diff --git a/apps/simplex-badge-service/src/BadgeService/Waiters.hs b/apps/simplex-badge-service/src/BadgeService/Waiters.hs new file mode 100644 index 0000000000..d074b28185 --- /dev/null +++ b/apps/simplex-badge-service/src/BadgeService/Waiters.hs @@ -0,0 +1,91 @@ +{-# LANGUAGE NamedFieldPuns #-} + +module BadgeService.Waiters (Waiters, Seen, newWaiters, publish, publishPayment, awaitStatus, waitingCount, waitingCountSTM) where + +import Control.Concurrent.STM +import Control.Exception (bracket) +import Control.Monad (forM_, when) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Maybe (fromMaybe, isNothing) +import Data.Text (Text) +import Simplex.Chat.PaymentService.Types (InvoiceId (..), InvoiceStatus) + +-- | wStatus stays Nothing until a publish or a read fills it, so a publish mid-read is not overwritten by the older answer. +data Watch = Watch {wStatus :: TVar (Maybe InvoiceStatus), wPayments :: TVar Int, wRefs :: TVar Int} + +newtype Waiters = Waiters (TVar (Map Text Watch)) + +type Seen = (InvoiceStatus, (Text, Bool)) + +newWaiters :: IO Waiters +newWaiters = Waiters <$> newTVarIO Map.empty + +-- | Call after the settling transaction commits. The reader re-reads the row, so an overwriting publish costs nothing. +publish :: Waiters -> InvoiceId -> InvoiceStatus -> STM () +publish (Waiters wv) (InvoiceId iid) status = do + watches <- readTVar wv + forM_ (Map.lookup iid watches) $ \Watch {wStatus} -> writeTVar wStatus (Just status) + +-- | Call after the commit, for a payment that did not move the status. +publishPayment :: Waiters -> InvoiceId -> STM () +publishPayment (Waiters wv) (InvoiceId iid) = do + watches <- readTVar wv + forM_ (Map.lookup iid watches) $ \Watch {wPayments} -> modifyTVar' wPayments (+ 1) + +subscribe :: Waiters -> InvoiceId -> STM Watch +subscribe (Waiters wv) (InvoiceId iid) = do + watches <- readTVar wv + case Map.lookup iid watches of + Just watch@Watch {wRefs} -> do + modifyTVar' wRefs (+ 1) + pure watch + Nothing -> do + status <- newTVar Nothing + payments <- newTVar 0 + refs <- newTVar 1 + let watch = Watch {wStatus = status, wPayments = payments, wRefs = refs} + writeTVar wv (Map.insert iid watch watches) + pure watch + +release :: Waiters -> InvoiceId -> STM () +release (Waiters wv) (InvoiceId iid) = do + watches <- readTVar wv + forM_ (Map.lookup iid watches) $ \Watch {wRefs} -> do + n <- pred <$> readTVar wRefs + if n <= 0 + then writeTVar wv (Map.delete iid watches) + else writeTVar wRefs n + +-- | Subscribe, then read, then block; reading first would miss a settlement landing in between. +awaitStatus :: Waiters -> InvoiceId -> IO Seen -> Seen -> Int -> IO InvoiceStatus +awaitStatus w iid readSeen seen@(seenStatus, _) usec = + bracket (atomically $ subscribe w iid) (const . atomically $ release w iid) $ \Watch {wStatus, wPayments} -> do + paidAt <- readTVarIO wPayments + current@(currentStatus, _) <- readSeen -- after subscribing, never before + -- a publish that landed between subscribe and this read is the fresher answer, so keep it + atomically $ readTVar wStatus >>= \published -> when (isNothing published) (writeTVar wStatus (Just currentStatus)) + if current /= seen + then pure currentStatus + else do + timer <- registerDelay usec + atomically $ + ( do + published <- readTVar wStatus + payments <- readTVar wPayments + case published of + -- seeded above and only republished, so this stays `Just` while the bracket holds its reference + Just s | s /= seenStatus || payments /= paidAt -> pure s + _ -> retry + ) + `orElse` ( do + readTVar timer >>= check + fromMaybe seenStatus <$> readTVar wStatus + ) + +waitingCount :: Waiters -> IO Int +waitingCount = atomically . waitingCountSTM + +-- | In STM so the poller can block on it changing, letting an arriving browser shorten the sleep it lands in. +waitingCountSTM :: Waiters -> STM Int +waitingCountSTM (Waiters wv) = Map.size <$> readTVar wv diff --git a/apps/simplex-badge-service/src/BadgeService/Web/Server.hs b/apps/simplex-badge-service/src/BadgeService/Web/Server.hs new file mode 100644 index 0000000000..0f600e931b --- /dev/null +++ b/apps/simplex-badge-service/src/BadgeService/Web/Server.hs @@ -0,0 +1,739 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module BadgeService.Web.Server + ( WebEnv (..), + Limit (..), + newWebEnv, + exportWebapp, + takeToken, + maxBuckets, + maxWebhookBytes, + webApp, + webSettings, + runWebListener, + holdMicros, + readLimit, + ) +where + +import BadgeService.Catalog (PricedOffer (..), priceOffer) +import BadgeService.Config (BTCPayConfig (..), ListenerConfig (..), ServiceConfig (..), SpeedPolicy (..), StripeConfig (..), defaultExpiryMinutes, defaultSessionMinutes) +import BadgeService.Poller (ReadHints, queueReadHint) +import BadgeService.Providers (OrderDraft (..), Provider (..), ProviderError (..), ProviderInvoice (..), WebhookError (..)) +import BadgeService.Store.Invoices (CreateError (..), InvoicePayment (..), InvoiceRow (..), NewInvoice (..), cancelOpenInvoice, codeHashExists, createInvoiceRows, cryptoCurrencyText, getInvoice, getInvoiceByProviderRef, invoiceStatusText, newInvoiceId, paymentHolds, readCatalogRows, textToInvoiceStatus, truncateToSecond) +import BadgeService.Waiters (Seen, Waiters, awaitStatus, publish) +import Control.Concurrent.STM +import qualified Control.Exception as E +import BadgeService.Log (logError, logInfo, logWarn) +import Control.Monad (forM_, when) +import Data.Aeson ((.=)) +import qualified Data.Aeson as J +import qualified Data.Aeson.KeyMap as KM +import Data.Aeson.Types (Pair) +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Base64.URL as B64U +import qualified Data.ByteString.Char8 as B +import qualified Data.ByteString.Lazy as LB +import Data.Char (toLower) +import Data.List (find, isPrefixOf, sortOn) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Maybe (fromMaybe) +import Data.String (fromString) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Text.Encoding (decodeUtf8', encodeUtf8) +import Data.Time.Clock (NominalDiffTime, UTCTime, addUTCTime, diffUTCTime, getCurrentTime) +import Data.Word (Word16) +import Network.HTTP.Types (Header, Status, hCacheControl, hContentType, status200, status400, status404, status405, status409, status413, status429, status500, status503) +import Network.Socket (SockAddr (..), hostAddress6ToTuple, hostAddressToTuple) +import Network.Wai +import qualified Network.Wai.Handler.Warp as Warp +import Numeric (showHex) +import Simplex.Chat.Badges.Types (BadgeOfferId (..), BadgePriceId (..)) +import Simplex.Chat.PaymentService.Types (CardProvider (..), CryptoCurrency (..), CurrencyAmount (..), InvoiceId (..), InvoiceStatus (..), PaymentProvider (..), ServicePaymentDestination (..), ServicePaymentMethod (..)) +import Simplex.Messaging.Agent.Store.Common (DBStore) +import Simplex.Messaging.Encoding.String (textEncode) +import Simplex.Messaging.Util (safeDecodeUtf8, tshow) +import System.Directory (canonicalizePath, copyFile, createDirectoryIfMissing, doesDirectoryExist, doesFileExist, listDirectory, removePathForcibly) +import System.FilePath (pathSeparator, takeExtension, ()) +import Text.Read (readMaybe) + +data WebEnv = WebEnv + { weStore :: DBStore, + weConfig :: ServiceConfig, + weWaiters :: Waiters, + weProviders :: [Provider], + weHoldMicros :: Int, + weHints :: ReadHints, + weBuckets :: TVar (Map Text Bucket), + -- | @Nothing@ when no Stripe key is configured, and the pristine @static_dir@ shell is served instead. + weShell :: Maybe LB.ByteString + } + +newWebEnv :: DBStore -> ServiceConfig -> Waiters -> ReadHints -> [Provider] -> IO WebEnv +newWebEnv weStore weConfig weWaiters weHints weProviders = do + weBuckets <- newTVarIO Map.empty + weShell <- prepareShell (listener weConfig) (stripe weConfig) + pure WebEnv {weStore, weConfig, weWaiters, weProviders, weHoldMicros = holdMicros, weHints, weBuckets, weShell} + +listenerConfig :: WebEnv -> ListenerConfig +listenerConfig WebEnv {weConfig} = listener weConfig + +type Respond = Response -> IO ResponseReceived + +-- | Short enough to stay under the idle timeout of any proxy in front of us. +holdMicros :: Int +holdMicros = 30 * 1000000 + +readLimit :: Limit +readLimit = Limit {lmName = "read", lmPerMinute = 60} + +createLimit :: Limit +createLimit = Limit {lmName = "create", lmPerMinute = 5} + +maxBodyBytes :: Int +maxBodyBytes = 8192 + +maxWebhookBytes :: Int +maxWebhookBytes = 64 * 1024 + +sha256Bytes :: Int +sha256Bytes = 32 + +codeHashChars :: Int +codeHashChars = 43 + +data Limit = Limit {lmName :: Text, lmPerMinute :: Int} + deriving (Eq, Show) + +data Bucket = Bucket {bkCount :: Int, bkStarted :: UTCTime} + +limitWindow :: NominalDiffTime +limitWindow = 60 + +maxBuckets :: Int +maxBuckets = 8192 + +reclaim :: UTCTime -> Map Text Bucket -> Map Text Bucket +reclaim now buckets + | Map.size buckets < maxBuckets = buckets + | Map.size live * 2 <= maxBuckets = live + | otherwise = Map.fromList (drop (Map.size live `div` 2) (sortOn (bkCount . snd) (Map.toList live))) + where + live = Map.filter (fresh now) buckets + +fresh :: UTCTime -> Bucket -> Bool +fresh now Bucket {bkStarted} = diffUTCTime now bkStarted < limitWindow + +takeToken :: WebEnv -> Limit -> Text -> IO (Maybe Int) +takeToken WebEnv {weBuckets} Limit {lmName, lmPerMinute} client = do + now <- getCurrentTime + atomically $ do + buckets <- reclaim now <$> readTVar weBuckets + let key = lmName <> "\t" <> client + count bucket = writeTVar weBuckets (Map.insert key bucket buckets) >> pure Nothing + -- write the reclaimed map back here too, or a refused request redoes the filtering every time and the map stays at the limit + refuse seconds = writeTVar weBuckets buckets >> pure (Just seconds) + case Map.lookup key buckets of + Just bucket@Bucket {bkCount, bkStarted} + | fresh now bucket -> + if bkCount < lmPerMinute + then count bucket {bkCount = bkCount + 1} + else refuse (secondsLeft now bkStarted) + _ -> count Bucket {bkCount = 1, bkStarted = now} + where + secondsLeft :: UTCTime -> UTCTime -> Int + secondsLeft now started = max 1 (ceiling (limitWindow - diffUTCTime now started)) + +limited :: WebEnv -> Limit -> Request -> Respond -> IO ResponseReceived -> IO ResponseReceived +limited env limit req respond action = + takeToken env limit (clientKey env req) >>= \case + Nothing -> action + Just seconds -> respond (rateLimited seconds) + +-- | Every line is joined first, so a second header line a caller adds cannot leave its own line the one we read. +clientKey :: WebEnv -> Request -> Text +clientKey env req = fromMaybe (peerText (remoteHost req)) forwarded + where + forwarded + | not (lTrustForwardedFor (listenerConfig env)) = Nothing + | otherwise = case reverse (concatMap entries (requestHeaders req)) of + (ip : _) | isIpAddress ip -> Just ip + _ -> Nothing + entries (name, raw) + | name /= "x-forwarded-for" = [] + | otherwise = either (const []) (filter (not . T.null) . map T.strip . T.splitOn ",") (decodeUtf8' raw) + +isIpAddress :: Text -> Bool +isIpAddress t = isIPv4 t || isIPv6 t + +asciiDigit :: Char -> Bool +asciiDigit c = c >= '0' && c <= '9' + +-- Data.Char.isDigit and isHexDigit accept Unicode digits, which are not addresses. +asciiHexDigit :: Char -> Bool +asciiHexDigit c = asciiDigit c || (c >= 'a' && c <= 'f') || (c >= 'A' && c <= 'F') + +-- | A leading zero is refused, so "010.0.0.1" cannot be a second key for "10.0.0.1". +isIPv4 :: Text -> Bool +isIPv4 t = case T.splitOn "." t of + [a, b, c, d] -> all octet [a, b, c, d] + _ -> False + where + octet s = + not (T.null s) + && T.length s <= 3 + && T.all asciiDigit s + && (T.length s == 1 || T.head s /= '0') + && maybe False (<= 255) (readMaybe (T.unpack s) :: Maybe Int) + +isIPv6 :: Text -> Bool +isIPv6 t + | T.any (== '%') t = False + | otherwise = case T.splitOn "::" t of + [full] -> groupCount True (segments full) == Just 8 + [before, after] -> case (groupCount False (segments before), groupCount True (segments after)) of + (Just b, Just a) -> b + a <= 7 -- "::" stands for at least one omitted group + _ -> False + _ -> False + where + segments s = if T.null s then [] else T.splitOn ":" s + +groupCount :: Bool -> [Text] -> Maybe Int +groupCount endsAddress gs + | null gs = Just 0 + | endsAddress && isIPv4 (last gs) = (+ 2) <$> plainGroups (init gs) + | otherwise = plainGroups gs + where + plainGroups ps = if all hexGroup ps then Just (length ps) else Nothing + hexGroup g = not (T.null g) && T.length g <= 4 && T.all asciiHexDigit g + +peerText :: SockAddr -> Text +peerText = \case + SockAddrInet _ addr -> + let (a, b, c, d) = hostAddressToTuple addr + in T.intercalate "." (map tshowInt [a, b, c, d]) + SockAddrInet6 _ _ addr _ -> + let (a, b, c, d, e, f, g, h) = hostAddress6ToTuple addr + in T.intercalate ":" (map hex16 [a, b, c, d, e, f, g, h]) + SockAddrUnix p -> "unix:" <> T.pack p + where + tshowInt :: Show a => a -> Text + tshowInt = T.pack . show + hex16 :: Word16 -> Text + hex16 w = T.pack (showHex w "") + +apiHeaders :: [Header] +apiHeaders = [(hContentType, "application/json"), (hCacheControl, "no-store")] + +jsonResponse :: Status -> J.Value -> Response +jsonResponse st = responseLBS st apiHeaders . J.encode + +jsonError :: Status -> Text -> Response +jsonError st code = jsonResponse st (J.object ["error" .= code]) + +notFound :: Response +notFound = jsonError status404 "not_found" + +badRequest :: Response +badRequest = jsonError status400 "bad_request" + +catalogChanged :: Response +catalogChanged = jsonError status400 "catalog_changed" + +codeConflict :: Response +codeConflict = jsonError status409 "code_conflict" + +providerUnavailable :: Response +providerUnavailable = jsonError status503 "provider_unavailable" + +rateLimited :: Int -> Response +rateLimited seconds = + responseLBS + status429 + (("Retry-After", B.pack (show seconds)) : apiHeaders) + (J.encode (J.object ["error" .= ("rate_limited" :: Text)])) + +methodNotAllowed :: ByteString -> Response +methodNotAllowed allow = responseLBS status405 (("Allow", allow) : apiHeaders) (J.encode (J.object ["error" .= ("method_not_allowed" :: Text)])) + +internalError :: Response +internalError = jsonError status500 "internal" + +webhookOk, webhookRefused, webhookTooLarge :: Response +webhookOk = webhookResponse status200 +webhookRefused = webhookResponse status400 +webhookTooLarge = webhookResponse status413 + +webhookResponse :: Status -> Response +webhookResponse st = responseLBS st [(hCacheControl, "no-store")] "" + +webApp :: WebEnv -> Application +webApp env req respond = case pathInfo req of + [] | serving -> only "GET" $ case weShell env of + Just shell -> respond (responseLBS status200 shellHeaders shell) + Nothing -> serveStatic env ["index.html"] respond + "assets" : rest | serving -> only "GET" $ serveStatic env ("assets" : rest) respond + ["sw.js"] | serving -> only "GET" $ serveStatic env ["sw.js"] respond + ["api", "invoice"] -> only "POST" $ limited env createLimit req respond $ createInvoiceHandler env req respond + ["api", "invoice", iid] -> only "GET" $ limited env readLimit req respond $ readInvoiceHandler env (InvoiceId iid) req respond + ["api", "invoice", iid, "cancel"] -> only "POST" $ limited env createLimit req respond $ cancelInvoiceHandler env (InvoiceId iid) respond + ["webhooks", "btcpay"] -> only "POST" $ webhookHandler env PPCrypto "POST /webhooks/btcpay" req respond + ["webhooks", "stripe"] -> only "POST" $ webhookHandler env PPStripe "POST /webhooks/stripe" req respond + _ -> respond notFound + where + serving = lServeWebapp (listenerConfig env) + only method action + | requestMethod req == method = action + | otherwise = respond (methodNotAllowed method) + +-- | A @".."@ check would miss separators WAI has already decoded, an absolute path, and a symlink out of the tree. +serveStatic :: WebEnv -> [Text] -> Respond -> IO ResponseReceived +serveStatic env segments respond = + resolveInside (lStaticDir (listenerConfig env)) segments >>= \case + Nothing -> respond notFound + Just (root, file) -> respond (responseFile status200 (staticHeaders root file) file Nothing) + +shellHeaders :: [Header] +shellHeaders = [(hContentType, "text/html; charset=utf-8"), (hCacheControl, "no-cache")] + +publishableKeyMeta :: Text +publishableKeyMeta = "id=\"stripe-publishable-key\" name=\"stripe-publishable-key\" content=\"" + +-- | @Nothing@ (serve the pristine file) when no key is set, no shell is present, or it cannot be read. +prepareShell :: ListenerConfig -> Maybe StripeConfig -> IO (Maybe LB.ByteString) +prepareShell _ Nothing = pure Nothing +prepareShell ListenerConfig {lStaticDir} (Just StripeConfig {sPublishableKey}) = + E.try attempt >>= \case + Right out -> pure out + Left (e :: E.IOException) -> do + logWarn ("could not read the shell in " <> T.pack lStaticDir <> ", serving the pristine one: " <> tshow e) + pure Nothing + where + attempt :: IO (Maybe LB.ByteString) + attempt = do + let shell = lStaticDir "index.html" + present <- doesFileExist shell + if not present + then pure Nothing + else do + -- TIO.readFile would decode in the locale's encoding, which fails outright under a C locale. + bytes <- BS.readFile shell + case decodeUtf8' bytes of + Left e -> do + logWarn ("the shell in " <> T.pack lStaticDir <> " is not valid UTF-8, serving the pristine one: " <> tshow e) + pure Nothing + Right html -> pure (Just (LB.fromStrict (encodeUtf8 (injectPublishableKey sPublishableKey html)))) + +exportWebapp :: ListenerConfig -> Maybe StripeConfig -> IO () +exportWebapp lc@ListenerConfig {lStaticDir, lWebappExportDir} stripeCfg = + forM_ lWebappExportDir $ \out -> do + emptyDir out + copyTree lStaticDir out + prepareShell lc stripeCfg >>= mapM_ (LB.writeFile (out "index.html")) + logInfo ("badge service: exported the webapp to " <> T.pack out) + +-- | Contents only: the directory itself may be a bind or volume mount point that cannot be removed. +emptyDir :: FilePath -> IO () +emptyDir dir = do + createDirectoryIfMissing True dir + entries <- listDirectory dir + forM_ entries (removePathForcibly . (dir )) + +copyTree :: FilePath -> FilePath -> IO () +copyTree src dst = do + isDir <- doesDirectoryExist src + if isDir + then do + createDirectoryIfMissing True dst + listDirectory src >>= mapM_ (\e -> copyTree (src e) (dst e)) + else copyFile src dst + +injectPublishableKey :: Text -> Text -> Text +injectPublishableKey key = T.replace (publishableKeyMeta <> "\"") (publishableKeyMeta <> key <> "\"") + +resolveInside :: FilePath -> [Text] -> IO (Maybe (FilePath, FilePath)) +resolveInside dir segments = either ioFailed id <$> E.try attempt + where + -- a NUL byte in the path makes the calls below throw + ioFailed :: E.IOException -> Maybe (FilePath, FilePath) + ioFailed _ = Nothing + attempt :: IO (Maybe (FilePath, FilePath)) + attempt = do + root <- canonicalizePath dir + file <- canonicalizePath (foldl (\acc s -> acc T.unpack s) root segments) + exists <- doesFileExist file + pure $ if exists && inside root file then Just (root, file) else Nothing + inside :: FilePath -> FilePath -> Bool + inside root file = (root <> [pathSeparator]) `isPrefixOf` file + +-- | The page at @\/@ must not be cached, or a browser would keep asking for assets from a build we no longer have. +staticHeaders :: FilePath -> FilePath -> [Header] +staticHeaders root file = + [ (hContentType, contentTypeFor file), + (hCacheControl, if hashedAsset then "public, max-age=31536000, immutable" else "no-cache") + ] + where + -- read off the resolved path, not the request: `/assets//%2e%2e/%2e%2e/index.html` resolves to the shell + hashedAsset = (root "assets" <> [pathSeparator]) `isPrefixOf` file + +contentTypeFor :: FilePath -> ByteString +contentTypeFor file = case map toLower (takeExtension file) of + ".html" -> "text/html; charset=utf-8" + ".css" -> "text/css; charset=utf-8" + ".js" -> "text/javascript; charset=utf-8" + ".json" -> "application/json" + ".webmanifest" -> "application/manifest+json" + ".svg" -> "image/svg+xml" + ".png" -> "image/png" + ".ico" -> "image/vnd.microsoft.icon" + ".woff2" -> "font/woff2" + ".txt" -> "text/plain; charset=utf-8" + _ -> "application/octet-stream" + +readInvoiceHandler :: WebEnv -> InvoiceId -> Request -> Respond -> IO ResponseReceived +readInvoiceHandler env@WebEnv {weStore} invId req respond = + getInvoice weStore invId >>= \case + Nothing -> respond notFound + Just row -> case holdFor row of + Nothing -> respond (jsonResponse status200 (invoiceView (confirmationsFor env) row)) + Just seen -> do + -- Settlement publishes after it commits, so the row read below is at least as new as whatever woke us. + _ <- awaitStatus (weWaiters env) invId readSeen seen (weHoldMicros env) + getInvoice weStore invId >>= \case + Nothing -> respond notFound + Just row' -> respond (jsonResponse status200 (invoiceView (confirmationsFor env) row')) + where + holdFor :: InvoiceRow -> Maybe Seen + holdFor row@InvoiceRow {irStatus} = case waitParam req of + Just seen | seen == irStatus, seen /= ISPaid, samePayment -> Just (irStatus, paymentMark row) + _ -> Nothing + where + -- The counter a hold watches starts at zero, so a payment recorded before this request arrived cannot wake it. + samePayment = case paidParam req of + Nothing -> True + Just seen -> seen == paymentMark row + readSeen :: IO Seen + readSeen = maybe (ISOpen, ("", False)) (\row -> (irStatus row, paymentMark row)) <$> getInvoice weStore invId + +-- | Monero reports a payment as confirming while its figures are zero, so the verdict counts as much as the figure. +paymentMark :: InvoiceRow -> (Text, Bool) +paymentMark InvoiceRow {irPayment} = + (maybe "" (fromMaybe "" . ipCryptoPaid) irPayment, maybe False ipPaidInFull irPayment) + +-- | The provider is cancelled first, because cancelling our record first would leave an address the buyer can still pay into with nothing watching it. +cancelInvoiceHandler :: WebEnv -> InvoiceId -> Respond -> IO ResponseReceived +cancelInvoiceHandler env@WebEnv {weStore} invId respond = + getInvoice weStore invId >>= \case + Nothing -> respond notFound + Just InvoiceRow {irStatus} | irStatus /= ISOpen -> respond (jsonError status409 "not_open") + Just row | funded row -> respond (jsonError status409 "funded") + Just InvoiceRow {irProvider, irProviderRef} -> case providerNamed env irProvider of + Nothing -> respond providerUnavailable + Just Provider {pCancelInvoice} -> + pCancelInvoice irProviderRef >>= \case + Left (ProviderError e) -> do + logError $ "cancel order " <> irProviderRef <> ": " <> e + respond providerUnavailable + Right () -> finish + where + funded InvoiceRow {irPayment} = maybe False paymentHolds irPayment + finish = do + now <- getCurrentTime + cancelled <- cancelOpenInvoice weStore invId now + when cancelled $ atomically $ publish (weWaiters env) invId ISExpired + getInvoice weStore invId >>= \case + Nothing -> respond notFound + Just row -> respond (jsonResponse status200 (invoiceView (confirmationsFor env) row)) + +paidParam :: Request -> Maybe (Text, Bool) +paidParam req = case lookup "seenPaid" (queryString req) of + Just raw -> (\seen -> (seen, fullParam)) <$> either (const Nothing) Just (decodeUtf8' (fromMaybe "" raw)) + Nothing -> Nothing + where + fullParam = lookup "seenFull" (queryString req) == Just (Just "1") + +waitParam :: Request -> Maybe InvoiceStatus +waitParam req = case lookup "wait" (queryString req) of + Just (Just raw) -> either (const Nothing) textToInvoiceStatus (decodeUtf8' raw) + _ -> Nothing + +-- | Greenfield reports no confirmation count, so this comes from the store's speed policy. +confirmationsFor :: WebEnv -> Maybe Int +confirmationsFor WebEnv {weConfig} = speedPolicyConfirmations . bSpeedPolicy <$> btcpay weConfig + +-- | BTCPay's own store setting, whose numbering is not in speed order. +speedPolicyConfirmations :: SpeedPolicy -> Int +speedPolicyConfirmations = \case + HighSpeed -> 0 + MediumSpeed -> 1 + LowMediumSpeed -> 2 + LowSpeed -> 6 + +invoiceView :: Maybe Int -> InvoiceRow -> J.Value +invoiceView confirmations InvoiceRow {irBadgeType, irMonths, irAmount, irCurrency, irDestination, irExpiresAt, irStatus, irPayment} = + J.object $ + [ "status" .= invoiceStatusText irStatus, + "badgeType" .= (textEncode irBadgeType :: Text), + "months" .= irMonths, + "amount" .= amountJSON irAmount, + "currency" .= irCurrency, + "expiresAt" .= irExpiresAt + ] + <> destinationPairs confirmations irDestination + <> paidPairs + where + paidPairs = maybe [] paymentPairs irPayment + paymentPairs p = + concat + [ maybe [] (\a -> ["amountPaid" .= amountJSON a]) (ipAmount p), + maybe [] (\a -> ["cryptoAmountPaid" .= a]) (ipCryptoPaid p), + maybe [] (\a -> ["cryptoAmountDue" .= a]) (ipCryptoDue p), + ["paidInFull" .= ipPaidInFull p], + ["settledAt" .= ipUpdatedAt p | irStatus == ISPaid] + ] + +destinationPairs :: Maybe Int -> ServicePaymentDestination -> [Pair] +destinationPairs confirmations = \case + SPDCard _ url -> ["clientSecret" .= url] + SPDCrypto currency address cryptoAmount -> + [ "address" .= address, + "cryptoAmount" .= cryptoAmount, + "cryptoCurrency" .= cryptoCurrencyText currency + ] + <> maybe [] (\n -> ["requiredConfirmations" .= n]) confirmations + +amountJSON :: CurrencyAmount -> J.Value +amountJSON (CurrencyAmount a) = J.toJSON a + +data CreateRequest = CreateRequest + { crPriceId :: BadgePriceId, + crOfferId :: Maybe BadgeOfferId, + crMethod :: ServicePaymentMethod, + crCodeHash :: ByteString + } + +createInvoiceHandler :: WebEnv -> Request -> Respond -> IO ResponseReceived +createInvoiceHandler env@WebEnv {weStore} req respond = + readBoundedBody maxBodyBytes req >>= \case + Nothing -> refuse "body over the size limit" badRequest + Just body -> case parseCreateRequest body of + Nothing -> refuse "malformed body" badRequest + Just cr@CreateRequest {crPriceId, crOfferId, crMethod, crCodeHash} -> do + (prices, offers) <- readCatalogRows weStore + case priceOffer prices offers crPriceId crOfferId of + Left reason -> refuse (tshow reason) catalogChanged + Right priced -> + codeHashExists weStore crCodeHash >>= \case + True -> refuse "code hash already sold" codeConflict + False -> case providerFor env crMethod of + Nothing -> refuse ("no provider configured for " <> tshow crMethod) providerUnavailable + Just provider -> createAtProvider env provider cr priced respond + where + refuse :: Text -> Response -> IO ResponseReceived + refuse why response = logInfo ("POST /api/invoice refused: " <> why) >> respond response + +-- | Once the provider call succeeds an invoice exists at BTCPay, and any path below that does not write our rows leaves it stranded. +createAtProvider :: WebEnv -> Provider -> CreateRequest -> PricedOffer -> Respond -> IO ResponseReceived +createAtProvider WebEnv {weStore, weConfig} provider CreateRequest {crPriceId, crOfferId, crMethod, crCodeHash} priced respond = + do + invId <- newInvoiceId + -- truncate once, so the response, the row and the provider get the same value + now <- truncateToSecond <$> getCurrentTime + let expiresAt = addUTCTime (invoiceWindow weConfig crMethod) now + draft = OrderDraft {odAmount = poAmount priced, odCurrency = poCurrency priced} + pCreateInvoice provider crMethod draft >>= \case + Left (ProviderError e) -> failed ("provider refused to create an invoice: " <> e) providerUnavailable + Right ProviderInvoice {piProviderRef, piDestination} -> do + let atProvider = "providerRef " <> piProviderRef + ni = + NewInvoice + { niInvoiceId = invId, + niProviderRef = piProviderRef, + niCodeHash = crCodeHash, + niPriceId = crPriceId, + niOfferId = crOfferId, + niBadgeType = poBadgeType priced, + niMonths = poMonths priced, + niPrice = poPrice priced, + niAmount = poAmount priced, + niCurrency = poCurrency priced, + niProvider = pProvider provider, + niDestination = piDestination, + niExpiresAt = expiresAt, + niCreatedAt = now + } + createInvoiceRows weStore ni >>= \case + Left CECodeConflict -> logInfo ("POST /api/invoice: code hash lost the race, invoice abandoned at the provider (" <> atProvider <> ")") >> respond codeConflict + Left e -> failed ("invoice rows not written, invoice abandoned at the provider (" <> atProvider <> "): " <> tshow e) internalError + Right () -> respond (jsonResponse status200 (createdInvoice invId priced expiresAt piDestination)) + where + failed :: Text -> Response -> IO ResponseReceived + failed why response = logError ("POST /api/invoice failed: " <> why) >> respond response + +createdInvoice :: InvoiceId -> PricedOffer -> UTCTime -> ServicePaymentDestination -> J.Value +createdInvoice (InvoiceId invId) PricedOffer {poBadgeType, poMonths, poAmount, poCurrency} expiresAt destination = + J.object $ + [ "invoiceId" .= invId, + "badgeType" .= (textEncode poBadgeType :: Text), + "months" .= poMonths, + "amount" .= amountJSON poAmount, + "currency" .= poCurrency, + "expiresAt" .= expiresAt + ] + <> destinationPairs Nothing destination + +secondsPerMinute :: Int +secondsPerMinute = 60 + +-- | The expiry shown and stored must come from the same key the provider sets the invoice's real expiry from. +invoiceWindow :: ServiceConfig -> ServicePaymentMethod -> NominalDiffTime +invoiceWindow cfg = \case + SPMCard CPStripe -> minutes (maybe defaultSessionMinutes sSessionMinutes (stripe cfg)) + SPMCrypto _ -> minutes (maybe defaultExpiryMinutes bExpiryMinutes (btcpay cfg)) + where + minutes n = fromIntegral (secondsPerMinute * n) + +providerFor :: WebEnv -> ServicePaymentMethod -> Maybe Provider +providerFor env method = providerNamed env (providerOf method) + +providerNamed :: WebEnv -> PaymentProvider -> Maybe Provider +providerNamed WebEnv {weProviders} provider = find ((== provider) . pProvider) weProviders + +providerOf :: ServicePaymentMethod -> PaymentProvider +providerOf = \case + SPMCard CPStripe -> PPStripe + SPMCrypto _ -> PPCrypto + +-- | Returns the bytes exactly as they arrived, since the webhook signature is over those bytes. +readBoundedBody :: Int -> Request -> IO (Maybe LB.ByteString) +readBoundedBody cap req = go 0 [] + where + go :: Int -> [ByteString] -> IO (Maybe LB.ByteString) + go read' acc = do + chunk <- getRequestBodyChunk req + if BS.null chunk + then pure (Just (LB.fromChunks (reverse acc))) + else + let read'' = read' + BS.length chunk + in if read'' > cap then pure Nothing else go read'' (chunk : acc) + +parseCreateRequest :: LB.ByteString -> Maybe CreateRequest +parseCreateRequest body = case J.decode body of + Just (J.Object o) -> do + crPriceId <- BadgePriceId <$> textField o "priceId" + crOfferId <- offerField o + crMethod <- methodFromText =<< textField o "method" + crCodeHash <- parseCodeHash =<< textField o "codeHash" + pure CreateRequest {crPriceId, crOfferId, crMethod, crCodeHash} + _ -> Nothing + where + textField o k = case KM.lookup k o of + Just (J.String t) | not (T.null t) -> Just t + _ -> Nothing + offerField o = case KM.lookup "offerId" o of + Nothing -> Just Nothing + Just J.Null -> Just Nothing + Just (J.String t) | not (T.null t) -> Just (Just (BadgeOfferId t)) + _ -> Nothing + +methodFromText :: Text -> Maybe ServicePaymentMethod +methodFromText = \case + "card" -> Just (SPMCard CPStripe) + "btc" -> Just (SPMCrypto CCBtc) + "xmr" -> Just (SPMCrypto CCXmr) + _ -> Nothing + +-- | The last character of a 43-character base64 string has two bits no digest byte uses, so a lax +-- decoder would accept four spellings of the same digest, which the re-encode check rejects. +parseCodeHash :: Text -> Maybe ByteString +parseCodeHash t + | T.length t /= codeHashChars = Nothing + | otherwise = case B64U.decode (encodeUtf8 (t <> "=")) of + Right bytes | BS.length bytes == sha256Bytes, canonical bytes == t -> Just bytes + _ -> Nothing + where + canonical = T.filter (/= '=') . safeDecodeUtf8 . B64U.encode + +-- | A provider retries a delivery it sees fail, so anything thrown below is caught and answered 200 anyway. +webhookHandler :: WebEnv -> PaymentProvider -> Text -> Request -> Respond -> IO ResponseReceived +webhookHandler env@WebEnv {weStore, weHints} provider route req respond = + E.try deliver >>= \case + Right received -> pure received + Left e -> case E.fromException e of + Just async' -> E.throwIO (async' :: E.SomeAsyncException) + Nothing -> do + logError (route <> ": the delivery could not be handled, so no read was queued: " <> tshow (e :: E.SomeException)) + respond webhookOk + where + deliver :: IO ResponseReceived + deliver = case providerNamed env provider of + Nothing -> do + logWarn (route <> ": no " <> tshow provider <> " adapter is configured, so every delivery is refused") + respond webhookRefused + Just p -> + readBoundedBody maxWebhookBytes req >>= \case + Nothing -> logInfo (route <> ": body over the " <> tshow maxWebhookBytes <> "-byte cap") >> respond webhookTooLarge + Just body -> + -- a provider signs the exact bytes it sent, so parsing and re-encoding here would fail the signature on every event + case pVerifyWebhook p (requestHeaders req) (LB.toStrict body) of + Left (WebhookError e) -> refuse e + Right Nothing -> ignore body "nothing this service acts on" + Right (Just ref) -> resolve body ref + refuse :: Text -> IO ResponseReceived + refuse why = logInfo (route <> " refused: " <> why) >> respond webhookRefused + ignore :: LB.ByteString -> Text -> IO ResponseReceived + ignore body why = logEvent body why >> respond webhookOk + logEvent :: LB.ByteString -> Text -> IO () + logEvent body what = case eventTypeOf body of + Just t -> logInfo (route <> ": " <> t <> ", " <> what) + Nothing -> logWarn (route <> ": " <> noEventType <> ", " <> what) + noEventType :: Text + noEventType = "a verified payload with no readable \"type\"" + resolve :: LB.ByteString -> Text -> IO ResponseReceived + resolve body ref = + getInvoiceByProviderRef weStore ref >>= \case + Nothing -> ignore body ("no invoice holds provider_ref " <> ref) + Just InvoiceRow {irProvider} + -- provider_ref is unique table-wide, not per provider, so without this a collision could credit the wrong order + | irProvider /= provider -> ignore body ("provider_ref " <> ref <> " belongs to " <> tshow irProvider) + | otherwise -> queue body ref + queue :: LB.ByteString -> Text -> IO ResponseReceived + queue body ref = do + queued <- queueReadHint weHints ref + if queued + then logEvent body ("queued a read of " <> ref) + else -- not an error, because the next pass finds this invoice anyway + logWarn (route <> ": " <> fromMaybe noEventType (eventTypeOf body) <> ", the read queue is full, so the read of " <> ref <> " waits for the next pass") + respond webhookOk + +-- | For the log only. A rename of the @type@ field would make every delivery look successful. +eventTypeOf :: LB.ByteString -> Maybe Text +eventTypeOf body = case J.decode body of + Just (J.Object o) | Just (J.String t) <- KM.lookup "type" o -> Just t + _ -> Nothing + +webSettings :: ListenerConfig -> Warp.Settings +webSettings ListenerConfig {lHost, lPort} = + Warp.setHost (fromString (T.unpack lHost)) + . Warp.setPort lPort + . Warp.setOnExceptionResponse (const internalError) + $ Warp.defaultSettings + +runWebListener :: WebEnv -> IO () +runWebListener env = do + warnIfHeaderTrustIsExposed (listenerConfig env) + Warp.runSettings (webSettings (listenerConfig env)) (webApp env) + +warnIfHeaderTrustIsExposed :: ListenerConfig -> IO () +warnIfHeaderTrustIsExposed ListenerConfig {lHost, lTrustForwardedFor} = + when (lTrustForwardedFor && not (isLoopbackHost lHost)) $ + logWarn ("badge service: trust_forwarded_for is on and the listener binds " <> lHost <> "; every caller can then choose its own rate limit bucket unless a proxy sets the header") + +isLoopbackHost :: Text -> Bool +isLoopbackHost h = h `elem` ["127.0.0.1", "::1", "localhost"] diff --git a/apps/simplex-badge-service/test-fixtures/btcpay/invoice-expired.json b/apps/simplex-badge-service/test-fixtures/btcpay/invoice-expired.json new file mode 100644 index 0000000000..7f5cee8aab --- /dev/null +++ b/apps/simplex-badge-service/test-fixtures/btcpay/invoice-expired.json @@ -0,0 +1,36 @@ +{ + "_fixture": "POST /api/v1/stores/{storeId}/invoices and GET .../invoices/{invoiceId} -- InvoiceData with status Expired -- the payment window closed -- from BTCPay's DOCUMENTED Greenfield schema (BTCPay 2.x naming). NOT captured from a live instance; replace `response` with a recorded body and rewrite this line. The fake patches `id`, `status` and `additionalStatus`; everything else is served as written here.", + "response": { + "metadata": {}, + "checkout": { + "speedPolicy": "MediumSpeed", + "paymentMethods": ["BTC-CHAIN"], + "defaultPaymentMethod": null, + "expirationMinutes": 60, + "monitoringMinutes": 4320, + "paymentTolerance": 0.5, + "redirectURL": null, + "redirectAutomatically": false, + "requiresRefundEmail": false, + "defaultLanguage": null + }, + "receipt": { + "enabled": null, + "showQR": null, + "showPayments": null + }, + "id": "GmpP7VDp3jj7HZeJVQpSNP", + "storeId": "BqZKtkeSN9JgLLdCJRJfXQjLwCLDNCVLdxLTTdMzTHnT", + "amount": "54.00", + "currency": "USD", + "type": "Standard", + "checkoutLink": "https://btcpay.example.org/i/GmpP7VDp3jj7HZeJVQpSNP", + "createdTime": 1700000000, + "expirationTime": 1700003600, + "monitoringExpiration": 1700259200, + "status": "Expired", + "additionalStatus": "None", + "availableStatusesForManualMarking": ["Settled", "Invalid"], + "archived": false + } +} diff --git a/apps/simplex-badge-service/test-fixtures/btcpay/invoice-invalid.json b/apps/simplex-badge-service/test-fixtures/btcpay/invoice-invalid.json new file mode 100644 index 0000000000..d1edee72a0 --- /dev/null +++ b/apps/simplex-badge-service/test-fixtures/btcpay/invoice-invalid.json @@ -0,0 +1,36 @@ +{ + "_fixture": "POST /api/v1/stores/{storeId}/invoices and GET .../invoices/{invoiceId} -- InvoiceData with status Invalid -- the invoice was marked invalid, which this design treats as expired -- from BTCPay's DOCUMENTED Greenfield schema (BTCPay 2.x naming). NOT captured from a live instance; replace `response` with a recorded body and rewrite this line. The fake patches `id`, `status` and `additionalStatus`; everything else is served as written here.", + "response": { + "metadata": {}, + "checkout": { + "speedPolicy": "MediumSpeed", + "paymentMethods": ["BTC-CHAIN"], + "defaultPaymentMethod": null, + "expirationMinutes": 60, + "monitoringMinutes": 4320, + "paymentTolerance": 0.5, + "redirectURL": null, + "redirectAutomatically": false, + "requiresRefundEmail": false, + "defaultLanguage": null + }, + "receipt": { + "enabled": null, + "showQR": null, + "showPayments": null + }, + "id": "GmpP7VDp3jj7HZeJVQpSNP", + "storeId": "BqZKtkeSN9JgLLdCJRJfXQjLwCLDNCVLdxLTTdMzTHnT", + "amount": "54.00", + "currency": "USD", + "type": "Standard", + "checkoutLink": "https://btcpay.example.org/i/GmpP7VDp3jj7HZeJVQpSNP", + "createdTime": 1700000000, + "expirationTime": 1700003600, + "monitoringExpiration": 1700259200, + "status": "Invalid", + "additionalStatus": "None", + "availableStatusesForManualMarking": ["Settled", "Invalid"], + "archived": false + } +} diff --git a/apps/simplex-badge-service/test-fixtures/btcpay/invoice-list-alien-method.json b/apps/simplex-badge-service/test-fixtures/btcpay/invoice-list-alien-method.json new file mode 100644 index 0000000000..3339eb44a8 --- /dev/null +++ b/apps/simplex-badge-service/test-fixtures/btcpay/invoice-list-alien-method.json @@ -0,0 +1,133 @@ +{ + "_fixture": "The same list response carrying an invoice paid over Lightning (BTC-LN), which this build does not know: switching Lightning on at the store is all it takes. Hand-written from the documented schema. The alien entry must be SKIPPED and the healthy one in the SAME response must still settle.", + "response": [ + { + "metadata": {}, + "checkout": { + "speedPolicy": "MediumSpeed", + "paymentMethods": [ + "BTC-CHAIN" + ], + "defaultPaymentMethod": null, + "expirationMinutes": 60, + "monitoringMinutes": 4320, + "paymentTolerance": 0.5, + "redirectURL": null, + "redirectAutomatically": false, + "requiresRefundEmail": false, + "defaultLanguage": null + }, + "receipt": { + "enabled": null, + "showQR": null, + "showPayments": null + }, + "id": "LightningInvoiceRefDD", + "storeId": "BqZKtkeSN9JgLLdCJRJfXQjLwCLDNCVLdxLTTdMzTHnT", + "amount": "54.00", + "currency": "USD", + "type": "Standard", + "checkoutLink": "https://btcpay.example.org/i/LightningInvoiceRefDD", + "createdTime": 1700000000, + "expirationTime": 1700003600, + "monitoringExpiration": 1700259200, + "status": "Settled", + "additionalStatus": "None", + "availableStatusesForManualMarking": [ + "Settled", + "Invalid" + ], + "archived": false, + "paymentMethods": [ + { + "paymentMethodId": "BTC-LN", + "currency": "BTC", + "destination": "lnbc500u1pexampleinvoicebolt11string", + "paymentLink": "lightning:lnbc500u1pexampleinvoicebolt11string", + "rate": "108000.12", + "paymentMethodPaid": "0.00050000", + "totalPaid": "9.99999999", + "due": "0.00000000", + "amount": "0.00050000", + "networkFee": "0.00000500", + "activated": true, + "payments": [ + { + "id": "d7a41e0b93c85f26a1804dbe73f52c9a6081ef34d25b7a90c6183fe45b027dac", + "receivedDate": 1700003600, + "value": "0.00050000", + "fee": "0.00000000", + "status": "Settled", + "destination": "lnbc500u1pexampleinvoicebolt11string" + } + ], + "additionalData": {} + } + ] + }, + { + "metadata": {}, + "checkout": { + "speedPolicy": "MediumSpeed", + "paymentMethods": [ + "BTC-CHAIN" + ], + "defaultPaymentMethod": null, + "expirationMinutes": 60, + "monitoringMinutes": 4320, + "paymentTolerance": 0.5, + "redirectURL": null, + "redirectAutomatically": false, + "requiresRefundEmail": false, + "defaultLanguage": null + }, + "receipt": { + "enabled": null, + "showQR": null, + "showPayments": null + }, + "id": "SettledInvoiceRefAAAA", + "storeId": "BqZKtkeSN9JgLLdCJRJfXQjLwCLDNCVLdxLTTdMzTHnT", + "amount": "54.00", + "currency": "USD", + "type": "Standard", + "checkoutLink": "https://btcpay.example.org/i/SettledInvoiceRefAAAA", + "createdTime": 1700000000, + "expirationTime": 1700003600, + "monitoringExpiration": 1700259200, + "status": "Settled", + "additionalStatus": "None", + "availableStatusesForManualMarking": [ + "Settled", + "Invalid" + ], + "archived": false, + "paymentMethods": [ + { + "paymentMethodId": "BTC-CHAIN", + "currency": "BTC", + "destination": "bc1qar0srrr7xfkvy5l643lydnw9re59gtzzwf5mdq", + "paymentLink": "bitcoin:bc1qar0srrr7xfkvy5l643lydnw9re59gtzzwf5mdq?amount=0.00050000", + "rate": "108000.12", + "paymentMethodPaid": "0.00050000", + "totalPaid": "9.99999999", + "due": "0.00000000", + "amount": "0.00050000", + "networkFee": "0.00000500", + "activated": true, + "payments": [ + { + "id": "8e3a1f0c9d2b4a5768f90e1c2d3b4a5968f70e1c2d3b4a5968f70e1c2d3b4a59-0", + "receivedDate": 1700003600, + "value": "0.00050000", + "fee": "0.00000000", + "status": "Settled", + "destination": "bc1qar0srrr7xfkvy5l643lydnw9re59gtzzwf5mdq" + } + ], + "additionalData": {} + } + ] + } + ] +} diff --git a/apps/simplex-badge-service/test-fixtures/btcpay/invoice-list-alien-status.json b/apps/simplex-badge-service/test-fixtures/btcpay/invoice-list-alien-status.json new file mode 100644 index 0000000000..28aad30892 --- /dev/null +++ b/apps/simplex-badge-service/test-fixtures/btcpay/invoice-list-alien-status.json @@ -0,0 +1,133 @@ +{ + "_fixture": "The same list response carrying an invoice whose `status` this build does not know -- the store enumerates every invoice, ours and not. Hand-written from the documented schema, since a real BTCPay will not produce a status on demand. The alien entry must be SKIPPED and the healthy one in the SAME response must still settle.", + "response": [ + { + "metadata": {}, + "checkout": { + "speedPolicy": "MediumSpeed", + "paymentMethods": [ + "BTC-CHAIN" + ], + "defaultPaymentMethod": null, + "expirationMinutes": 60, + "monitoringMinutes": 4320, + "paymentTolerance": 0.5, + "redirectURL": null, + "redirectAutomatically": false, + "requiresRefundEmail": false, + "defaultLanguage": null + }, + "receipt": { + "enabled": null, + "showQR": null, + "showPayments": null + }, + "id": "AlienStatusInvoiceRef", + "storeId": "BqZKtkeSN9JgLLdCJRJfXQjLwCLDNCVLdxLTTdMzTHnT", + "amount": "54.00", + "currency": "USD", + "type": "Standard", + "checkoutLink": "https://btcpay.example.org/i/AlienStatusInvoiceRef", + "createdTime": 1700000000, + "expirationTime": 1700003600, + "monitoringExpiration": 1700259200, + "status": "Frobnicated", + "additionalStatus": "None", + "availableStatusesForManualMarking": [ + "Settled", + "Invalid" + ], + "archived": false, + "paymentMethods": [ + { + "paymentMethodId": "BTC-CHAIN", + "currency": "BTC", + "destination": "bc1qar0srrr7xfkvy5l643lydnw9re59gtzzwf5mdq", + "paymentLink": "bitcoin:bc1qar0srrr7xfkvy5l643lydnw9re59gtzzwf5mdq?amount=0.00050000", + "rate": "108000.12", + "paymentMethodPaid": "0.00050000", + "totalPaid": "9.99999999", + "due": "0.00000000", + "amount": "0.00050000", + "networkFee": "0.00000500", + "activated": true, + "payments": [ + { + "id": "8e3a1f0c9d2b4a5768f90e1c2d3b4a5968f70e1c2d3b4a5968f70e1c2d3b4a59-0", + "receivedDate": 1700003600, + "value": "0.00050000", + "fee": "0.00000000", + "status": "Settled", + "destination": "bc1qar0srrr7xfkvy5l643lydnw9re59gtzzwf5mdq" + } + ], + "additionalData": {} + } + ] + }, + { + "metadata": {}, + "checkout": { + "speedPolicy": "MediumSpeed", + "paymentMethods": [ + "BTC-CHAIN" + ], + "defaultPaymentMethod": null, + "expirationMinutes": 60, + "monitoringMinutes": 4320, + "paymentTolerance": 0.5, + "redirectURL": null, + "redirectAutomatically": false, + "requiresRefundEmail": false, + "defaultLanguage": null + }, + "receipt": { + "enabled": null, + "showQR": null, + "showPayments": null + }, + "id": "SettledInvoiceRefAAAA", + "storeId": "BqZKtkeSN9JgLLdCJRJfXQjLwCLDNCVLdxLTTdMzTHnT", + "amount": "54.00", + "currency": "USD", + "type": "Standard", + "checkoutLink": "https://btcpay.example.org/i/SettledInvoiceRefAAAA", + "createdTime": 1700000000, + "expirationTime": 1700003600, + "monitoringExpiration": 1700259200, + "status": "Settled", + "additionalStatus": "None", + "availableStatusesForManualMarking": [ + "Settled", + "Invalid" + ], + "archived": false, + "paymentMethods": [ + { + "paymentMethodId": "BTC-CHAIN", + "currency": "BTC", + "destination": "bc1qar0srrr7xfkvy5l643lydnw9re59gtzzwf5mdq", + "paymentLink": "bitcoin:bc1qar0srrr7xfkvy5l643lydnw9re59gtzzwf5mdq?amount=0.00050000", + "rate": "108000.12", + "paymentMethodPaid": "0.00050000", + "totalPaid": "9.99999999", + "due": "0.00000000", + "amount": "0.00050000", + "networkFee": "0.00000500", + "activated": true, + "payments": [ + { + "id": "8e3a1f0c9d2b4a5768f90e1c2d3b4a5968f70e1c2d3b4a5968f70e1c2d3b4a59-0", + "receivedDate": 1700003600, + "value": "0.00050000", + "fee": "0.00000000", + "status": "Settled", + "destination": "bc1qar0srrr7xfkvy5l643lydnw9re59gtzzwf5mdq" + } + ], + "additionalData": {} + } + ] + } + ] +} diff --git a/apps/simplex-badge-service/test-fixtures/btcpay/invoice-list-no-id.json b/apps/simplex-badge-service/test-fixtures/btcpay/invoice-list-no-id.json new file mode 100644 index 0000000000..9a8ed8c97f --- /dev/null +++ b/apps/simplex-badge-service/test-fixtures/btcpay/invoice-list-no-id.json @@ -0,0 +1,132 @@ +{ + "_fixture": "A list response carrying an entry with no `id`. Hand-written from the documented schema, where `id` is required. This must FAIL the pass: an invoice the pass cannot even name has no ref to skip and none to log.", + "response": [ + { + "metadata": {}, + "checkout": { + "speedPolicy": "MediumSpeed", + "paymentMethods": [ + "BTC-CHAIN" + ], + "defaultPaymentMethod": null, + "expirationMinutes": 60, + "monitoringMinutes": 4320, + "paymentTolerance": 0.5, + "redirectURL": null, + "redirectAutomatically": false, + "requiresRefundEmail": false, + "defaultLanguage": null + }, + "receipt": { + "enabled": null, + "showQR": null, + "showPayments": null + }, + "id": "SettledInvoiceRefAAAA", + "storeId": "BqZKtkeSN9JgLLdCJRJfXQjLwCLDNCVLdxLTTdMzTHnT", + "amount": "54.00", + "currency": "USD", + "type": "Standard", + "checkoutLink": "https://btcpay.example.org/i/SettledInvoiceRefAAAA", + "createdTime": 1700000000, + "expirationTime": 1700003600, + "monitoringExpiration": 1700259200, + "status": "Settled", + "additionalStatus": "None", + "availableStatusesForManualMarking": [ + "Settled", + "Invalid" + ], + "archived": false, + "paymentMethods": [ + { + "paymentMethodId": "BTC-CHAIN", + "currency": "BTC", + "destination": "bc1qar0srrr7xfkvy5l643lydnw9re59gtzzwf5mdq", + "paymentLink": "bitcoin:bc1qar0srrr7xfkvy5l643lydnw9re59gtzzwf5mdq?amount=0.00050000", + "rate": "108000.12", + "paymentMethodPaid": "0.00050000", + "totalPaid": "9.99999999", + "due": "0.00000000", + "amount": "0.00050000", + "networkFee": "0.00000500", + "activated": true, + "payments": [ + { + "id": "8e3a1f0c9d2b4a5768f90e1c2d3b4a5968f70e1c2d3b4a5968f70e1c2d3b4a59-0", + "receivedDate": 1700003600, + "value": "0.00050000", + "fee": "0.00000000", + "status": "Settled", + "destination": "bc1qar0srrr7xfkvy5l643lydnw9re59gtzzwf5mdq" + } + ], + "additionalData": {} + } + ] + }, + { + "metadata": {}, + "checkout": { + "speedPolicy": "MediumSpeed", + "paymentMethods": [ + "BTC-CHAIN" + ], + "defaultPaymentMethod": null, + "expirationMinutes": 60, + "monitoringMinutes": 4320, + "paymentTolerance": 0.5, + "redirectURL": null, + "redirectAutomatically": false, + "requiresRefundEmail": false, + "defaultLanguage": null + }, + "receipt": { + "enabled": null, + "showQR": null, + "showPayments": null + }, + "storeId": "BqZKtkeSN9JgLLdCJRJfXQjLwCLDNCVLdxLTTdMzTHnT", + "amount": "54.00", + "currency": "USD", + "type": "Standard", + "checkoutLink": "https://btcpay.example.org/i/x", + "createdTime": 1700000000, + "expirationTime": 1700003600, + "monitoringExpiration": 1700259200, + "status": "Settled", + "additionalStatus": "None", + "availableStatusesForManualMarking": [ + "Settled", + "Invalid" + ], + "archived": false, + "paymentMethods": [ + { + "paymentMethodId": "BTC-CHAIN", + "currency": "BTC", + "destination": "bc1qar0srrr7xfkvy5l643lydnw9re59gtzzwf5mdq", + "paymentLink": "bitcoin:bc1qar0srrr7xfkvy5l643lydnw9re59gtzzwf5mdq?amount=0.00050000", + "rate": "108000.12", + "paymentMethodPaid": "0.00050000", + "totalPaid": "9.99999999", + "due": "0.00000000", + "amount": "0.00050000", + "networkFee": "0.00000500", + "activated": true, + "payments": [ + { + "id": "8e3a1f0c9d2b4a5768f90e1c2d3b4a5968f70e1c2d3b4a5968f70e1c2d3b4a59-0", + "receivedDate": 1700003600, + "value": "0.00050000", + "fee": "0.00000000", + "status": "Settled", + "destination": "bc1qar0srrr7xfkvy5l643lydnw9re59gtzzwf5mdq" + } + ], + "additionalData": {} + } + ] + } + ] +} diff --git a/apps/simplex-badge-service/test-fixtures/btcpay/invoice-list-no-payment-methods.json b/apps/simplex-badge-service/test-fixtures/btcpay/invoice-list-no-payment-methods.json new file mode 100644 index 0000000000..02ffeed945 --- /dev/null +++ b/apps/simplex-badge-service/test-fixtures/btcpay/invoice-list-no-payment-methods.json @@ -0,0 +1,43 @@ +{ + "_fixture": "A list response with `paymentMethods` ABSENT, which is what a server that did not honour includePaymentMethods sends. Hand-written from the documented schema. This must FAIL the pass: skipping it would answer `Right []` and report health for as long as nothing ever settled.", + "response": [ + { + "metadata": {}, + "checkout": { + "speedPolicy": "MediumSpeed", + "paymentMethods": [ + "BTC-CHAIN" + ], + "defaultPaymentMethod": null, + "expirationMinutes": 60, + "monitoringMinutes": 4320, + "paymentTolerance": 0.5, + "redirectURL": null, + "redirectAutomatically": false, + "requiresRefundEmail": false, + "defaultLanguage": null + }, + "receipt": { + "enabled": null, + "showQR": null, + "showPayments": null + }, + "id": "NoMethodsInvoiceRefEE", + "storeId": "BqZKtkeSN9JgLLdCJRJfXQjLwCLDNCVLdxLTTdMzTHnT", + "amount": "54.00", + "currency": "USD", + "type": "Standard", + "checkoutLink": "https://btcpay.example.org/i/NoMethodsInvoiceRefEE", + "createdTime": 1700000000, + "expirationTime": 1700003600, + "monitoringExpiration": 1700259200, + "status": "Settled", + "additionalStatus": "None", + "availableStatusesForManualMarking": [ + "Settled", + "Invalid" + ], + "archived": false + } + ] +} diff --git a/apps/simplex-badge-service/test-fixtures/btcpay/invoice-list.json b/apps/simplex-badge-service/test-fixtures/btcpay/invoice-list.json new file mode 100644 index 0000000000..95d477f14f --- /dev/null +++ b/apps/simplex-badge-service/test-fixtures/btcpay/invoice-list.json @@ -0,0 +1,188 @@ +{ + "_fixture": "GET /api/v1/stores/{storeId}/invoices?includePaymentMethods=true&startDate=... -- InvoiceData[] with the payment methods inline, from BTCPay's DOCUMENTED Greenfield schema. NOT captured from a live instance; replace `response` with a recorded body and rewrite this line. Three invoices: one Settled, one Processing, and one New with nothing received -- the last of which the pass must report as unmoved rather than omit by accident.", + "response": [ + { + "metadata": {}, + "checkout": { + "speedPolicy": "MediumSpeed", + "paymentMethods": [ + "BTC-CHAIN" + ], + "defaultPaymentMethod": null, + "expirationMinutes": 60, + "monitoringMinutes": 4320, + "paymentTolerance": 0.5, + "redirectURL": null, + "redirectAutomatically": false, + "requiresRefundEmail": false, + "defaultLanguage": null + }, + "receipt": { + "enabled": null, + "showQR": null, + "showPayments": null + }, + "id": "SettledInvoiceRefAAAA", + "storeId": "BqZKtkeSN9JgLLdCJRJfXQjLwCLDNCVLdxLTTdMzTHnT", + "amount": "54.00", + "currency": "USD", + "type": "Standard", + "checkoutLink": "https://btcpay.example.org/i/SettledInvoiceRefAAAA", + "createdTime": 1700000000, + "expirationTime": 1700003600, + "monitoringExpiration": 1700259200, + "status": "Settled", + "additionalStatus": "None", + "availableStatusesForManualMarking": [ + "Settled", + "Invalid" + ], + "archived": false, + "paymentMethods": [ + { + "paymentMethodId": "BTC-CHAIN", + "currency": "BTC", + "destination": "bc1qar0srrr7xfkvy5l643lydnw9re59gtzzwf5mdq", + "paymentLink": "bitcoin:bc1qar0srrr7xfkvy5l643lydnw9re59gtzzwf5mdq?amount=0.00050000", + "rate": "108000.12", + "paymentMethodPaid": "0.00050000", + "totalPaid": "9.99999999", + "due": "0.00000000", + "amount": "0.00050000", + "networkFee": "0.00000500", + "activated": true, + "payments": [ + { + "id": "8e3a1f0c9d2b4a5768f90e1c2d3b4a5968f70e1c2d3b4a5968f70e1c2d3b4a59-0", + "receivedDate": 1700003600, + "value": "0.00050000", + "fee": "0.00000000", + "status": "Settled", + "destination": "bc1qar0srrr7xfkvy5l643lydnw9re59gtzzwf5mdq" + } + ], + "additionalData": {} + } + ] + }, + { + "metadata": {}, + "checkout": { + "speedPolicy": "MediumSpeed", + "paymentMethods": [ + "XMR-CHAIN" + ], + "defaultPaymentMethod": null, + "expirationMinutes": 60, + "monitoringMinutes": 4320, + "paymentTolerance": 0.5, + "redirectURL": null, + "redirectAutomatically": false, + "requiresRefundEmail": false, + "defaultLanguage": null + }, + "receipt": { + "enabled": null, + "showQR": null, + "showPayments": null + }, + "id": "ProcessingInvoiceRefB", + "storeId": "BqZKtkeSN9JgLLdCJRJfXQjLwCLDNCVLdxLTTdMzTHnT", + "amount": "54.00", + "currency": "USD", + "type": "Standard", + "checkoutLink": "https://btcpay.example.org/i/ProcessingInvoiceRefB", + "createdTime": 1700000000, + "expirationTime": 1700003600, + "monitoringExpiration": 1700259200, + "status": "Processing", + "additionalStatus": "None", + "availableStatusesForManualMarking": [ + "Settled", + "Invalid" + ], + "archived": false, + "paymentMethods": [ + { + "paymentMethodId": "XMR-CHAIN", + "currency": "XMR", + "destination": "44AFFq5kSiGBoZ4NMDwYtN18obc8AemS33DBLWs3H7otXft3XjrpDtQGv7SqSsaBYBb98uNbr2VBBEt7f2wfn3RVGQBEP3A", + "paymentLink": "monero:44AFFq5kSiGBoZ4NMDwYtN18obc8AemS33DBLWs3H7otXft3XjrpDtQGv7SqSsaBYBb98uNbr2VBBEt7f2wfn3RVGQBEP3A?tx_amount=0.32095000", + "rate": "168.25", + "paymentMethodPaid": "0.32095000", + "totalPaid": "9.99999999", + "due": "0.00000000", + "amount": "0.32095000", + "networkFee": "0.00000500", + "activated": true, + "payments": [ + { + "id": "6f2c1b0a9e8d7c6b5a4938271605f4e3d2c1b0a9e8d7c6b5a4938271605f4e3d", + "receivedDate": 1700003000, + "value": "0.32095000", + "fee": "0.00000000", + "status": "Processing", + "destination": "44AFFq5kSiGBoZ4NMDwYtN18obc8AemS33DBLWs3H7otXft3XjrpDtQGv7SqSsaBYBb98uNbr2VBBEt7f2wfn3RVGQBEP3A" + } + ], + "additionalData": {} + } + ] + }, + { + "metadata": {}, + "checkout": { + "speedPolicy": "MediumSpeed", + "paymentMethods": [ + "BTC-CHAIN" + ], + "defaultPaymentMethod": null, + "expirationMinutes": 60, + "monitoringMinutes": 4320, + "paymentTolerance": 0.5, + "redirectURL": null, + "redirectAutomatically": false, + "requiresRefundEmail": false, + "defaultLanguage": null + }, + "receipt": { + "enabled": null, + "showQR": null, + "showPayments": null + }, + "id": "UntouchedInvoiceRefCC", + "storeId": "BqZKtkeSN9JgLLdCJRJfXQjLwCLDNCVLdxLTTdMzTHnT", + "amount": "54.00", + "currency": "USD", + "type": "Standard", + "checkoutLink": "https://btcpay.example.org/i/UntouchedInvoiceRefCC", + "createdTime": 1700000000, + "expirationTime": 1700003600, + "monitoringExpiration": 1700259200, + "status": "New", + "additionalStatus": "None", + "availableStatusesForManualMarking": [ + "Settled", + "Invalid" + ], + "archived": false, + "paymentMethods": [ + { + "paymentMethodId": "BTC-CHAIN", + "currency": "BTC", + "destination": "bc1qar0srrr7xfkvy5l643lydnw9re59gtzzwf5mdq", + "paymentLink": "bitcoin:bc1qar0srrr7xfkvy5l643lydnw9re59gtzzwf5mdq?amount=0.00050000", + "rate": "108000.12", + "paymentMethodPaid": "0.00000000", + "totalPaid": "0.00000000", + "due": "0.00050000", + "amount": "0.00050000", + "networkFee": "0.00000500", + "activated": true, + "payments": [], + "additionalData": {} + } + ] + } + ] +} diff --git a/apps/simplex-badge-service/test-fixtures/btcpay/invoice-new.json b/apps/simplex-badge-service/test-fixtures/btcpay/invoice-new.json new file mode 100644 index 0000000000..94df911cf4 --- /dev/null +++ b/apps/simplex-badge-service/test-fixtures/btcpay/invoice-new.json @@ -0,0 +1,36 @@ +{ + "_fixture": "POST /api/v1/stores/{storeId}/invoices and GET .../invoices/{invoiceId} -- InvoiceData with status New, from BTCPay's DOCUMENTED Greenfield schema (BTCPay 2.x naming). NOT captured from a live instance; replace `response` with a recorded body and rewrite this line. The fake patches `id`, `status` and `additionalStatus`; everything else is served as written here.", + "response": { + "metadata": {}, + "checkout": { + "speedPolicy": "MediumSpeed", + "paymentMethods": ["BTC-CHAIN"], + "defaultPaymentMethod": null, + "expirationMinutes": 60, + "monitoringMinutes": 4320, + "paymentTolerance": 0.5, + "redirectURL": null, + "redirectAutomatically": false, + "requiresRefundEmail": false, + "defaultLanguage": null + }, + "receipt": { + "enabled": null, + "showQR": null, + "showPayments": null + }, + "id": "GmpP7VDp3jj7HZeJVQpSNP", + "storeId": "BqZKtkeSN9JgLLdCJRJfXQjLwCLDNCVLdxLTTdMzTHnT", + "amount": "54.00", + "currency": "USD", + "type": "Standard", + "checkoutLink": "https://btcpay.example.org/i/GmpP7VDp3jj7HZeJVQpSNP", + "createdTime": 1700000000, + "expirationTime": 1700003600, + "monitoringExpiration": 1700259200, + "status": "New", + "additionalStatus": "None", + "availableStatusesForManualMarking": ["Settled", "Invalid"], + "archived": false + } +} diff --git a/apps/simplex-badge-service/test-fixtures/btcpay/invoice-processing.json b/apps/simplex-badge-service/test-fixtures/btcpay/invoice-processing.json new file mode 100644 index 0000000000..1dd94d651c --- /dev/null +++ b/apps/simplex-badge-service/test-fixtures/btcpay/invoice-processing.json @@ -0,0 +1,36 @@ +{ + "_fixture": "POST /api/v1/stores/{storeId}/invoices and GET .../invoices/{invoiceId} -- InvoiceData with status Processing -- InvoiceProcessing has fired: the payment is seen and is waiting for the confirmations `checkout.speedPolicy` requires -- from BTCPay's DOCUMENTED Greenfield schema (BTCPay 2.x naming). NOT captured from a live instance; replace `response` with a recorded body and rewrite this line. The fake patches `id`, `status` and `additionalStatus`; everything else is served as written here.", + "response": { + "metadata": {}, + "checkout": { + "speedPolicy": "MediumSpeed", + "paymentMethods": ["BTC-CHAIN"], + "defaultPaymentMethod": null, + "expirationMinutes": 60, + "monitoringMinutes": 4320, + "paymentTolerance": 0.5, + "redirectURL": null, + "redirectAutomatically": false, + "requiresRefundEmail": false, + "defaultLanguage": null + }, + "receipt": { + "enabled": null, + "showQR": null, + "showPayments": null + }, + "id": "GmpP7VDp3jj7HZeJVQpSNP", + "storeId": "BqZKtkeSN9JgLLdCJRJfXQjLwCLDNCVLdxLTTdMzTHnT", + "amount": "54.00", + "currency": "USD", + "type": "Standard", + "checkoutLink": "https://btcpay.example.org/i/GmpP7VDp3jj7HZeJVQpSNP", + "createdTime": 1700000000, + "expirationTime": 1700003600, + "monitoringExpiration": 1700259200, + "status": "Processing", + "additionalStatus": "None", + "availableStatusesForManualMarking": ["Settled", "Invalid"], + "archived": false + } +} diff --git a/apps/simplex-badge-service/test-fixtures/btcpay/invoice-settled.json b/apps/simplex-badge-service/test-fixtures/btcpay/invoice-settled.json new file mode 100644 index 0000000000..fd80a7296b --- /dev/null +++ b/apps/simplex-badge-service/test-fixtures/btcpay/invoice-settled.json @@ -0,0 +1,36 @@ +{ + "_fixture": "POST /api/v1/stores/{storeId}/invoices and GET .../invoices/{invoiceId} -- InvoiceData with status Settled -- the invoice is paid in full -- from BTCPay's DOCUMENTED Greenfield schema (BTCPay 2.x naming). NOT captured from a live instance; replace `response` with a recorded body and rewrite this line. The fake patches `id`, `status` and `additionalStatus`; everything else is served as written here.", + "response": { + "metadata": {}, + "checkout": { + "speedPolicy": "MediumSpeed", + "paymentMethods": ["BTC-CHAIN"], + "defaultPaymentMethod": null, + "expirationMinutes": 60, + "monitoringMinutes": 4320, + "paymentTolerance": 0.5, + "redirectURL": null, + "redirectAutomatically": false, + "requiresRefundEmail": false, + "defaultLanguage": null + }, + "receipt": { + "enabled": null, + "showQR": null, + "showPayments": null + }, + "id": "GmpP7VDp3jj7HZeJVQpSNP", + "storeId": "BqZKtkeSN9JgLLdCJRJfXQjLwCLDNCVLdxLTTdMzTHnT", + "amount": "54.00", + "currency": "USD", + "type": "Standard", + "checkoutLink": "https://btcpay.example.org/i/GmpP7VDp3jj7HZeJVQpSNP", + "createdTime": 1700000000, + "expirationTime": 1700003600, + "monitoringExpiration": 1700259200, + "status": "Settled", + "additionalStatus": "None", + "availableStatusesForManualMarking": ["Settled", "Invalid"], + "archived": false + } +} diff --git a/apps/simplex-badge-service/test-fixtures/btcpay/payment-methods-btc.json b/apps/simplex-badge-service/test-fixtures/btcpay/payment-methods-btc.json new file mode 100644 index 0000000000..83c03dcfd4 --- /dev/null +++ b/apps/simplex-badge-service/test-fixtures/btcpay/payment-methods-btc.json @@ -0,0 +1,29 @@ +{ + "_fixture": "GET /api/v1/stores/{storeId}/invoices/{invoiceId}/payment-methods -- InvoicePaymentMethodDataModel[], from BTCPay's DOCUMENTED Greenfield schema (BTCPay 2.x naming). NOT captured from a live instance; replace `response` with a recorded body and rewrite this line. `totalPaid` is deliberately NOT equal to `paymentMethodPaid` -- at this rate reading the wrong one would report $1,080,001.20 instead of $54.00. The fake patches `paymentMethodPaid`, and serves `payments` as [] when nothing was paid.", + "response": [ + { + "paymentMethodId": "BTC-CHAIN", + "currency": "BTC", + "destination": "bc1qar0srrr7xfkvy5l643lydnw9re59gtzzwf5mdq", + "paymentLink": "bitcoin:bc1qar0srrr7xfkvy5l643lydnw9re59gtzzwf5mdq?amount=0.00050000", + "rate": "108000.12", + "paymentMethodPaid": "0.00050000", + "totalPaid": "9.99999999", + "due": "0.00000000", + "amount": "0.00050000", + "networkFee": "0.00000500", + "activated": true, + "payments": [ + { + "id": "8e3a1f0c9d2b4a5768f90e1c2d3b4a5968f70e1c2d3b4a5968f70e1c2d3b4a59-0", + "receivedDate": 1700003600, + "value": "0.00050000", + "fee": "0.00000000", + "status": "Settled", + "destination": "bc1qar0srrr7xfkvy5l643lydnw9re59gtzzwf5mdq" + } + ], + "additionalData": {} + } + ] +} diff --git a/apps/simplex-badge-service/test-fixtures/btcpay/payment-methods-no-amount.json b/apps/simplex-badge-service/test-fixtures/btcpay/payment-methods-no-amount.json new file mode 100644 index 0000000000..d1c4129ce2 --- /dev/null +++ b/apps/simplex-badge-service/test-fixtures/btcpay/payment-methods-no-amount.json @@ -0,0 +1,19 @@ +{ + "_fixture": "GET /api/v1/stores/{storeId}/invoices/{invoiceId}/payment-methods -- a BTC-CHAIN method with no `amount` -- the crypto figure the payment screen renders, absent. Hand-written from the documented schema; a real BTCPay will not produce it on demand. A create that cannot learn where to pay must be a ProviderError naming the missing field, and write nothing -- the invoice exists at the provider and is abandoned there.", + "response": [ + { + "paymentMethodId": "BTC-CHAIN", + "currency": "BTC", + "destination": "bc1qar0srrr7xfkvy5l643lydnw9re59gtzzwf5mdq", + "paymentLink": "bitcoin:bc1qar0srrr7xfkvy5l643lydnw9re59gtzzwf5mdq?amount=0.00050000", + "rate": "108000.12", + "paymentMethodPaid": "0.00000000", + "totalPaid": "0.00000000", + "due": "0.00050000", + "networkFee": "0.00000500", + "activated": true, + "payments": [], + "additionalData": {} + } + ] +} diff --git a/apps/simplex-badge-service/test-fixtures/btcpay/payment-methods-no-destination.json b/apps/simplex-badge-service/test-fixtures/btcpay/payment-methods-no-destination.json new file mode 100644 index 0000000000..4dc67e6170 --- /dev/null +++ b/apps/simplex-badge-service/test-fixtures/btcpay/payment-methods-no-destination.json @@ -0,0 +1,18 @@ +{ + "_fixture": "GET /api/v1/stores/{storeId}/invoices/{invoiceId}/payment-methods -- a BTC-CHAIN method with no `destination` yet -- the shape a payment method has before it is activated and given an address. Hand-written from the documented schema; a real BTCPay will not produce it on demand. A create that cannot learn where to pay must be a ProviderError naming the missing field, and write nothing -- the invoice exists at the provider and is abandoned there.", + "response": [ + { + "paymentMethodId": "BTC-CHAIN", + "currency": "BTC", + "rate": "108000.12", + "paymentMethodPaid": "0.00000000", + "totalPaid": "0.00000000", + "due": "0.00050000", + "amount": "0.00050000", + "networkFee": "0.00000500", + "activated": false, + "payments": [], + "additionalData": {} + } + ] +} diff --git a/apps/simplex-badge-service/test-fixtures/btcpay/payment-methods-xmr.json b/apps/simplex-badge-service/test-fixtures/btcpay/payment-methods-xmr.json new file mode 100644 index 0000000000..c68256f3d7 --- /dev/null +++ b/apps/simplex-badge-service/test-fixtures/btcpay/payment-methods-xmr.json @@ -0,0 +1,29 @@ +{ + "_fixture": "GET /api/v1/stores/{storeId}/invoices/{invoiceId}/payment-methods -- InvoicePaymentMethodDataModel[] for the Monero PLUGIN, from the same documented shape. NOT captured from a live instance -- the plugin is the likeliest of these files to diverge, XMR coming from btcpayserver-monero-plugin rather than BTCPay itself, and the likeliest to need replacing with a recorded body. `totalPaid` is deliberately NOT equal to `paymentMethodPaid`.", + "response": [ + { + "paymentMethodId": "XMR-CHAIN", + "currency": "XMR", + "destination": "44AFFq5kSiGBoZ4NMDwYtN18obc8AemS33DBLWs3H7otXft3XjrpDtQGv7SqSsaBYBb98uNbr2VBBEt7f2wfn3RVGQBEP3A", + "paymentLink": "monero:44AFFq5kSiGBoZ4NMDwYtN18obc8AemS33DBLWs3H7otXft3XjrpDtQGv7SqSsaBYBb98uNbr2VBBEt7f2wfn3RVGQBEP3A?tx_amount=0.32095000", + "rate": "168.25", + "paymentMethodPaid": "0.32095000", + "totalPaid": "9.99999999", + "due": "0.00000000", + "amount": "0.32095000", + "networkFee": "0.00000500", + "activated": true, + "payments": [ + { + "id": "6f2c1b0a9e8d7c6b5a4938271605f4e3d2c1b0a9e8d7c6b5a4938271605f4e3d", + "receivedDate": 1700003600, + "value": "0.32095000", + "fee": "0.00000000", + "status": "Settled", + "destination": "44AFFq5kSiGBoZ4NMDwYtN18obc8AemS33DBLWs3H7otXft3XjrpDtQGv7SqSsaBYBb98uNbr2VBBEt7f2wfn3RVGQBEP3A" + } + ], + "additionalData": {} + } + ] +} diff --git a/apps/simplex-badge-service/test-fixtures/btcpay/store-payment-methods.json b/apps/simplex-badge-service/test-fixtures/btcpay/store-payment-methods.json new file mode 100644 index 0000000000..836303b943 --- /dev/null +++ b/apps/simplex-badge-service/test-fixtures/btcpay/store-payment-methods.json @@ -0,0 +1,21 @@ +{ + "_fixture": "GET /api/v1/stores/{storeId}/payment-methods -- StorePaymentMethodDataList, from BTCPay's DOCUMENTED Greenfield schema (BTCPay 2.x naming, where a payment method id is CODE-CHAIN). NOT captured from a live instance; replace `response` with a recorded body and rewrite this line.", + "response": [ + { + "paymentMethodId": "BTC-CHAIN", + "enabled": true, + "config": { + "accountDerivation": "xpub661MyMwAqRbcExampleAccountDerivation-[p2wpkh]", + "label": "", + "accountKeyPath": "" + } + }, + { + "paymentMethodId": "XMR-CHAIN", + "enabled": true, + "config": { + "accountIndex": 0 + } + } + ] +} diff --git a/apps/simplex-badge-service/test-fixtures/stripe/intent-canceled.json b/apps/simplex-badge-service/test-fixtures/stripe/intent-canceled.json new file mode 100644 index 0000000000..eafb1c0c61 --- /dev/null +++ b/apps/simplex-badge-service/test-fixtures/stripe/intent-canceled.json @@ -0,0 +1,12 @@ +{ + "_fixture": "GET /v1/payment_intents/{id} for a canceled intent (status canceled), from Stripe's documented API schema. NOT captured from a live instance; replace `response` with a recorded body and rewrite this line. A canceled intent captured nothing, so amount_received is zero.", + "response": { + "id": "pi_test_canceled", + "object": "payment_intent", + "amount": 5400, + "amount_received": 0, + "currency": "usd", + "status": "canceled", + "latest_charge": null + } +} diff --git a/apps/simplex-badge-service/test-fixtures/stripe/intent-list-cursor-gap.json b/apps/simplex-badge-service/test-fixtures/stripe/intent-list-cursor-gap.json new file mode 100644 index 0000000000..f9e6f9bd21 --- /dev/null +++ b/apps/simplex-badge-service/test-fixtures/stripe/intent-list-cursor-gap.json @@ -0,0 +1,12 @@ +{ + "_fixture": "GET /v1/payment_intents?created[gte]=&limit=, a page whose LAST row carries no id, from Stripe's documented API schema. NOT captured from a live instance. Served with a small page size so the id-less row ends a page while more remain, leaving no starting_after to continue from. pi_test_a settles, pi_test_c sits on the unreachable next page.", + "response": { + "object": "list", + "has_more": false, + "data": [ + {"id": "pi_test_a", "object": "payment_intent", "status": "succeeded", "amount": 5400, "amount_received": 5400, "currency": "usd"}, + {"object": "payment_intent", "status": "requires_payment_method", "amount": 5400, "amount_received": 0, "currency": "usd"}, + {"id": "pi_test_c", "object": "payment_intent", "status": "canceled", "amount": 5400, "amount_received": 0, "currency": "usd"} + ] + } +} diff --git a/apps/simplex-badge-service/test-fixtures/stripe/intent-list.json b/apps/simplex-badge-service/test-fixtures/stripe/intent-list.json new file mode 100644 index 0000000000..4a0e477218 --- /dev/null +++ b/apps/simplex-badge-service/test-fixtures/stripe/intent-list.json @@ -0,0 +1,13 @@ +{ + "_fixture": "GET /v1/payment_intents?created[gte]=&limit=, a page of PaymentIntents created within the settle window, from Stripe's documented API schema. NOT captured from a live instance; replace `response` with a recorded body and rewrite this line. List rows carry NO expanded latest_charge, so a succeeded row dates its settlement at read time. Rows exercise the mapping: pi_test_open still open (no signal), pi_test_a succeeded, pi_test_b canceled, and one row with no id for the skip path. The fake serves data verbatim and paginates when _paging is set.", + "response": { + "object": "list", + "has_more": false, + "data": [ + {"id": "pi_test_open", "object": "payment_intent", "status": "requires_payment_method", "amount": 5400, "amount_received": 0, "currency": "usd"}, + {"id": "pi_test_a", "object": "payment_intent", "status": "succeeded", "amount": 5400, "amount_received": 5400, "currency": "usd"}, + {"id": "pi_test_b", "object": "payment_intent", "status": "canceled", "amount": 5400, "amount_received": 0, "currency": "usd"}, + {"object": "payment_intent", "status": "requires_payment_method", "amount": 5400, "amount_received": 0, "currency": "usd"} + ] + } +} diff --git a/apps/simplex-badge-service/test-fixtures/stripe/intent-open.json b/apps/simplex-badge-service/test-fixtures/stripe/intent-open.json new file mode 100644 index 0000000000..ac0cd42547 --- /dev/null +++ b/apps/simplex-badge-service/test-fixtures/stripe/intent-open.json @@ -0,0 +1,13 @@ +{ + "_fixture": "POST /v1/payment_intents and GET /v1/payment_intents/{id} for an unpaid intent (status requires_payment_method), from Stripe's documented API schema. NOT captured from a live instance; replace `response` with a recorded body and rewrite this line. The fake patches id, client_secret, status, amount_received and currency; everything else is served as written.", + "response": { + "id": "pi_test_open", + "object": "payment_intent", + "amount": 5400, + "amount_received": 0, + "currency": "usd", + "client_secret": "pi_test_open_secret", + "status": "requires_payment_method", + "latest_charge": null + } +} diff --git a/apps/simplex-badge-service/test-fixtures/stripe/intent-succeeded.json b/apps/simplex-badge-service/test-fixtures/stripe/intent-succeeded.json new file mode 100644 index 0000000000..cde8176601 --- /dev/null +++ b/apps/simplex-badge-service/test-fixtures/stripe/intent-succeeded.json @@ -0,0 +1,18 @@ +{ + "_fixture": "GET /v1/payment_intents/{id}?expand[]=latest_charge for a paid intent (status succeeded), from Stripe's documented API schema. NOT captured from a live instance; replace `response` with a recorded body and rewrite this line. The fake patches id, status, amount_received and currency; latest_charge.created dates the settlement.", + "response": { + "id": "pi_test_settled", + "object": "payment_intent", + "amount": 5400, + "amount_received": 5400, + "currency": "usd", + "status": "succeeded", + "latest_charge": { + "id": "ch_test_x", + "object": "charge", + "created": 1700000000, + "paid": true, + "amount_captured": 5400 + } + } +} diff --git a/apps/simplex-badge-service/web/.gitignore b/apps/simplex-badge-service/web/.gitignore new file mode 100644 index 0000000000..939e8224c9 --- /dev/null +++ b/apps/simplex-badge-service/web/.gitignore @@ -0,0 +1,3 @@ +node_modules/ +build/ +dist/ diff --git a/apps/simplex-badge-service/web/README.md b/apps/simplex-badge-service/web/README.md new file mode 100644 index 0000000000..ee910e198a --- /dev/null +++ b/apps/simplex-badge-service/web/README.md @@ -0,0 +1,301 @@ +# SimpleX badge codes — web + +The buyer-facing page for badge codes: choose a tier and duration, pay by +card, BTC or XMR, and receive a code. Design and rationale are in +[`plans/badges-codes/2026-08-27-badge-codes.md`](../../../plans/badges-codes/2026-08-27-badge-codes.md); +the implementation plan for this app is +[`plans/badges-codes/2026-08-28-web-implementation.md`](../../../plans/badges-codes/2026-08-28-web-implementation.md). +This file covers how to build, test and run it. + +No runtime or dev dependencies beyond `typescript` and `@types/node`. +Stripe.js is loaded at runtime from `js.stripe.com`, never bundled or +installed. + +## Build and test + +``` +npm install +npm run build +npm test +``` + +`npm run build` clears `build/` and runs `tsc` into it (gitignored), then +`build.js`, which content-hashes the compiled modules, `styles.css` and the images, +copies them to `dist/assets//`, and writes that hash into +`public/index.html` and `public/sw.js`. `dist/` (gitignored) is the deploy +tree: `index.html`, `sw.js` and `assets//`, nothing else. + +`npm test` compiles and runs the suite (`node --test` over +compiled output) but does **not** run `build.js`. One of those tests is a +tripwire: it recomputes the hash from the freshly compiled modules and fails +if the hash named in `public/index.html` or `public/sw.js` does not match. + +**If you edit anything under `src/`, run `npm run build` and commit the +regenerated `public/index.html` and `public/sw.js`.** Skipping this is the +most likely way to break the suite — `npm test` will tell you, but the fix is +`npm run build`, not the test. + +Both scripts clear `build/` first. `tsc` leaves the output of a module you rename or delete +behind, `build.js` hashes every `.js` it finds there, and the result is a phantom module in the +build that the tripwire would tell you to commit. + +## Layout + +Only `src/main.ts` and `src/stripe.ts` touch `window`, `location`, `history` +or `localStorage`. `src/screens.ts` builds the DOM, and `src/qr.ts` and +`src/icons.ts` reach for `document` only through `createElementNS`, to build +inline SVG. Nothing else outside those five modules touches the DOM. Every other module +is plain TypeScript, tested directly in Node. + +| Module | Owns | +|---|---| +| `domain.ts` | The words the app is written in: steps, themes, order statuses, methods, chains | +| `catalog.ts` | Prices and offers compiled into the page at build time | +| `codes.ts` | The badge code alphabet and check character | +| `parse.ts` | Readers for data the page did not produce, each answering the value or undefined | +| `format.ts` | Money, countdowns and elapsed time as the words a screen prints | +| `store.ts` | The three `localStorage` keys — session, orders and the chosen theme | +| `order.ts` | What an order's state means: what to keep from a response, which screen it selects, and its history row | +| `routing.ts` | Reading `?order=` and the store into what to render | +| `api.ts` | The three routes — create, cancel and read — and the long-poll wait loop, with `fetch`, sleep and the clock injected | +| `flow.ts` | Payment flow control logic — pure, no DOM, no globals | +| `stripe.ts` | Loading Stripe.js, mounting the Payment Element, confirming, and the no-key stand-in | +| `icons.ts` | The badge art, the payment marks and the hamburger, built with `createElementNS`. The brand mark is NOT here: it is a served file | +| `qr.ts` | A QR encoder written for this page, with no dependency, no network and no raster | +| `screens.ts` | Every screen of the spec, and the header and its menu, built node by node — markup is never assigned from a string | +| `main.ts` | Wiring: DOM events in, `flow.ts` calls out, `screens.ts` renders | + +## Running the real service against this build + +**`mock/server.py` is not the service.** The service is the Haskell +executable `simplex-badge-service`, in `apps/simplex-badge-service/`, and +`dist/` is the directory its listener serves. Nothing about the page changes +between the two — the service matches this build, never the reverse. + +``` +# 1. build the page. dist/ is the deploy tree: index.html, sw.js, assets// +cd apps/simplex-badge-service/web +npm install && npm run build +cd ../../.. + +# 2. configuration, from the committed example. Copy it IN +# PLACE, beside the example: that path is the one .gitignore covers, and this +# file is about to hold a real api_key and webhook_secret. +cd apps/simplex-badge-service +cp badge_service.ini.example badge_service.ini +cd ../.. +# static_dir = ./apps/simplex-badge-service/web/dist <- the build above +# [btcpay] = a real store's host, api_key, store_id and webhook_secret, +# or delete the whole section to disable BTC and XMR (the provider-unavailable screen) +# [issuer] = uncomment the section and put a real issuer secret in key_1, with +# default = key_1. It has to be a key whose public half already ships in +# the apps: startup checks the secret against `badgePublicKeys` at that +# index, so a fresh `simplex-chat badge keygen` pair is refused. + +# 3. run it. Without --service-config the web listener does not start at all. +# An issuer key is required even though nothing in the checkout path uses it: +# the same process also answers redemption requests, and it refuses to start +# without a key it could sign a credential with. Put it in the ini's [issuer] +# section, or pass --issuer-key-idx and --issuer-secret, which override it. +# `simplex-chat badge keygen` prints a pair. +cabal run simplex-badge-service -- \ + --service-config apps/simplex-badge-service/badge_service.ini +``` + +Then open the `[listener]` host and port — `http://127.0.0.1:8080/` as the +example ships. `static_dir` is relative to the working directory, so run from +the repository root or make it absolute. + +**The executable is the whole badge service, not just this listener.** +`badgeService` starts `simplexChatCore` unconditionally and the web listener +is one lane beside the chat one, so a local run opens or creates a chat +database (`printDbOpts` names the path at startup) and does agent network +work. `--no-address` skips creating the service's contact address on first +start, which a run of the web listener alone does not need. + +*These three steps are read out of `Options.hs`, `Service.hs`, `Config.hs` and +`badge_service.ini.example` rather than from a run — driving them end to end +needs a chat database and a real BTCPay store.* + +What the mock cannot stand in for: + +| | `mock/server.py` | `simplex-badge-service` | +|---|---|---| +| Invoices | invented in memory | created at BTCPay over Greenfield | +| Payment detected by | `POST /control/settle/:id`, an endpoint that exists nowhere else | a poller reading the provider, which is the only thing that carries authority | +| Webhooks | none | `POST /webhooks/btcpay`, signature-verified, a latency hint and nothing more | +| Persistence | none | the chat database, under `sx_badge_service_*` | +| Codes | invented | written unpaid at checkout, marked paid by settlement | + +The Haskell side's own end-to-end coverage of that lane — checkout, payment, +polling, partial payment, expiry, late settlement and replay, all against a +fake Greenfield — is `tests/Bots/BadgeWebTests.hs`: + +``` +cabal test --test-options='-m "Supporter badges"' +``` + +## Running the mock + +`mock/server.py` stands in for the Haskell service, Stripe and BTCPay, so the +whole browser flow can be driven with no real backend. **It is a browser-only +test fixture and not the service**: no signatures, no persistence, no real +money, no provider, and not a specification of what ships. Standard library +only. + +``` +python3 mock/server.py --port 8099 +``` + +It serves `public/` and `dist/`, and adds: + +| Endpoint | Behaviour | +|---|---| +| `POST /api/invoice` | Creates an invoice. Rejects a repeated `codeHash` with `409 code_conflict`. | +| `GET /api/invoice/:id?wait=&seenPaid=
&seenFull=<0\|1>` | Long-polls: holds while the invoice's status is still `` **and** its payment is the one the page says it has rendered, up to `MOCK_HOLD_SECONDS` (default 30). A payment the page has not seen answers at once — the provider's verdict counts as much as the figure, since Monero reports an invoice as confirming while its figures are still zero. A request that omits `seenPaid` holds on the status alone. | +| `POST /api/invoice/:id/cancel` | Expires an open invoice. Refuses a settled one with `409 not_open` and a funded one with `409 funded`, as the service does. | +| `POST /control/settle/:id` | Marks the invoice paid — stands in for a provider webhook. | +| `POST /control/expire/:id` | Marks it expired. | +| `POST /control/partial/:id` | Records a partial payment, half the amount due, and the remainder the provider would still ask for. | +| `POST /control/confirming/:id` | Records the full amount as arrived with the invoice still open — the screen that waits for confirmations. | +| `POST /control/verdict/:id` | Records the provider's verdict alone, with no figure — how Monero reports a payment it is still confirming. | + +### Driving a purchase by hand + +``` +python3 mock/server.py --port 8099 & + +curl -s -X POST http://localhost:8099/api/invoice -H 'content-type: application/json' \ + -d '{"codeHash":"<43 base64url chars>","priceId":"price_supporter","offerId":"offer_3m","method":"btc"}' +# => {"invoiceId": "...", "status": "open", ...} + +curl -s -X POST http://localhost:8099/control/settle/ +# => {"ok": true, "status": "paid"} + +curl -s "http://localhost:8099/api/invoice/?wait=open" +# returns immediately once settled, with status "paid" +``` + +A GET with `wait=open` held while `open` is still current unblocks the +instant `/control/settle` (or `/control/expire`, `/control/partial`) fires, +which is what the page's own wait loop relies on — no polling on a timer. + +Card invoices (`"method":"card"`) get a `clientSecret` in the response +instead of an address; BTC and XMR get `address` and `cryptoAmount`. + +### The Stripe key + +The publishable key lives in a `` element +in `public/index.html`, committed empty. `mock/server.py` substitutes +`$STRIPE_PUBLISHABLE_KEY` into the served page and refuses to start if it is +set to anything but a `pk_`-prefixed key (a secret or restricted key would +otherwise be baked into a page anyone can read). + +With no key set, the card path renders a labelled development stand-in +instead of a Stripe Payment Element: its button does what a successful +confirm does, and settling it calls the mock's `/control/settle` directly. +**This stand-in cannot appear when a key is set** — the code path that +builds it is unreachable once Stripe.js has actually loaded. To see the real +Payment Element, set a test key: + +``` +STRIPE_PUBLISHABLE_KEY=pk_test_... python3 mock/server.py --port 8099 +``` + +## What is not verified here + +The test suite runs in Node, so it asserts structure rather than rendering: +CSS is checked by parsing `styles.css`, `inert` by the attribute, the QR by +decoding the path the encoder produced, and the service worker by driving +`public/sw.js` in a Node `vm`. + +The screens themselves **have** been rendered and reviewed, in both themes at +desktop and phone widths, using headless Chromium driven by Playwright +installed outside this package — the whole purchase was walked through, +settled against the mock, and photographed. Nothing in `package.json` +changed; do the same rather than trusting the suite for anything visual. + +What still cannot be checked anywhere here: + +- A real QR scan with a phone camera. +- Stripe.js loading, mounting a Payment Element and confirming a payment, + which need a browser **and** a Stripe account. The SDK method names come + from the spec and every test drives a fake, so a wrong name stays green here + and fails in production. +- A real service worker installing and serving the precache with the network + genuinely off. +- System fonts: headless Chromium substitutes DejaVu, so type metrics differ + from a real machine. + +Before shipping a change that touches any of these, check it by hand in a +real browser: the wizard's two panels travel together for the length of a +step and neither one blinks out, panels ahead of the buyer are unreachable by +Tab, the menu closes on Escape and hands focus back to its button, both +themes are drawn from the menu's own control as well as from the operating +system, offline reload actually serves the cached build, and (with a test +key) the Payment Element mounts and confirms. + +## What is not implemented + +The web manifest is absent. The design calls it optional: offline support +needs the service worker, not the manifest. + +The asset table is otherwise built. The brand mark is the difference worth +knowing about: `public/img/wordmark-*.svg` and `public/img/symbol-*.svg` are +the official files copied out of `website/` and `media-logos/`, served under +the build hash and drawn by the stylesheet — NOT path data transcribed into a +module. `design.test.ts` compares each one against its source byte for byte, +so a hand-edited mark fails the suite. The one edit is the dark wordmark, +which is the light file with its `#030749` lettering set to white, exactly as +simplex.chat's own dark header shows it. + +## Content Security Policy + +This repository has no CSP — it belongs on the listener that serves the app +in production, not in this app. Without one, in +particular without `script-src https://js.stripe.com`, card payments break +silently and nothing in this test suite would catch it. The policy the spec +specifies: + +``` +default-src 'self'; +script-src 'self' https://js.stripe.com https://*.js.stripe.com; +frame-src https://js.stripe.com https://*.js.stripe.com https://hooks.stripe.com; +connect-src 'self' https://api.stripe.com; +img-src 'self' https://*.stripe.com; +frame-ancestors 'self' https://simplex.chat https://*.simplex.chat +``` + +`frame-ancestors` is what lets the site embed this app in an iframe while every other origin is +refused (clickjacking). Drop the `simplex.chat` entries to forbid embedding entirely. + +## Embedding in the site + +The app runs standalone or inside an iframe on simplex.chat. It detects the frame +(`window.self !== window.top`), points the wordmark at the site's own home on the top window, and +speaks a small theme protocol so one switch drives both (`src/embed.ts`): + +- On load the frame posts `{ type: "simplex-embed-ready", theme }` to its parent. +- The host posts `{ type: "simplex-theme", theme }` (theme is `light` | `dark` | `system`) to drive + the frame; the frame applies it only from a trusted origin (`https://simplex.chat` or a subdomain). +- When the buyer uses the in-frame theme control, the frame echoes the same message back so the + host's own control stays in step. + +The host page hides its own navbar and frames the app full-bleed: + +```html + + +``` diff --git a/apps/simplex-badge-service/web/build.js b/apps/simplex-badge-service/web/build.js new file mode 100644 index 0000000000..35af3fd98e --- /dev/null +++ b/apps/simplex-badge-service/web/build.js @@ -0,0 +1,156 @@ +#!/usr/bin/env node +// The build hash is written back into public/index.html and public/sw.js, so a served shell can never name a build other than the one on disk. + +import { createHash } from "node:crypto"; +import { copyFileSync, mkdirSync, readFileSync, readdirSync, rmSync, writeFileSync } from "node:fs"; +import { fileURLToPath, pathToFileURL } from "node:url"; + +const root = fileURLToPath(new URL("./", import.meta.url)); +export const paths = { + compiled: `${root}build/src`, + stylesheet: `${root}public/styles.css`, + images: `${root}public/img`, + indexHtml: `${root}public/index.html`, + worker: `${root}public/sw.js`, + site: `${root}dist`, +}; + +/** This is long enough to avoid a collision and short enough to read in a URL. */ +export const HASH_CHARS = 16; +export const ASSET_PATTERN = new RegExp(`/assets/[0-9a-f]{${HASH_CHARS}}/`, "g"); +export const BUILD_PATTERN = /const BUILD = "[0-9a-f]+";/; + +/** The sourceMappingURL comment is removed because the maps are not copied and would 404 on every devtools open. */ +export function served(source) { + return source.replace(/\n?\/\/# sourceMappingURL=.*\n?$/, "\n"); +} + +export function hashOf(files) { + const digest = createHash("sha256"); + for (const [name, content] of [...files].sort((a, b) => a[0].localeCompare(b[0]))) { + digest.update(name); + digest.update("\0"); + digest.update(content); + } + return digest.digest("hex").slice(0, HASH_CHARS); +} + +const IMAGE_TYPES = [".png", ".svg"]; + +/** Images sit flat beside styles.css so that a url(hero-light.png) reference in the stylesheet resolves. */ +/** + * This runs as a classic non-module script so that it executes before the first paint. + * The CSP allows script-src 'self' but not inline, so it must be served as a file rather than inlined. + */ +const INIT_JS = `(function () { + var r = document.documentElement; + try { + var raw = localStorage.getItem("sb.theme.v1"); + var t = raw ? JSON.parse(raw) : "system"; + if (t !== "light" && t !== "dark" && t !== "system") t = "system"; + if (t === "system") r.removeAttribute("data-theme"); else r.setAttribute("data-theme", t); + r.style.colorScheme = (t === "dark" || (t === "system" && matchMedia("(prefers-color-scheme: dark)").matches)) ? "dark" : "light"; + } catch (e) {} + try { + var h = location.hash; + var landing = (h === "" || h === "#" || h === "#/") && location.search.indexOf("order=") < 0; + if (!landing) r.classList.add("sb-booting"); + } catch (e) {} +})(); +`; + +export function assets(compiled = paths.compiled, stylesheet = paths.stylesheet, images = paths.images) { + const modules = readdirSync(compiled).filter((f) => f.endsWith(".js")).sort(); + if (modules.length === 0) throw new Error("build: build/src holds no modules — run tsc first"); + const pictures = readdirSync(images).filter((f) => IMAGE_TYPES.some((t) => f.endsWith(t))).sort(); + return [ + ...modules.map((name) => [name, served(readFileSync(`${compiled}/${name}`, "utf8"))]), + ["styles.css", readFileSync(stylesheet, "utf8")], + ["init.js", INIT_JS], + ...pictures.map((name) => [name, readFileSync(`${images}/${name}`)]), + ]; +} + +/** This throws rather than returning the text unchanged, because a silent no-op would ship a shell that still names the previous build. */ +export function retarget(text, pattern, replacement, what) { + if (!new RegExp(pattern.source).test(text)) throw new Error(`build: no ${what} to rewrite`); + return text.replace(pattern, replacement); +} + +export function withBuild(html, build) { + return retarget(html, ASSET_PATTERN, `/assets/${build}/`, "asset path"); +} + +export async function prerenderShell() { + const dom = await import("./build/test/stub-dom.js"); + const prevDoc = Object.getOwnPropertyDescriptor(globalThis, "document"); + const prevNav = Object.getOwnPropertyDescriptor(globalThis, "navigator"); + dom.installDocument(); + try { + const screens = await import("./build/src/screens.js"); + const noop = () => {}; + const chromeHtml = screens.chrome({ + theme: "system", onNewPurchase: noop, onHistory: noop, onTheme: noop, onToggle: noop, onHome: noop, + }).node.serialize(); + const landingHtml = screens.landing({ onStart: noop }).serialize(); + return { chromeHtml, appHtml: `
${landingHtml}
` }; + } finally { + if (prevDoc) Object.defineProperty(globalThis, "document", prevDoc); else delete globalThis.document; + if (prevNav) Object.defineProperty(globalThis, "navigator", prevNav); else delete globalThis.navigator; + } +} + +export const SHELL_SLOTS = /** @type {const} */ ([ + ["chrome", /()[\s\S]*?()/], + ["app", /()[\s\S]*?()/], +]); + +/** The markers are kept so the next build can find the slots again. */ +export function injectShell(html, shell) { + let out = html; + for (const [slot, pattern] of SHELL_SLOTS) { + const body = slot === "chrome" ? shell.chromeHtml : shell.appHtml; + out = retarget(out, pattern, (_m, open, close) => `${open}${body}${close}`, `${slot} shell slot`); + } + return out; +} + +export function withBuildId(js, build) { + return retarget(js, BUILD_PATTERN, `const BUILD = "${build}";`, "BUILD constant"); +} + +function put(file, content) { + let before = null; + try { before = readFileSync(file, "utf8"); } catch { /* the file may not exist yet */ } + if (before === content) return false; + writeFileSync(file, content); + return true; +} + +export async function assemble() { + const files = assets(); + const build = hashOf(files); + const shell = await prerenderShell(); + + // The whole site directory is removed first so a stale build hash cannot remain beside the current one. + rmSync(paths.site, { recursive: true, force: true }); + mkdirSync(`${paths.site}/assets/${build}`, { recursive: true }); + for (const [name, content] of files) writeFileSync(`${paths.site}/assets/${build}/${name}`, content); + + // The shell is injected before the build hash is rewritten, because the injected markup carries no asset URLs while the hash rewrite still finds the ones in the head. + const indexSource = withBuild(injectShell(readFileSync(paths.indexHtml, "utf8"), shell), build); + const moved = [ + put(paths.indexHtml, indexSource), + put(paths.worker, withBuildId(readFileSync(paths.worker, "utf8"), build)), + ].some(Boolean); + copyFileSync(paths.indexHtml, `${paths.site}/index.html`); + copyFileSync(paths.worker, `${paths.site}/sw.js`); + + return { build, files: files.length, moved }; +} + +if (process.argv[1] !== undefined && pathToFileURL(process.argv[1]).href === import.meta.url) { + const { build, files, moved } = await assemble(); + console.log(`build ${build}: ${files} files in dist/assets/${build}/, with index.html and sw.js`); + if (moved) console.log("build: public/index.html and public/sw.js now name this build — commit them"); +} diff --git a/apps/simplex-badge-service/web/check-tests.js b/apps/simplex-badge-service/web/check-tests.js new file mode 100644 index 0000000000..101e0262f3 --- /dev/null +++ b/apps/simplex-badge-service/web/check-tests.js @@ -0,0 +1,20 @@ +#!/usr/bin/env node +import fs from 'fs'; +import path from 'path'; + +const testDir = 'build/test'; + +if (!fs.existsSync(testDir)) { + console.error(`Error: test directory not found: ${testDir}`); + process.exit(1); +} + +const files = fs.readdirSync(testDir, { recursive: true }); +const testFiles = files.filter(f => typeof f === 'string' && f.endsWith('.test.js')); + +if (testFiles.length === 0) { + console.error('Error: No test files found in build/test/'); + process.exit(1); +} + +console.log(`Found ${testFiles.length} test file(s)`); diff --git a/apps/simplex-badge-service/web/mock/server.py b/apps/simplex-badge-service/web/mock/server.py new file mode 100644 index 0000000000..af7612a084 --- /dev/null +++ b/apps/simplex-badge-service/web/mock/server.py @@ -0,0 +1,323 @@ +"""Stands in for the Haskell service AND for Stripe and BTCPay, so the whole +browser flow can be driven without any of them. A test fixture: no signatures, +no persistence, no money, and not a specification of the real service. + +Standard library only. Threaded, because the wait endpoint holds a connection. + +Environment: + MOCK_HOLD_SECONDS how long GET /api/invoice/:id?wait= holds (default 30) + STRIPE_PUBLISHABLE_KEY substituted into the + served index.html. Public by design, but still not + committed: unset, the page has NO card form and + renders the development stand-in instead, whose + button does what a successful confirm does and whose + settling is POST /control/settle/ below. + Set it to a `pk_test_...` key to drive the real + Stripe path; a secret key here is refused at start. +""" +import json, os, re, secrets, sys, threading +from datetime import datetime, timedelta, timezone +from http.server import BaseHTTPRequestHandler, ThreadingHTTPServer +from pathlib import Path +from urllib.parse import urlparse, parse_qs + +ROOT = Path(__file__).resolve().parent.parent +HOLD_SECONDS = float(os.environ.get("MOCK_HOLD_SECONDS", "30")) +STRIPE_PUBLISHABLE_KEY = os.environ.get("STRIPE_PUBLISHABLE_KEY", "").strip() +KEY_META = re.compile(r'(]*content=")[^"]*(")') + +CATALOG = { + "price_supporter": {"badgeType": "supporter", "monthPrice": 700}, + "price_legend": {"badgeType": "legend", "monthPrice": 7000}, +} +OFFERS = { + "offer_3m": {"months": 3, "free": 1}, + "offer_12m": {"months": 12, "discount": 50}, + "offer_3m_s": {"months": 3, "free": 1}, + "offer_12m_s": {"months": 12, "discount": 50}, +} +MIME = {".html": "text/html", ".css": "text/css", ".js": "text/javascript", + ".svg": "image/svg+xml", ".json": "application/json", ".webmanifest": "application/manifest+json"} +# BTCPay's default speed policy asks for one confirmation. +REQUIRED_CONFIRMATIONS = 1 +ADDRESSES = {"btc": "bc1qexampleaddress0k3jq2wvcgmqz", "xmr": "48HqK2XmVexampleAddress9fRtWc"} + +LOCK = threading.Lock() +INVOICES = {} +HASHES = {} +EVENTS = {} + + +def now_iso(): + return datetime.now(timezone.utc).replace(microsecond=0).isoformat().replace("+00:00", "Z") + + +def total(price_id, offer_id): + price = CATALOG.get(price_id) + if price is None: + return None + if not offer_id: + return {"months": 1, "amount": price["monthPrice"]} + offer = OFFERS.get(offer_id) + if offer is None: + return None + gross = price["monthPrice"] * offer["months"] + if "free" in offer: + amount = price["monthPrice"] * (offer["months"] - offer["free"]) + else: + amount = (gross * (100 - offer["discount"])) // 100 + return {"months": offer["months"], "amount": amount} + + +def payment_mark(inv): + """The figure the page shows and the verdict it shows it under, which together decide + which screen it is on.""" + return (inv.get("cryptoAmountPaid") or "", inv.get("paidInFull") is True) + + +def swap_event(invoice_id): + """Called under LOCK; returns the event to fire once it is released. A fresh Event for + whoever parks next, so a waiter that read the pre-change status but calls wait() after we + fire this one still catches its own (already-set) event instead of racing a clear() on a + shared one and missing the wake.""" + old = EVENTS.get(invoice_id) + EVENTS[invoice_id] = threading.Event() + return old + + +def public_view(inv): + """What the browser may see. Note what is absent: no code, no code hash — the service + never has the code.""" + view = { + "status": inv["status"], "badgeType": inv["badgeType"], "months": inv["months"], + "amount": inv["amount"], "currency": inv["currency"], + "expiresAt": inv["expiresAt"], + } + for k in ("amountPaid", "cryptoAmountPaid", "cryptoAmountDue", "settledAt"): + if inv.get(k) is not None: + view[k] = inv[k] + if inv.get("paidInFull") is not None: + view["paidInFull"] = inv["paidInFull"] + if inv["method"] == "card": + view["clientSecret"] = inv["clientSecret"] + else: + view["address"] = inv["address"] + view["cryptoAmount"] = inv["cryptoAmount"] + view["cryptoCurrency"] = inv["method"] + view["requiredConfirmations"] = REQUIRED_CONFIRMATIONS + return view + + +def with_publishable_key(html): + """The publishable key is compiled into the page. Here it comes + from the environment, so nothing that could be a real key is ever written + back into public/index.html. Unset leaves the committed empty value, which + is what selects the development stand-in.""" + if not STRIPE_PUBLISHABLE_KEY: + return html + text, found = KEY_META.subn(lambda m: m.group(1) + STRIPE_PUBLISHABLE_KEY + m.group(2), html.decode()) + if found != 1: + raise RuntimeError("mock: the shell has no stripe-publishable-key meta element to fill") + return text.encode() + + +class Handler(BaseHTTPRequestHandler): + protocol_version = "HTTP/1.1" + + def log_message(self, *args): + pass + + def _send(self, status, payload, ctype="application/json"): + body = payload if isinstance(payload, bytes) else json.dumps(payload).encode() + try: + self.send_response(status) + self.send_header("content-type", ctype) + self.send_header("content-length", str(len(body))) + self.send_header("cache-control", "no-store") + self.end_headers() + self.wfile.write(body) + except (BrokenPipeError, ConnectionResetError): + # A client that drops during a long poll leaves the invoice untouched and the page + # reissues on its next load, so there is nothing to retry. + self.close_connection = True + + def _read_json(self): + length = int(self.headers.get("content-length") or 0) + try: + return json.loads(self.rfile.read(length) or b"{}") + except Exception: + return None + + def do_POST(self): + path = urlparse(self.path).path + + if path.startswith("/control/"): + parts = path.strip("/").split("/") + if len(parts) != 3: + return self._send(400, {"error": "bad_request"}) + _, action, invoice_id = parts + with LOCK: + inv = INVOICES.get(invoice_id) + if inv is None: + return self._send(404, {"error": "not_found"}) + if action == "settle": + inv["status"] = "paid" + inv["amountPaid"] = inv["amount"] + inv["settledAt"] = now_iso() + inv["paidInFull"] = True + if inv["method"] != "card": + inv["cryptoAmountPaid"] = inv["cryptoAmount"] + inv["cryptoAmountDue"] = "0.000" + elif action == "expire": + inv["status"] = "expired" + elif action == "confirming": + inv["amountPaid"] = inv["amount"] + inv["paidInFull"] = True + if inv["method"] != "card": + inv["cryptoAmountPaid"] = inv["cryptoAmount"] + inv["cryptoAmountDue"] = "0.000" + elif action == "verdict": + # Monero reports the payment as paid in full while its figures are still zero. + inv["paidInFull"] = True + elif action == "partial": + inv["amountPaid"] = inv["amount"] // 2 + inv["paidInFull"] = False + if inv["method"] != "card": + inv["cryptoAmountPaid"] = "0.734" + inv["cryptoAmountDue"] = "0.752" + else: + return self._send(400, {"error": "bad_request"}) + status = inv["status"] + old_event = swap_event(invoice_id) + if old_event is not None: + old_event.set() + return self._send(200, {"ok": True, "status": status}) + + if path.startswith("/api/invoice/") and path.endswith("/cancel"): + invoice_id = path[len("/api/invoice/"):-len("/cancel")] + with LOCK: + inv = INVOICES.get(invoice_id) + if inv is None: + return self._send(404, {"error": "not_found"}) + if inv["status"] != "open": + return self._send(409, {"error": "not_open"}) + if payment_mark(inv) != ("", False) or inv.get("amountPaid"): + # Cancelling a funded invoice would strand what the buyer already sent. + return self._send(409, {"error": "funded"}) + inv["status"] = "expired" + payload = {"invoiceId": invoice_id, **public_view(inv)} + old_event = swap_event(invoice_id) + if old_event is not None: + old_event.set() + return self._send(200, payload) + + if path == "/api/invoice": + body = self._read_json() + if not body or not isinstance(body.get("codeHash"), str) or not body["codeHash"]: + return self._send(400, {"error": "bad_request"}) + if body.get("method") not in ("card", "btc", "xmr"): + return self._send(400, {"error": "bad_request"}) + with LOCK: + if body["codeHash"] in HASHES: + return self._send(409, {"error": "code_conflict"}) + t = total(body.get("priceId"), body.get("offerId")) + if t is None: + return self._send(400, {"error": "catalog_changed"}) + invoice_id = secrets.token_urlsafe(16) + is_card = body["method"] == "card" + inv = { + "invoiceId": invoice_id, "method": body["method"], "status": "open", + "badgeType": CATALOG[body["priceId"]]["badgeType"], "months": t["months"], + "amount": t["amount"], "currency": "usd", + "expiresAt": (datetime.now(timezone.utc) + timedelta(hours=1)) + .replace(microsecond=0).isoformat().replace("+00:00", "Z"), + "clientSecret": f"cs_test_{secrets.token_hex(12)}" if is_card else None, + "address": None if is_card else ADDRESSES[body["method"]], + "cryptoAmount": None if is_card else "1.482", + } + INVOICES[invoice_id] = inv + HASHES[body["codeHash"]] = invoice_id + EVENTS[invoice_id] = threading.Event() + payload = {"invoiceId": invoice_id, **public_view(inv)} + return self._send(200, payload) + + return self._send(405, {"error": "bad_request"}) + + def do_GET(self): + parsed = urlparse(self.path) + # An empty `seenPaid=` means the page rendered no figure, which differs from the parameter + # being absent, so blank values are kept. + path, query = parsed.path, parse_qs(parsed.query, keep_blank_values=True) + + if path.startswith("/api/invoice/"): + invoice_id = path[len("/api/invoice/"):] + with LOCK: + inv = INVOICES.get(invoice_id) + if inv is None: + return self._send(404, {"error": "not_found"}) + current = inv["status"] + held = payment_mark(inv) + event = EVENTS.get(invoice_id) + wait = (query.get("wait") or [None])[0] + # A payment recorded before this request arrived cannot fire the event this request + # would wait on, so holding then would strand the buyer on the payment screen. + seen = ((query.get("seenPaid") or [""])[0], (query.get("seenFull") or ["0"])[0] == "1") + unseen = "seenPaid" in query and seen != held + if wait is not None and wait == current and not unseen and event is not None: + # The event is never cleared; settle, expire and partial replace it with a fresh + # one under the lock, so a set event always means a change happened after this + # reference was taken. + event.wait(timeout=HOLD_SECONDS) + with LOCK: + inv = INVOICES[invoice_id] + payload = {"invoiceId": invoice_id, **public_view(inv)} + return self._send(200, payload) + + rel = "index.html" if path == "/" else path.lstrip("/") + for base in ("public", "dist"): + base_resolved = (ROOT / base).resolve() + candidate = (base_resolved / rel).resolve() + try: + candidate.relative_to(base_resolved) + except ValueError: + # The path escaped this base directory, so move to the next one. + continue + if candidate.is_file(): + ctype = MIME.get(candidate.suffix, "application/octet-stream") + body = candidate.read_bytes() + if candidate.name == "index.html": + body = with_publishable_key(body) + return self._send(200, body, ctype) + return self._send(404, {"error": "not_found"}) + + +class Server(ThreadingHTTPServer): + daemon_threads = True + + def handle_error(self, request, client_address): + # socketserver's default prints a traceback for a dropped client, which is routine under + # a long poll, so suppress it while letting anything else surface. + if isinstance(sys.exc_info()[1], (BrokenPipeError, ConnectionResetError)): + return + super().handle_error(request, client_address) + + +def main(): + port = 8099 + if "--port" in sys.argv: + port = int(sys.argv[sys.argv.index("--port") + 1]) + if STRIPE_PUBLISHABLE_KEY and not STRIPE_PUBLISHABLE_KEY.startswith("pk_"): + # A secret or restricted key (sk_, rk_) would be written into the page for anyone to read, + # so only a publishable key (pk_) is allowed. + sys.exit("mock: STRIPE_PUBLISHABLE_KEY must be a publishable key (pk_...)") + server = Server(("127.0.0.1", port), Handler) + print(f"mock badge service on http://localhost:{port}", flush=True) + print("stripe: " + (f"publishable key {STRIPE_PUBLISHABLE_KEY[:11]}… — the real card form" + if STRIPE_PUBLISHABLE_KEY + else "no STRIPE_PUBLISHABLE_KEY — the card path renders the development stand-in"), + flush=True) + server.serve_forever() + + +if __name__ == "__main__": + main() diff --git a/apps/simplex-badge-service/web/package-lock.json b/apps/simplex-badge-service/web/package-lock.json new file mode 100644 index 0000000000..4c40bd373f --- /dev/null +++ b/apps/simplex-badge-service/web/package-lock.json @@ -0,0 +1,45 @@ +{ + "name": "simplex-badge-web", + "lockfileVersion": 3, + "requires": true, + "packages": { + "": { + "name": "simplex-badge-web", + "devDependencies": { + "@types/node": "^24.0.0", + "typescript": "^6.0.0" + } + }, + "node_modules/@types/node": { + "version": "24.13.3", + "resolved": "https://registry.npmjs.org/@types/node/-/node-24.13.3.tgz", + "integrity": "sha512-Dh8vAsV36ig5wa9OX4pXvMc9D3Veibfw2wix0CUwYODLD8nkj9UsLjASr49nPg+2eKzxhBV+v7L8pXvT4e639Q==", + "dev": true, + "license": "MIT", + "dependencies": { + "undici-types": "~7.18.0" + } + }, + "node_modules/typescript": { + "version": "6.0.3", + "resolved": "https://registry.npmjs.org/typescript/-/typescript-6.0.3.tgz", + "integrity": "sha512-y2TvuxSZPDyQakkFRPZHKFm+KKVqIisdg9/CZwm9ftvKXLP8NRWj38/ODjNbr43SsoXqNuAisEf1GdCxqWcdBw==", + "dev": true, + "license": "Apache-2.0", + "bin": { + "tsc": "bin/tsc", + "tsserver": "bin/tsserver" + }, + "engines": { + "node": ">=14.17" + } + }, + "node_modules/undici-types": { + "version": "7.18.2", + "resolved": "https://registry.npmjs.org/undici-types/-/undici-types-7.18.2.tgz", + "integrity": "sha512-AsuCzffGHJybSaRrmr5eHr81mwJU3kjw6M+uprWvCXiNeN9SOGwQ3Jn8jb8m3Z6izVgknn1R0FTCEAP2QrLY/w==", + "dev": true, + "license": "MIT" + } + } +} diff --git a/apps/simplex-badge-service/web/package.json b/apps/simplex-badge-service/web/package.json new file mode 100644 index 0000000000..eb42e5c0cb --- /dev/null +++ b/apps/simplex-badge-service/web/package.json @@ -0,0 +1,14 @@ +{ + "name": "simplex-badge-web", + "private": true, + "type": "module", + "scripts": { + "build": "rm -rf build && tsc -p tsconfig.json && tsc -p tsconfig.test.json && node build.js", + "test": "rm -rf build && tsc -p tsconfig.json && tsc -p tsconfig.test.json && node check-tests.js && TZ=UTC node --test 'build/test/**/*.test.js'", + "mock": "python3 mock/server.py" + }, + "devDependencies": { + "typescript": "^6.0.0", + "@types/node": "^24.0.0" + } +} diff --git a/apps/simplex-badge-service/web/public/img/hero-dark.png b/apps/simplex-badge-service/web/public/img/hero-dark.png new file mode 100644 index 0000000000..07362c870d Binary files /dev/null and b/apps/simplex-badge-service/web/public/img/hero-dark.png differ diff --git a/apps/simplex-badge-service/web/public/img/hero-light.png b/apps/simplex-badge-service/web/public/img/hero-light.png new file mode 100644 index 0000000000..2f36b060c7 Binary files /dev/null and b/apps/simplex-badge-service/web/public/img/hero-light.png differ diff --git a/apps/simplex-badge-service/web/public/img/symbol-dark.svg b/apps/simplex-badge-service/web/public/img/symbol-dark.svg new file mode 100644 index 0000000000..fa598acf3d --- /dev/null +++ b/apps/simplex-badge-service/web/public/img/symbol-dark.svg @@ -0,0 +1,10 @@ + + + + + + + + + + diff --git a/apps/simplex-badge-service/web/public/img/symbol-light.svg b/apps/simplex-badge-service/web/public/img/symbol-light.svg new file mode 100644 index 0000000000..d8b5951a0b --- /dev/null +++ b/apps/simplex-badge-service/web/public/img/symbol-light.svg @@ -0,0 +1,15 @@ + + + + + + + + + + + + + + + diff --git a/apps/simplex-badge-service/web/public/img/wordmark-dark.svg b/apps/simplex-badge-service/web/public/img/wordmark-dark.svg new file mode 100644 index 0000000000..3ada958e11 --- /dev/null +++ b/apps/simplex-badge-service/web/public/img/wordmark-dark.svg @@ -0,0 +1,11 @@ + + + + + + + + + + + diff --git a/apps/simplex-badge-service/web/public/img/wordmark-light.svg b/apps/simplex-badge-service/web/public/img/wordmark-light.svg new file mode 100644 index 0000000000..b845ff219d --- /dev/null +++ b/apps/simplex-badge-service/web/public/img/wordmark-light.svg @@ -0,0 +1,11 @@ + + + + + + + + + + + diff --git a/apps/simplex-badge-service/web/public/index.html b/apps/simplex-badge-service/web/public/index.html new file mode 100644 index 0000000000..027b8887c6 --- /dev/null +++ b/apps/simplex-badge-service/web/public/index.html @@ -0,0 +1,49 @@ + + + + + + + + + + + + + +Support SimpleX + + + + + + + + + + +
+

Support SimpleX

SimpleX has no ads, no user accounts and nothing to sell.

A supporter badge helps pay for the people who build it.

Already bought a code?

Redeem it in the app: Settings, Supporter perks.

The badge shows on your profile. Nothing renews by itself, and no account is created.

+ + + + + diff --git a/apps/simplex-badge-service/web/public/styles.css b/apps/simplex-badge-service/web/public/styles.css new file mode 100644 index 0000000000..4898616643 --- /dev/null +++ b/apps/simplex-badge-service/web/public/styles.css @@ -0,0 +1,1108 @@ +/* Every colour, radius, face and type step below is the published SimpleX design's own + value. Where one is not, the line says why. */ +:root { + /* Tell the UA which ground to paint before the first message and on a reload's blank frame, and + which form controls and scrollbars to render; the dark blocks flip it with the palette. */ + color-scheme: light; + /* One accent in both themes, with white on it in both: #3889FF on white is + 3.6:1 for the 16/700 label it carries. */ + --accent: #3889FF; + --accent-hover: #2F7BEC; /* the accent, one step down in value */ + --accent-pressed: #2A6ED6; + --on-accent: #ffffff; + --ink: #1E2122; + --bg: #F7F7F7; + --surface: #FFFFFF; + --menu: #FFFFFF; /* the popup, one step off the page */ + --line: #E8E8E8; + /* one faint blue wash over the flat ground, and nothing else */ + --page: radial-gradient(50% 50% at 50% 50%, rgba(82, 152, 255, .063) 0%, rgba(255, 255, 255, 0) 100%); + + /* Secondary text is the ink at two lower emphases, so the page stays one hue + and composites correctly over the wash. 8.9:1 and 6.2:1 on #F7F7F7. */ + --body: rgba(30, 33, 34, .72); + --muted: rgba(30, 33, 34, .56); + /* The ink at 4%: the menu's hover, the landing screen's info panel, and a card the catalog + cannot price. */ + --tint: rgba(30, 33, 34, .04); + + --title: linear-gradient(330.4deg, #44BCF0 4.54%, #7298F8 59.2%, #A099FF 148.85%); + + /* Settled, waiting and failed, each a foreground on its own ground. */ + --ok-fg: #1c7c3f; + --ok-bg: #e8f5ec; + --ok-line: #bfe3cc; + --warn-fg: #8a6100; + --warn-bg: #fff8e6; + --warn-line: #f0dcae; + --danger-fg: #b3261e; + --danger-bg: #fdecec; + --danger-line: #f3c9c6; + + /* the code screen's code frame, in the one accent both themes share. */ + --code-bg: rgba(56, 137, 255, .06); + --code-line: rgba(56, 137, 255, .35); + + /* A primary button with nothing to do: a flat bar with a washed label, legible + at 4.0:1. See `.primary[disabled]` for why it is not the accent faded. */ + --disabled: rgba(30, 33, 34, .07); + --on-disabled: rgba(30, 33, 34, .50); + + /* Switched with the theme rather than tinted by it. The dark wordmark is the + same file with its `#030749` set to white. */ + --hero: url(hero-light.png); + --wordmark: url(wordmark-light.svg); + + /* a card is a 1px border at radius 20 with no shadow, and every button a pill; the + only shadow on the page is the menu's */ + --r-card: 20px; + --r-pill: 9999px; + --shadow-pop: 0 2px 6px rgba(0, 0, 0, .06), 0 16px 40px rgba(0, 0, 0, .12); + + /* Satoshi is not vendored and may not be fetched, so the system face is what + actually renders. */ + --font: Satoshi, -apple-system, BlinkMacSystemFont, "Segoe UI", Roboto, Oxygen, Ubuntu, Cantarell, "Fira Sans", "Droid Sans", "Helvetica Neue", sans-serif; + --mono: ui-monospace, SFMono-Regular, Menlo, Consolas, monospace; +} + +/* The dark palette is written twice on purpose: the media query claims + everything that is not an explicit light, and the attribute rule claims an + explicit dark, which is how `system`, `light` and `dark` all win where they + should. Both blocks must declare the same tokens and values, and + `design.test.ts` fails if they diverge. */ +@media (prefers-color-scheme: dark) { + :root:not([data-theme="light"]) { + color-scheme: dark; + /* The accent does not move between themes, and the dark surface #1E2122 is the + light theme's ink, to the byte. */ + --ink: #FFFFFF; + --bg: #141416; + --surface: #1E2122; + --menu: #242427; + --line: #424347; + /* the dark ground is flat: the light theme's wash would be a smear */ + --page: none; + + --body: rgba(255, 255, 255, .72); + --muted: rgba(255, 255, 255, .56); + --tint: rgba(255, 255, 255, .06); + + /* The light theme's three hues, lightened to sit on #141416, each with its + own ground at a low alpha of itself. */ + --ok-fg: #7FE3A6; + --ok-bg: rgba(127, 227, 166, .12); + --ok-line: rgba(127, 227, 166, .28); + --warn-fg: #F5C86A; + --warn-bg: rgba(245, 200, 106, .12); + --warn-line: rgba(245, 200, 106, .28); + --danger-fg: #FF9F98; + --danger-bg: rgba(255, 159, 152, .12); + --danger-line: rgba(255, 159, 152, .28); + + --code-bg: rgba(56, 137, 255, .12); + --code-line: rgba(56, 137, 255, .45); + + --disabled: rgba(255, 255, 255, .09); + --on-disabled: rgba(255, 255, 255, .45); + + --hero: url(hero-dark.png); + --wordmark: url(wordmark-dark.svg); + + --shadow-pop: 0 2px 8px rgba(0, 0, 0, .50), 0 16px 40px rgba(0, 0, 0, .55); + } +} + +/* The same palette again, for the menu's explicit Dark. */ +:root[data-theme="dark"] { + color-scheme: dark; + --ink: #FFFFFF; + --bg: #141416; + --surface: #1E2122; + --menu: #242427; + --line: #424347; + --page: none; + + --body: rgba(255, 255, 255, .72); + --muted: rgba(255, 255, 255, .56); + --tint: rgba(255, 255, 255, .06); + + --ok-fg: #7FE3A6; + --ok-bg: rgba(127, 227, 166, .12); + --ok-line: rgba(127, 227, 166, .28); + --warn-fg: #F5C86A; + --warn-bg: rgba(245, 200, 106, .12); + --warn-line: rgba(245, 200, 106, .28); + --danger-fg: #FF9F98; + --danger-bg: rgba(255, 159, 152, .12); + --danger-line: rgba(255, 159, 152, .28); + + --code-bg: rgba(56, 137, 255, .12); + --code-line: rgba(56, 137, 255, .45); + + --disabled: rgba(255, 255, 255, .09); + --on-disabled: rgba(255, 255, 255, .45); + + --hero: url(hero-dark.png); + --wordmark: url(wordmark-dark.svg); + + --shadow-pop: 0 2px 8px rgba(0, 0, 0, .50), 0 16px 40px rgba(0, 0, 0, .55); +} + +* { box-sizing: border-box; } + +/* Reserve the scrollbar's width always, so a panel whose height changes (the Payment Element + autofilling or a 3DS challenge resizing it) cannot toggle the scrollbar and jog the centred + column sideways, which `#app`'s overflow-x then clips. */ +html { scrollbar-gutter: stable; } + +body { + margin: 0; + /* The gutter is here, so `#app` is exactly the 560px content column and + nothing inside it has to subtract padding to reach that width. */ + padding: 0 20px; + min-height: 100vh; + background: var(--bg); + /* Fixed, so the wash does not tile or scroll away on a long screen. */ + background-image: var(--page); + background-attachment: fixed; + color: var(--ink); + font-family: var(--font); + /* the scale: 1rem/1.25 body, .875 small, .75 extra-small, larger steps below */ + font-size: 16px; + line-height: 1.5; + -webkit-font-smoothing: antialiased; +} + +#app { max-width: 560px; margin: 0 auto; overflow-x: hidden; } + +/* The shell ships a static copy of the first screen (see index.html), so the first paint is the real + landing, not an empty page, and `main.ts` swaps in its own identical markup with no flash. Embedded, + the site owns the navbar, so the shell's copy of it is hidden there as the built one would be. */ +.embedded #chrome { display: none; } + +/* A reload of any screen but the landing can't be prerendered (the screen depends on runtime state), + so `init.js` marks it `sb-booting` before the first paint: the shell's landing is held hidden over + the themed ground, and `main.ts` clears the mark once it has painted the real screen, which then + fades in rather than replacing a flash of the landing. The landing route is never marked, so its + prerendered first paint stays instant. */ +#app { transition: opacity .2s ease; } +.sb-booting #app { opacity: 0; } + +/* Embedded in the site: the site's fixed navbar sits above the frame, so pad the top to clear it, + and drop the page's own wash so the flat background the site hands in shows through cleanly. The + site carries its own footer below the frame, so ours would only double the contact link and leave + its accent line at the frame's edge — hide it embedded. */ +/* Standalone, the body fills the viewport so the footer sits at the bottom; embedded, the host sizes + the frame to the body, so a `100vh` floor would make the body's height depend on the frame height + the host derived from it — a loop that ratchets the frame taller and drops the site's footer as the + zoom shifts. Drop the floor so the body is exactly its content. */ +.embedded body { padding-top: 54px; background-image: none; min-height: 0; } +.embedded footer { display: none; } + +/* Embedded in the site's dark theme, the standalone grey surfaces read as off against the navy the + site hands in. Follow the site's own dark-card idiom instead: a faint white veil and hairline on + the navy ground, so a panel is a lighter navy rather than a grey block. Both selectors, to match + `system` dark (media query) and the explicit Dark choice (data-theme). */ +@media (prefers-color-scheme: dark) { + :root.embedded:not([data-theme="light"]) { + --surface: rgba(255, 255, 255, .05); + --menu: rgba(255, 255, 255, .07); + --line: rgba(255, 255, 255, .22); + } +} +:root.embedded[data-theme="dark"] { + --surface: rgba(255, 255, 255, .05); + --menu: rgba(255, 255, 255, .07); + --line: rgba(255, 255, 255, .22); +} + +/* ------------------------------------------------------------------- chrome */ + +/* The wordmark on the left, and on the right a circular icon button holding the + hamburger. It spans the page rather than the 560 column, so the column reads + as content inside a site rather than as the whole site. */ +.chrome-bar { + display: flex; + align-items: center; + justify-content: space-between; + gap: 16px; + min-height: 56px; + max-width: 1120px; + margin: 0 auto; + padding: 8px 4px; +} + +/* The official wordmark, drawn from the file. The URL is relative, so it + resolves inside /assets// beside this sheet and is precached with + everything else. */ +.brand { + display: block; + width: 132px; + aspect-ratio: 161 / 40; + background-image: var(--wordmark); + background-size: contain; + background-position: left center; + background-repeat: no-repeat; + /* A link with no text: the accessible name is on the element. */ + text-indent: -9999px; + overflow: hidden; +} + +.menu-wrap { position: relative; } + +/* 40 rather than the reference's 32, which is under every platform's minimum + touch target and this is the header's only control. */ +.menu-button { + display: flex; + align-items: center; + justify-content: center; + width: 40px; + height: 40px; + padding: 0; + border: 0; + border-radius: 50%; + /* The hairline colour as a fill, which on both grounds is the reference's own + circle without a fourth grey. */ + background: var(--line); + color: var(--ink); + cursor: pointer; +} +.menu-button:hover, .menu-button[aria-expanded="true"] { color: var(--accent); } +.bars { display: block; width: 20px; height: 20px; } + +/* The panel, anchored under the button and right-aligned to it, one step off + the page ground, with a hairline and the page's only drop shadow. */ +.menu { + position: absolute; + top: calc(100% + 8px); + right: 0; + z-index: 20; + width: 320px; + border: 1px solid var(--line); + border-radius: 14px; + background: var(--menu); + box-shadow: var(--shadow-pop); + text-align: left; + overflow: hidden; +} +.menu[hidden] { display: none; } + +/* Full-bleed hairlines between sections, so the padding is on the section and + never on the panel. */ +.menu-section { padding: 6px; } +.menu-section + .menu-section { border-top: 1px solid var(--line); } + +.menu-row { + display: flex; + align-items: center; + justify-content: space-between; + gap: 12px; + padding: 6px 10px; +} +.menu-label { font-size: .875rem; font-weight: 700; color: var(--ink); } + +/* the segmented setting: three values in one pill, the chosen one in the + accent with white on it. */ +.segmented { + display: flex; + padding: 2px; + border-radius: var(--r-pill); + background: var(--tint); +} +.segment { + padding: 5px 11px; + border: 0; + border-radius: var(--r-pill); + background: none; + color: var(--muted); + font: inherit; + font-size: .75rem; + font-weight: 700; + cursor: pointer; +} +.segment:hover { color: var(--ink); } +.segment[aria-pressed="true"] { background: var(--accent); color: var(--on-accent); } + +.menu-item { + display: block; + width: 100%; + padding: 10px; + border: 0; + border-radius: 10px; + background: none; + color: var(--ink); + font: inherit; + font-size: .875rem; + font-weight: 500; + text-align: left; + cursor: pointer; +} +.menu-item[hidden] { display: none; } +.menu-item:hover { background: var(--tint); color: var(--accent); } +.menu-item.danger { color: var(--danger-fg); } +.menu-item.danger:hover { background: var(--danger-bg); color: var(--danger-fg); } + +/* the footer, on every screen: a hairline across the column, then the + contact link centred under it in the accent. */ +footer { + max-width: 560px; + margin: 0 auto; + text-align: center; +} +footer a { + display: block; + border-top: 1px solid var(--line); + padding: 16px 0 34px; + color: var(--accent); + font-size: .875rem; + text-decoration: none; +} +footer a:hover { text-decoration: underline; } + +/* The keyboard's equivalent of the hover underline, declared rather than left + to the user agent, whose thin dark outline all but disappears on the accent + button and on the dark ground. `:focus-visible`, so a mouse press leaves + nothing behind. */ +:focus-visible { + outline: 2px solid var(--accent); + outline-offset: 2px; +} +/* On the accent ground itself an accent ring is invisible, so it inverts. */ +.primary:not(.outline):focus-visible { outline-color: var(--ink); } + +/* -------------------------------------------------------------- the wizard */ + +/* the horizontal track, in two elements, because one cannot clip and travel + at the same time. `.track` clips and is the height of the panel in view; + `.rail` is the flex row of four panels and is what translates. Both animate, + so the outgoing panel travels off one edge while the incoming one arrives at + the other. `main.ts` writes the height and the transform, and sets `--slide` + to 0ms for any move that is not a step. + + `overflow: hidden` is also what makes this a stepper rather than a carousel: + there is no scroll to drag. Unreached panels carry `inert`, so Tab cannot + enter them either. */ +.track { + overflow: hidden; + transition: height var(--slide, 320ms) cubic-bezier(.22, .61, .36, 1); +} +.rail { + display: flex; + align-items: flex-start; + width: 100%; + transition: transform var(--slide, 320ms) cubic-bezier(.22, .61, .36, 1); +} +/* Below the column width each panel is the viewport width: the same track is + the phone flow, with only the padding and the type scale changing. */ +.panel { + flex: 0 0 100%; + min-width: 0; + padding: 12px 0 22px; + text-align: center; +} +@media (prefers-reduced-motion: reduce) { + .track, .rail { transition: none; } +} + +/* Every payment screen and `#/codes` takes the same shell as a wizard panel. + The 20px a trailing button adds is the difference between a footer rule under + a button and one under a block of text. */ +.panel > button:last-child { margin-bottom: 20px; } + +/* ------------------------------------------------------------------ headings */ + +h1 { + font-size: 2.25rem; + line-height: 3rem; + font-weight: 800; + color: var(--ink); + margin: 12px 0 0; +} +/* The heading is the gradient, clipped to its own glyphs, in both themes. + Guarded, because the fill is transparent: a browser that cannot clip a + background to text would render every heading invisible. */ +@supports ((background-clip: text) or (-webkit-background-clip: text)) { + h1 { + background-image: var(--title); + -webkit-background-clip: text; + background-clip: text; + color: transparent; + } +} +/* the payment screen and the code screen take one step down from the landing screen's. */ +h1.tight { font-size: 1.875rem; line-height: 2.5rem; margin-top: 15px; } + +.lede { + font-size: 1.125rem; + line-height: 1.5; + color: var(--body); + margin: 10px 0 0; +} +h1 + .lede { margin-top: 10px; } +h1.tight + .lede { margin-top: 6px; } +/* Two ledes are two sentences of one paragraph, a line height apart rather than + a paragraph gap. */ +.lede + .lede { margin-top: 0; } + +.muted { color: var(--muted); font-size: .875rem; margin: 14px 0 0; } +/* A narrower measure than the column, so the closing footnote breaks in two rather than + reading as a caption that ran on. Scoped to a direct child, so it cannot reach the same + class inside a left-aligned field and indent the line it holds. */ +.panel > p.muted { max-width: 332px; margin-left: auto; margin-right: auto; } +/* Shown beside the status while the browser is offline, not instead of it. */ +.offline { color: var(--warn-fg); } +.center { text-align: center; } + +/* Figures that are compared down a column, or that change in place while the + buyer is looking at them. The default proportional digits are narrower on 1 + than on 0, so the payment screen's held-rate clock and the rate-limited screen's countdown shifted every second + they ticked, and the duration list's three prices did not line up under one another. + `.notice .title` is the rate-limited screen's countdown, which is the only figure that line ever + holds. */ +.row, .choice .price, .rate, .notice .title, .entry .meta { + font-variant-numeric: tabular-nums; +} + +/* ← Back is the first thing in the panel, on the left of the column. */ +.back { + display: block; + color: var(--accent); + background: none; + border: 0; + font: inherit; + font-size: 1rem; + font-weight: 500; + text-align: left; + cursor: pointer; + padding: 0; + margin: 0; +} + +/* -------------------------------------------------------------------- buttons */ + +/* Spans the column because it is the column's one action. */ +.primary { + display: block; + width: 100%; + min-height: 48px; + padding: 8px 16px; + border: 0; + border-radius: var(--r-pill); + background: var(--accent); + color: var(--on-accent); + font: inherit; + font-size: 1rem; + font-weight: 700; + line-height: 1.25; + cursor: pointer; + margin: 24px 0 0; + transition: background-color 120ms linear; +} +.primary:not([disabled]):not(.copied):hover { background: var(--accent-hover); } +.primary:not([disabled]):not(.copied):active { background: var(--accent-pressed); } +/* A different shape, not a faded one: the accent at reduced opacity still reads + as the live button, so a Continue that cannot continue looks broken rather + than not-yet-answered. */ +.primary[disabled] { + background: var(--disabled); + color: var(--on-disabled); + cursor: default; +} + +/* The same button as an outline, which is what the closed-window screen's [ New invoice ] and the code screen's + [ Copy code ] are. */ +.primary.outline { + background: none; + color: var(--accent); + border: 1.5px solid var(--accent); +} +.primary.outline:not([disabled]):not(.copied):hover { background: var(--tint); color: var(--accent-hover); } + +/* A minimum height and not a fixed one: at the 320px floor a two-line + label would otherwise put its second line outside the border. */ +.secondary { + display: flex; + align-items: center; + justify-content: center; + width: 100%; + min-height: 48px; + padding: 8px 16px; + border: 1px solid var(--line); + border-radius: var(--r-pill); + background: var(--surface); + color: var(--accent); + font: inherit; + font-size: 1rem; + font-weight: 700; + text-align: center; + text-decoration: none; + cursor: pointer; + margin: 12px 0 0; + line-height: 1.25; +} +.secondary:not(.copied):hover { border-color: var(--accent); } + +/* the payment screen's Copy, which lives inside the address panel rather than under it. */ +.secondary.inline { + display: inline; + width: auto; + min-height: 0; + height: auto; + padding: 0; + border: 0; + background: none; + font-size: .875rem; + line-height: inherit; + margin: 0; +} +.secondary.inline:not(.copied):hover { text-decoration: underline; } + +/* A copy that landed, confirmed on the control itself for two seconds. + Every hover rule above excludes it: the pointer is still on the button that + was just pressed, and a hover colour would overwrite the confirmation. */ +.copied { color: var(--ok-fg); border-color: var(--ok-line); } +.primary.copied { background: none; color: var(--ok-fg); border-color: var(--ok-fg); } +.secondary.inline.copied { text-decoration: none; } +/* The failure line only: a success never lands here, so this is empty until + something goes wrong, and empty it takes up no room. */ +.copy-status:empty, .cancel-status:empty { display: none; } + +.link { + background: none; + border: 0; + padding: 0; + font: inherit; + font-size: .875rem; + color: var(--accent); + cursor: pointer; + text-decoration: none; +} +.link:hover { text-decoration: underline; } +.link.danger { color: var(--danger-fg); } +.link[disabled] { color: var(--muted); cursor: default; text-decoration: none; } +p.row-line { margin: 16px 0 0; } + +/* --------------------------------------------------------------- the choices */ + +/* the tier list's tiers and the duration list's durations stay side by side at every width: values being + compared must stay comparable. Only the type scale shrinks. */ +.choices { display: flex; gap: 14px; margin: 26px 0 0; align-items: stretch; } +.choice { + /* A column, explicitly top-aligned: a