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 4f73442c36..4ceea4d1a1 100644 --- a/.gitignore +++ b/.gitignore @@ -87,4 +87,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..945256f814 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,163 @@ 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 key can come from `badge_service.ini` instead: + +```ini +[issuer] +index = 1 +private_key = +``` + +`index` is the index clients verify against (`badgePublicKeys` in `ChatConfig`), and `private_key` +is the secret that signs. Both are required, and the key is checked at startup like the flags. +Rotating is a change to both and a restart, once clients trust the new index. + +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 + **PaymentIntents: write**, to create and cancel intents, plus **Charges: read** — the poller + reads an intent with `expand[]=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. +- `session_minutes` — how many minutes an unpaid card order stays open (1 to 1440, default 60). + Ten minutes after that, the service cancels the payment at Stripe, and retries if that fails. + If the order is over 72 hours old and the cancel has kept failing for an hour, the service marks + it expired and logs an error. Check such orders in the Stripe Dashboard. After a restart, the + hour starts again. + +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. A delivery signed more than +15 minutes away from the server's clock is refused with a warning, so keep the clock synced (NTP). + +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 +228,21 @@ 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. A code that +was already redeemed cannot be revoked: its badge was issued, and the command answers with an error. + 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..b1f5f4b1c1 --- /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; 1-1440 +session_minutes = 60 + +[poll] +waiting_seconds = 3 +idle_seconds = 60 + +; the key this service signs credentials with. index is the index clients verify against, so +; private_key has to be one whose public half already ships in the apps at that index: 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. +; to rotate, change index and private_key together, once clients trust the new index. +; the key is checked at startup, so this section stays commented out until it holds a real key. +;[issuer] +;index = 1 +;private_key = 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..10d55d7da7 --- /dev/null +++ b/apps/simplex-badge-service/src/BadgeService/Config.hs @@ -0,0 +1,284 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module BadgeService.Config + ( ListenerConfig (..), + BTCPayConfig (..), + StripeConfig (..), + SpeedPolicy (..), + speedPolicyName, + PollConfig (..), + BadgeIssuerKey (..), + 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.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) + +data BadgeIssuerKey = BadgeIssuerKey + { keyIdx :: Int, + secretKey :: BBSSecretKey + } + deriving (Eq) + +-- BBSSecretKey derives Show, so this is written out to keep the secret out of logs and errors +instance Show BadgeIssuerKey where + show BadgeIssuerKey {keyIdx} = "issuer key " <> show keyIdx + +data ServiceConfig = ServiceConfig + { listener :: ListenerConfig, + btcpay :: Maybe BTCPayConfig, + stripe :: Maybe StripeConfig, + poll :: PollConfig, + issuer :: Maybe BadgeIssuerKey, + -- 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 + +-- | At most one day, so a card order expires long before the poller stops checking it at 72 hours. +minSessionMinutes, maxSessionMinutes :: Int +minSessionMinutes = 1 +maxSessionMinutes = 1440 + +-- | 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) + +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"]), + ("issuer", ["index", "private_key"]) + ] + +unknownKeys :: Ini -> [Text] +unknownKeys ini = beforeAnySection <> unknownSections <> settings + where + beforeAnySection = [k <> ", written above the first section header" | (k, _) <- iniGlobals ini] + unknownSections = ["[" <> s <> "]" | s <- sections ini, T.strip s `notElem` map fst knownSettings] + 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 + keyIdx <- issuerIndex + secretKey <- issuerSecret + pure (Just BadgeIssuerKey {keyIdx, secretKey}) + issuerIndex = do + v <- required "issuer" "index" + case readMaybe (T.unpack v) of + Just n | n >= 1, n <= toInteger (maxBound :: Int) -> Right (fromInteger n) + _ -> Left "issuer.index must be a positive whole number" + issuerSecret = do + v <- required "issuer" "private_key" + either (const (Left "issuer.private_key is not a valid issuer secret; use the value from `simplex-chat badge keygen`")) Right $ + strDecode (B.pack (T.unpack v)) + 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..1d2423771a 100644 --- a/apps/simplex-badge-service/src/BadgeService/Options.hs +++ b/apps/simplex-badge-service/src/BadgeService/Options.hs @@ -5,19 +5,18 @@ module BadgeService.Options ( BadgeServiceOpts (..), - BadgeIssuerKey (..), getBadgeServiceOpts, badgeServiceOpts, mkChatOpts, ) where +import BadgeService.Config (BadgeIssuerKey (..)) import qualified Data.ByteString.Char8 as B import qualified Data.Text as T import Options.Applicative import Simplex.Chat.Controller (updateStr, versionNumber, versionString) import Simplex.Chat.Options (ChatCmdLog (..), ChatOpts (..), CoreChatOpts, CreateBotOpts (..), coreChatOptsP) -import Simplex.Messaging.Crypto.BBS (BBSSecretKey) import Simplex.Messaging.Encoding.String (strDecode) data BadgeServiceOpts = BadgeServiceOpts @@ -26,21 +25,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 - } - --- BBSSecretKey derives Show, so this is written out to keep the secret out of logs and errors -instance Show BadgeIssuerKey where - show BadgeIssuerKey {keyIdx} = "issuer key " <> show keyIdx - badgeServiceOpts :: FilePath -> FilePath -> Parser BadgeServiceOpts badgeServiceOpts appDir defaultDbName = do coreOptions <- coreChatOptsP appDir defaultDbName @@ -66,6 +55,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 +86,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..c91ffcd22f --- /dev/null +++ b/apps/simplex-badge-service/src/BadgeService/Poller.hs @@ -0,0 +1,376 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module BadgeService.Poller + ( PollerEnv (..), + ReadHints, + newReadHints, + queueReadHint, + hintQueueSize, + newPollerEnv, + runOnePass, + drainHints, + passDue, + runPoller, + passDelay, + SkipOwner (..), + skipOwner, + dueToWarn, + expiryGrace, + cancelGiveUpDelay, + readsPerPass, + skipWarnInterval, + maxSkipReasons, + ) +where + +import BadgeService.Config (PollConfig (..)) +import BadgeService.Orders (decide, settleOrder) +import BadgeService.Providers (ListPass (..), PaymentSignal (..), Provider (..), ProviderError (..), Received (..), expiresItself, settleWindow) +import BadgeService.Store.Invoices (InvoiceRow (..), OverdueInvoice (..), expireOverdue, getInvoiceByProviderRef, overdueInvoices, 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 (filterM, forever, unless, void, when) +import Data.List (find, partition, sortOn) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as M +import Data.Maybe (fromMaybe, isJust) +import Data.Set (Set) +import qualified Data.Set as S +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 + +-- | Give up on a failing cancel only after an hour, not on the first failure. +cancelGiveUpDelay :: NominalDiffTime +cancelGiveUpDelay = 3600 + +skipWarnInterval :: NominalDiffTime +skipWarnInterval = 3600 + +maxSkipReasons :: Int +maxSkipReasons = 4096 + +-- | Webhooks queue reads here, so all settling happens on the poller thread. +-- An order already waiting in the queue is not added again, so repeated webhooks don't pile up reads. +data ReadHints = ReadHints (TBQueue Text) (TVar (Set Text)) + +hintQueueSize :: Natural +hintQueueSize = 256 + +newReadHints :: IO ReadHints +newReadHints = ReadHints <$> newTBQueueIO hintQueueSize <*> newTVarIO S.empty + +queueReadHint :: ReadHints -> Text -> IO Bool +queueReadHint (ReadHints q queued) ref = atomically $ do + already <- S.member ref <$> readTVar queued + full <- isFullTBQueue q + if + | already -> pure True + | full -> pure False + | otherwise -> do + writeTBQueue q ref + modifyTVar' queued (S.insert ref) + pure True + +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, + -- When the cancel first failed, for orders older than 72 hours. + peCancelFailed :: TVar (Map Text UTCTime) + } + +newPollerEnv :: DBStore -> Waiters -> ReadHints -> [Provider] -> PollConfig -> IO PollerEnv +newPollerEnv peStore peWaiters peHints peProviders pePoll = do + peSkipped <- newTVarIO M.empty + peListedAt <- newTVarIO Nothing + peCancelFailed <- newTVarIO M.empty + pure PollerEnv {peStore, peWaiters, peHints, peProviders, pePoll, peSkipped, peListedAt, peStrayEvery = strayListInterval, peCancelFailed} + +-- | 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 env@PollerEnv {peStore, peWaiters, peCancelFailed} now = do + let cutoff = addUTCTime (negate expiryGrace) now + (selfExpiring, payable) <- partition (expiresItself . oiProvider) <$> overdueInvoices peStore cutoff + atomically $ modifyTVar' peCancelFailed (`M.restrictKeys` S.fromList (map oiProviderRef payable)) + -- Cancel only a few orders per pass, so a long list does not block other work. + cancelled <- filterM (closedAtProvider env now) (take readsPerPass payable) + expired <- expireOverdue peStore cutoff (map oiInvoiceId (selfExpiring <> cancelled)) + -- 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") + +-- | Cancel the order at the provider first, so the buyer can no longer pay it. +closedAtProvider :: PollerEnv -> UTCTime -> OverdueInvoice -> IO Bool +closedAtProvider env@PollerEnv {peProviders} now oi@OverdueInvoice {oiProvider, oiProviderRef = ref} = + safelyWith ("cancelling " <> tshow oiProvider <> " invoice " <> ref) False $ + case find ((== oiProvider) . pProvider) peProviders of + Nothing -> uncancelled env now oi "no provider is configured for it" + Just p -> + pCancelInvoice p ref >>= \case + Right () -> pure True + -- The provider won't cancel an order that is already paid or closed. Reading it shows which. + Left (ProviderError cancelError) -> + pReadInvoice p ref >>= \case + Right (Just signal) -> False <$ settleMoved env oiProvider now (ref, signal) + Right Nothing -> uncancelled env now oi cancelError + Left (ProviderError readError) -> uncancelled env now oi (cancelError <> "; reading it failed too: " <> readError) + +-- | After 72 hours the poller only reads an order when a webhook asks. If an older order still +-- can't be cancelled after an hour of trying, mark it expired here and log an error. +uncancelled :: PollerEnv -> UTCTime -> OverdueInvoice -> Text -> IO Bool +uncancelled env@PollerEnv {peCancelFailed} now OverdueInvoice {oiProvider, oiProviderRef = ref, oiCreatedAt} e + | diffUTCTime now oiCreatedAt <= settleWindow = keepOpen "it stays open until a cancel succeeds or it settles" + | otherwise = do + firstFailed <- atomically $ stateTVar peCancelFailed $ \failed -> (M.lookup ref failed, M.insertWith (\_ first -> first) ref now failed) + case firstFailed of + Just at | diffUTCTime now at >= cancelGiveUpDelay -> do + logError ("badge poller: overdue " <> tshow oiProvider <> " invoice " <> ref <> " could not be cancelled at the provider, so it was expired here only; check it in the provider's dashboard: " <> e) + pure True + _ -> keepOpen "it is expired here if the cancel still fails an hour after its first failure" + where + keepOpen outcome = do + due <- dueToWarn env now ("cancel failed: " <> tshow oiProvider <> " invoice " <> ref) + when due $ logWarn ("badge poller: cancelling overdue " <> tshow oiProvider <> " invoice " <> ref <> " failed; " <> outcome <> ": " <> e) + pure False + +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 queued} due = do + next <- atomically ((Nothing <$ due) `orElse` (Just <$> takeHint)) + case next of + Nothing -> pure () + Just ref -> serveHint env ref >> serveHints env due + where + takeHint = do + ref <- readTBQueue q + modifyTVar' queued (S.delete ref) + pure ref + +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..8faabd2a2c --- /dev/null +++ b/apps/simplex-badge-service/src/BadgeService/Providers.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} + +module BadgeService.Providers + ( ProviderError (..), + WebhookError (..), + Received (..), + PaymentSignal (..), + ProviderInvoice (..), + Funded (..), + OrderDraft (..), + ListPass (..), + settleWindow, + expiresItself, + 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) + +-- | WebhookStale is a valid signature with a timestamp too far from our clock. +data WebhookError = WebhookError Text | WebhookStale 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) + +-- | BTCPay invoices expire by themselves. Stripe payments stay open until we cancel them. +expiresItself :: PaymentProvider -> Bool +expiresItself = \case + PPCrypto -> True + _ -> False + +-- 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 from accepting payment for this order. + pCancelInvoice :: Text -> IO (Either ProviderError ()), + pListOpen :: IO (Either ProviderError ListPass), + pVerifyWebhook :: UTCTime -> [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..2df54789a3 --- /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 = const (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..93f55f37b2 --- /dev/null +++ b/apps/simplex-badge-service/src/BadgeService/Providers/Stripe.hs @@ -0,0 +1,355 @@ +{-# 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 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 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 (NominalDiffTime, UTCTime, addUTCTime, diffUTCTime, 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 + +-- | Stripe signs each retry again with the current time, so an old timestamp means a replayed request. +webhookTolerance :: NominalDiffTime +webhookTolerance = 15 * 60 + +-- Constant-time over the raw bytes. Stripe signs "{t}.{body}", so hash the timestamp, a dot, then the body as it arrived. +verifyStripeSig :: Text -> UTCTime -> [Header] -> ByteString -> Either WebhookError (Maybe Text) +verifyStripeSig secret now 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 + unless (any (constEq expected) givens) $ Left (WebhookError "Stripe-Signature does not verify") + signedAt <- note "Stripe-Signature t is not a whole number of seconds" (fullInt t) + if abs (diffUTCTime now (posixSecondsToUTCTime (fromIntegral signedAt))) <= webhookTolerance + then Right actedOn + else Left (WebhookStale ("Stripe-Signature t is more than " <> tshow (round webhookTolerance `div` 60 :: Int) <> " minutes from now; check the server clock")) + where + fullInt s = case B8.readInt s of + Just (n, rest) | B8.null rest -> Just n + _ -> Nothing + 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..9a3a3f4236 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 (BadgeIssuerKey (..), 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,88 @@ 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" +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 k -> checkOne cfg k -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 +188,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 +197,51 @@ 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 Revoked -> pure $ Right CRCustomChatResponse {user_ = Nothing, response = "revoked"} + Right AlreadyRevoked -> pure $ chatCmdError "code was revoked already" + Right AlreadyRedeemed -> pure $ chatCmdError "code was redeemed already, so it cannot be revoked" + Right NoSuchCode -> pure $ chatCmdError "no such code" + 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 RevokeResult) +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 +274,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 +325,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 +333,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 +347,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 +356,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,51 +375,58 @@ 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 + -- If the code was revoked or redeemed while signing, the claim fails. Read the code again to tell the client why. r <- withDB "writeCodeRedemption" cc $ \db -> - readCode code db >>= \case - Left resp -> pure resp - Right _ -> liftIO $ do - purchaseId <- createCodePurchase db NewCodePurchase {badgeCodeId, purchaseKey, masterKey, badgeType} now + liftIO (createCodePurchase db NewCodePurchase {badgeCodeId, purchaseKey, masterKey, badgeType} now) >>= \case + Nothing -> + readCode now code db >>= \case + Left resp -> pure resp + Right _ -> logError "badge service: redeeming a code failed, but the code is neither redeemed nor revoked" $> errorResponse BSEInternal + Just purchaseId -> liftIO $ do appendLedgerPlan db purchaseId [granted] $ Just $ issuanceAfter granted signed entries_ <- getLedgerEntries db purchaseId 0 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 $ + 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 +454,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..d8ab44c268 100644 --- a/apps/simplex-badge-service/src/BadgeService/Store.hs +++ b/apps/simplex-badge-service/src/BadgeService/Store.hs @@ -21,9 +21,12 @@ module BadgeService.Store appendLedgerPlan, createCodePurchase, insertBadgeCode, + RevokeResult (..), + 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 +55,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 +72,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 +91,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 +102,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 +116,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 +146,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 +154,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 +174,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 +190,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 +205,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,21 +222,48 @@ 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 -createCodePurchase :: DB.Connection -> NewCodePurchase -> UTCTime -> IO Int64 +-- redeemed_at is stamped here, so this must run in the same transaction as the credential rows. +-- Mark the code as redeemed before adding the purchase. On Postgres, a revoke or redemption running +-- at the same time then waits, sees the code is taken, and fails. +createCodePurchase :: DB.Connection -> NewCodePurchase -> UTCTime -> IO (Maybe Int64) createCodePurchase db NewCodePurchase {badgeCodeId, purchaseKey, masterKey = BadgeMasterKey mk, badgeType} now = do - DB.execute - db - [sql| - INSERT INTO sx_badge_service_badge_purchases - (purchase_key, master_key, initial_badge_type, current_badge_type, status, badge_code_id, created_at, updated_at) - VALUES (?,?,?,?,?,?,?,?) - |] - (purchaseKey, Binary mk, badgeType, badgeType, PSIssued, badgeCodeId, now, now) - purchaseId <- insertedRowId db - DB.execute db "UPDATE sx_badge_service_badge_codes SET redeemed_at = ? WHERE badge_code_id = ?" (now, badgeCodeId) - pure purchaseId + claimed <- + executeChanging + db + "UPDATE sx_badge_service_badge_codes SET redeemed_at = ? WHERE badge_code_id = ? AND redeemed_at IS NULL AND revoked_at IS NULL" + (now, badgeCodeId) + if claimed == 0 + then pure Nothing + else do + DB.execute + db + [sql| + INSERT INTO sx_badge_service_badge_purchases + (purchase_key, master_key, initial_badge_type, current_badge_type, status, badge_code_id, created_at, updated_at) + VALUES (?,?,?,?,?,?,?,?) + |] + (purchaseKey, Binary mk, badgeType, badgeType, PSIssued, badgeCodeId, now, now) + Just <$> insertedRowId db + +data RevokeResult = Revoked | AlreadyRevoked | AlreadyRedeemed | NoSuchCode + deriving (Eq, Show) + +-- | A code that was already redeemed can't be revoked, because its badge was already given out. +revokeCode :: DB.Connection -> ByteString -> UTCTime -> IO RevokeResult +revokeCode db codeHash now = do + revoked <- + executeChanging + db + "UPDATE sx_badge_service_badge_codes SET revoked_at = ? WHERE code_hash = ? AND revoked_at IS NULL AND redeemed_at IS NULL" + (now, Binary codeHash) + if revoked > 0 + then pure Revoked + else + maybeFirstRow' NoSuchCode refusal $ + DB.query db "SELECT revoked_at FROM sx_badge_service_badge_codes WHERE code_hash = ?" (Only (Binary codeHash)) + where + refusal :: Only (Maybe UTCTime) -> RevokeResult + refusal (Only revokedAt) = maybe AlreadyRedeemed (const AlreadyRevoked) revokedAt insertBadgeCode :: DB.Connection -> ByteString -> BadgeType -> Int -> BadgeCodePaymentStatus -> UTCTime -> IO () insertBadgeCode db codeHash badgeType months paymentStatus now = 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..a3e177400e --- /dev/null +++ b/apps/simplex-badge-service/src/BadgeService/Store/Invoices.hs @@ -0,0 +1,613 @@ +{-# 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, + OverdueInvoice (..), + overdueInvoices, + 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 (filterM) +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)) " + +qOverdueInvoices :: Query +qOverdueInvoices = + mkQuery $ + "SELECT @invoices.invoice_id, @invoices.provider, ci.provider_ref, @invoices.created_at FROM @invoices " + <> "JOIN @badge_code_invoices ci ON ci.invoice_id = @invoices.invoice_id " + <> "WHERE status = 'open' AND expires_at < ? " + <> unfundedOnly + <> "ORDER BY @invoices.created_at" + +qExpireOverdue :: Query +qExpireOverdue = + mkQuery $ + "UPDATE @invoices SET status = 'expired', updated_at = ? " + <> "WHERE status = 'open' AND expires_at < ? AND invoice_id = ? " + <> 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]) + +data OverdueInvoice = OverdueInvoice + { oiInvoiceId :: InvoiceId, + oiProvider :: PaymentProvider, + oiProviderRef :: Text, + oiCreatedAt :: UTCTime + } + deriving (Eq, Show) + +overdueInvoices :: DBStore -> UTCTime -> IO [OverdueInvoice] +overdueInvoices st cutoff = withConnection st $ \db -> do + rows <- DB.query db qOverdueInvoices (Only (truncateToSecond cutoff)) + either (E.throwIO . StoreDecodeError) pure (traverse toOverdue rows) + where + toOverdue (i, providerTxt, oiProviderRef, oiCreatedAt) = case textToProvider providerTxt of + Just oiProvider -> Right OverdueInvoice {oiInvoiceId = InvoiceId i, oiProvider, oiProviderRef, oiCreatedAt} + Nothing -> Left ("invoices.provider: " <> providerTxt) + +-- | Of the given invoices, expire those that are still open, have received no money, and are past their deadline. +expireOverdue :: DBStore -> UTCTime -> [InvoiceId] -> IO [InvoiceId] +expireOverdue st cutoff' invIds = withTransaction st $ \db -> do + let cutoff = truncateToSecond cutoff' + filterM (\(InvoiceId i) -> (> 0) <$> executeChanging db qExpireOverdue (cutoff, cutoff, i)) invIds + +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..0c742bccf1 --- /dev/null +++ b/apps/simplex-badge-service/src/BadgeService/Web/Server.hs @@ -0,0 +1,741 @@ +{-# 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 -> do + now <- getCurrentTime + -- a provider signs the exact bytes it sent, so parsing and re-encoding here would fail the signature on every event + case pVerifyWebhook p now (requestHeaders req) (LB.toStrict body) of + Left (WebhookError e) -> refuse e + Left (WebhookStale e) -> logWarn (route <> " refused: " <> e) >> respond webhookRefused + 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..0004b44944 --- /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 private_key, +# with its index in index. 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/BadgeService/WebTests.hs`: + +``` +cabal test --test-options='-m "/SimpleX badge service/"' +``` + +## 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..41f8003c2b --- /dev/null +++ b/apps/simplex-badge-service/web/build.js @@ -0,0 +1,160 @@ +#!/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`, + fonts: `${root}public/fonts`, + 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"]; +const FONT_TYPES = [".woff2"]; + +/** Images and fonts sit flat beside styles.css so that a url(hero-light.png) or url(Manrope-Regular.woff2) 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, fonts = paths.fonts) { + 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(); + const faces = readdirSync(fonts).filter((f) => FONT_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}`)]), + ...faces.map((name) => [name, readFileSync(`${fonts}/${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/fonts/GT-Walsheim-LC-Bold.woff2 b/apps/simplex-badge-service/web/public/fonts/GT-Walsheim-LC-Bold.woff2 new file mode 100644 index 0000000000..da6193cb44 Binary files /dev/null and b/apps/simplex-badge-service/web/public/fonts/GT-Walsheim-LC-Bold.woff2 differ diff --git a/apps/simplex-badge-service/web/public/fonts/Manrope-Bold.woff2 b/apps/simplex-badge-service/web/public/fonts/Manrope-Bold.woff2 new file mode 100644 index 0000000000..969c36f982 Binary files /dev/null and b/apps/simplex-badge-service/web/public/fonts/Manrope-Bold.woff2 differ diff --git a/apps/simplex-badge-service/web/public/fonts/Manrope-Medium.woff2 b/apps/simplex-badge-service/web/public/fonts/Manrope-Medium.woff2 new file mode 100644 index 0000000000..8c9a66a07c Binary files /dev/null and b/apps/simplex-badge-service/web/public/fonts/Manrope-Medium.woff2 differ diff --git a/apps/simplex-badge-service/web/public/fonts/Manrope-Regular.woff2 b/apps/simplex-badge-service/web/public/fonts/Manrope-Regular.woff2 new file mode 100644 index 0000000000..d91a1b707b Binary files /dev/null and b/apps/simplex-badge-service/web/public/fonts/Manrope-Regular.woff2 differ diff --git a/apps/simplex-badge-service/web/public/fonts/Manrope-SemiBold.woff2 b/apps/simplex-badge-service/web/public/fonts/Manrope-SemiBold.woff2 new file mode 100644 index 0000000000..03a79b412b Binary files /dev/null and b/apps/simplex-badge-service/web/public/fonts/Manrope-SemiBold.woff2 differ 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..dcf5e7d4b2 --- /dev/null +++ b/apps/simplex-badge-service/web/public/index.html @@ -0,0 +1,49 @@ + + + + + + + + + + + + + +Support SimpleX + + + + + + + + + + +
+

Support SimpleX

Get a badge to send larger files (2‑5GB) that stay available longer (7‑21 days), and to show it on your profile.

You pay once for the months you choose. No subscription, no account.

Invest $100+ in SimpleX Chat and get a free supporter badge.

Learn more on
+ + + + + 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..2fee434fcd --- /dev/null +++ b/apps/simplex-badge-service/web/public/styles.css @@ -0,0 +1,1252 @@ +/* The colours are the website's, as its blog pages use them (website/tailwind.config.js, + website/src/css/blog.css and website/src/_includes/layouts/article.html): the page's ground, + the article's card, the heading gradient, and the link and button colours, in both themes. + Every other value below is the published SimpleX design's own; 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; + /* primary-light and its hover step; white on it, as on the site's buttons. Pressed is the + accent one small step darker rather than the site's lighter, greyer #407AD2: a press should + read as the same button under the finger, not a paler one. */ + --accent: #0053D0; + --accent-hover: #1661D1; + --accent-pressed: #004ABB; + --on-accent: #FFFFFF; + --ink: #0D1B3A; /* simplex.domains' ink: the navy the page's blues are built on */ + --bg: #F3FAFF; /* secondary-bg-light: the blog page's ground */ + --surface: #FFFFFF; /* the article's card */ + --menu: #FFFFFF; + --line: rgba(0, 83, 208, .14); /* simplex.domains' card line: the accent, faint, so it sits in the page's blue */ + /* one faint wash of the accent over the flat ground, and nothing else */ + --page: radial-gradient(50% 50% at 50% 50%, rgba(0, 83, 208, .06) 0%, rgba(243, 250, 255, 0) 100%); + + /* The one secondary text colour, simplex.domains' own: the ink at 65%, so it stays in the + page's hue. 5.3:1 on #F3FAFF, and set at 500 wherever it is used. */ + --ink-soft: rgba(13, 27, 58, .651); + /* The ink at 4%: the menu's hover, the landing screen's info panel, and a card the catalog + cannot price. */ + --tint: rgba(13, 27, 58, .04); + + /* the blog's heading gradient, top to bottom */ + --title: linear-gradient(to bottom, #53C1FF -50%, #0053D0 160%); + + /* 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 accent */ + --code-bg: rgba(0, 83, 208, .06); + --code-line: rgba(0, 83, 208, .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(13, 27, 58, .07); + --on-disabled: rgba(13, 27, 58, .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 + shadows on the page are the menu's and the primary button'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); + /* the primary button: a touch of light across its top and a soft shadow in the accent */ + --sheen: linear-gradient(to bottom, rgba(255, 255, 255, .16), rgba(255, 255, 255, 0) 60%); + --shadow-button: 0 4px 12px rgba(0, 83, 208, .18); + --shadow-button-hover: 0 6px 16px rgba(0, 83, 208, .24); + + /* The faces simplex.domains sets: GT Walsheim for the heading, Manrope for everything else. + Both are served under the build hash (see the @font-face rules below) and precached. */ + --display: "GT Walsheim", Manrope, -apple-system, BlinkMacSystemFont, "Segoe UI", Roboto, "Helvetica Neue", sans-serif; + --font: Manrope, -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 four Manrope weights the sheet uses and the one GT Walsheim weight, relative to this file, + so they sit under the build hash with it. `swap`, so text is never invisible while a face loads. */ +@font-face { font-family: Manrope; src: url(Manrope-Regular.woff2) format("woff2"); font-weight: 400; font-style: normal; font-display: swap; } +@font-face { font-family: Manrope; src: url(Manrope-Medium.woff2) format("woff2"); font-weight: 500; font-style: normal; font-display: swap; } +@font-face { font-family: Manrope; src: url(Manrope-SemiBold.woff2) format("woff2"); font-weight: 600; font-style: normal; font-display: swap; } +@font-face { font-family: Manrope; src: url(Manrope-Bold.woff2) format("woff2"); font-weight: 700; font-style: normal; font-display: swap; } +@font-face { font-family: "GT Walsheim"; src: url(GT-Walsheim-LC-Bold.woff2) format("woff2"); font-weight: 700; font-style: normal; font-display: swap; } + +/* 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; + /* primary-dark, with its hover and pressed steps, and the page's ground on it, as on the + site's dark buttons */ + --accent: #70F0F9; + --accent-hover: #66D9E2; + --accent-pressed: #5CD3DC; + --on-accent: #000832; + --ink: #EAF2FF; /* simplex.domains' dark ink */ + --bg: #000832; /* primary-bg-dark: the blog page's ground */ + --surface: #0B2A59; /* secondary-bg-dark: the blog list's card, a clear step off the ground */ + --menu: #0B2A59; + --line: rgba(112, 240, 249, .18); /* simplex.domains' dark card line: the accent, faint */ + --page: radial-gradient(50% 50% at 50% 50%, rgba(112, 240, 249, .05) 0%, rgba(0, 8, 50, 0) 100%); + + --ink-soft: rgba(234, 242, 255, .735); + --tint: rgba(255, 255, 255, .06); + + --title: linear-gradient(to bottom, #70F0F9 0%, #70F0F9 33%, #50D8F1 100%); + + /* The light theme's three hues, lightened to sit on #000832, 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(112, 240, 249, .12); + --code-line: rgba(112, 240, 249, .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); + /* White barely shows on the light cyan, so the dark sheen also deepens the pill's foot. */ + --sheen: linear-gradient(to bottom, rgba(255, 255, 255, .30), rgba(255, 255, 255, 0) 50%, rgba(0, 8, 50, .16) 100%); + --shadow-button: 0 6px 16px rgba(112, 240, 249, .16); + --shadow-button-hover: 0 8px 20px rgba(112, 240, 249, .22); + } +} + +/* The same palette again, for the menu's explicit Dark. */ +:root[data-theme="dark"] { + color-scheme: dark; + /* primary-dark, with its hover and pressed steps, and the page's ground on it, as on the + site's dark buttons */ + --accent: #70F0F9; + --accent-hover: #66D9E2; + --accent-pressed: #5CD3DC; + --on-accent: #000832; + --ink: #EAF2FF; /* simplex.domains' dark ink */ + --bg: #000832; /* primary-bg-dark: the blog page's ground */ + --surface: #0B2A59; /* secondary-bg-dark: the blog list's card, a clear step off the ground */ + --menu: #0B2A59; + --line: rgba(112, 240, 249, .18); /* simplex.domains' dark card line: the accent, faint */ + --page: radial-gradient(50% 50% at 50% 50%, rgba(112, 240, 249, .05) 0%, rgba(0, 8, 50, 0) 100%); + + --ink-soft: rgba(234, 242, 255, .735); + --tint: rgba(255, 255, 255, .06); + + --title: linear-gradient(to bottom, #70F0F9 0%, #70F0F9 33%, #50D8F1 100%); + + /* The light theme's three hues, lightened to sit on #000832, 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(112, 240, 249, .12); + --code-line: rgba(112, 240, 249, .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); + /* White barely shows on the light cyan, so the dark sheen also deepens the pill's foot. */ + --sheen: linear-gradient(to bottom, rgba(255, 255, 255, .30), rgba(255, 255, 255, 0) 50%, rgba(0, 8, 50, .16) 100%); + --shadow-button: 0 6px 16px rgba(112, 240, 249, .16); + --shadow-button-hover: 0 8px 20px rgba(112, 240, 249, .22); +} + +* { 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; } + +/* The page is one column of the viewport's height: the header, then the screen, which is at least + the rest of the viewport tall (see `.panel`), then the footer below the fold, where a scroll + reaches it. `100vh` is the fallback for a browser without dynamic viewport units. */ +body { + margin: 0; + display: flex; + flex-direction: column; + /* The gutter is here, so `#app` is exactly the 640px content column and + nothing inside it has to subtract padding to reach that width. */ + padding: 0 20px; + min-height: 100vh; + min-height: 100dvh; + 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 { width: 100%; max-width: 640px; margin: 0 auto; overflow-x: hidden; flex: 1 0 auto; } +/* The header's height, which every screen's minimum height is the viewport less: `.chrome-bar`'s + 56px box, its paddings inside it. */ +:root { --chrome-h: 56px; } + +/* 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; display: block; } +.embedded .panel { 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 640 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(--ink-soft); + font: inherit; + font-size: .875rem; + 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 { + flex: none; + width: 100%; + max-width: 640px; + margin: 0 auto; + text-align: center; +} +footer a { + display: block; + border-top: 1px solid var(--line); + padding: 22px 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 { + position: relative; + flex: 0 0 100%; + min-width: 0; + padding: 12px 0 22px; + text-align: center; + /* A screen is a column at least as tall as the viewport under the header, so that its button + stands at the same place on every screen - near the bottom, where a thumb reaches it - and the + content between the heading and the button is spread over the height rather than stacked at + the top. A screen taller than the viewport grows and scrolls, as the payment screens do. */ + display: flex; + flex-direction: column; + min-height: calc(100vh - var(--chrome-h)); + min-height: calc(100dvh - var(--chrome-h)); +} +/* On a wide screen the button needs no thumb, so it stands higher off the foot of the viewport and + the page reads as balanced rather than bottom-heavy. Up to a 1080px-tall viewport the space under + it grows with the height; beyond that the content stops descending - its foot stays 927px under + the header, where a 1080px viewport puts it - and the whole surplus goes under it. */ +@media (min-width: 700px) { + .panel { + padding-bottom: max(clamp(40px, 9vh, 110px), calc(100vh - var(--chrome-h) - 927px)); + padding-bottom: max(clamp(40px, 9vh, 110px), calc(100dvh - var(--chrome-h) - 927px)); + } +} +/* What each screen spreads: the hero, the choice cards, the summary. `auto` above and nothing + below, so the free height is shared between the space over the block and the space under it, + which the button's own `auto` margin takes. */ +.panel > .hero, .panel > .choices, .panel > .rows { margin-top: auto; } +/* The button is the last thing before the invest block, and sinks to the foot of the screen. Where + a screen keeps notes above its button, the notes sink with it and the button follows them. */ +.panel > .primary { margin-top: auto; } +.panel > .notes { margin-top: auto; } +.notes + .primary { margin-top: 20px; } +.notes .muted { margin: 4px auto 0; max-width: 480px; } +/* The checkout's note slot holds one line's height whether or not the line is shown, so choosing a + method moves nothing above or below it. */ +.notes.slot { min-height: calc(4px + .875rem * 1.5); } +.notes .half { display: inline-block; } +@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-family: var(--display); + font-size: 2.25rem; + line-height: 3rem; + font-weight: 700; + letter-spacing: -.02em; + 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; + font-weight: 500; + color: var(--ink-soft); + 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; } +.lede .line { display: block; } +.lede .half { display: inline-block; } + +.muted { color: var(--ink-soft); font-size: .875rem; font-weight: 500; 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 out of the flow, so the heading is the first thing in every panel and stands at one + height whether or not there is a Back. On a desktop `top` centres it on the heading's first + line, at the left of the column, as a navigation bar draws it. On a phone the heading is nearly + as wide as the column, so Back is above it and the heading's margin holds that line open on + every screen. The chevron hangs a little into the gutter so the word aligns with the column's edge. */ +.back { + position: absolute; + left: -5px; + top: 36px; + display: flex; + align-items: center; + gap: 1px; + color: var(--accent); + background: none; + border: 0; + font: inherit; + font-size: 1rem; + font-weight: 500; + text-align: left; + cursor: pointer; + padding: 0; +} +.back .chevron { width: 22px; height: 22px; display: block; } + +/* -------------------------------------------------------------------- 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); + background-image: var(--sheen); + box-shadow: var(--shadow-button); + 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, box-shadow 120ms linear; +} +.primary:not([disabled]):not(.copied):hover { background-color: var(--accent-hover); box-shadow: var(--shadow-button-hover); } +.primary:not([disabled]):not(.copied):active { background-color: var(--accent-pressed); box-shadow: none; } +/* 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); + box-shadow: none; + 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; + box-shadow: 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; box-shadow: 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(--ink-soft); 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