mirror of
https://github.com/simplex-chat/simplex-chat.git
synced 2026-11-04 08:37:30 +00:00
spaced4ndyandspacedandy-agents-simplex
9696a71b91
* core, badge-service: name Apple claims by reference
Rename appleTransactionId to appleTransactionRef, matching googlePurchaseRef
and StoreTransactionRef. No behaviour change: the next change makes it
return a subscription's original transaction id, which the old name would
misstate.
Run: 001-badge-subscriptions, slice 1
* core, badge-service: store subscription charges and carry the subscription state
Add the service migration 20261012_badge_subscriptions: the subscription
charges table, the ledger's charge_id, and the payment's subscription state,
check time and Play token, replacing three subscription columns nothing
wrote. The ledger now stores and reads back charge credits, and the badge
credential response gains an optional subscription state that older clients
ignore and that reads an unknown state without failing. Nothing writes a
charge or a state yet, so no behaviour changes.
Run: 001-badge-subscriptions, slice 2
* core, badge-service: plan subscription charges and claim Apple subscriptions by original id
Add chargeEntries, the one planner for a store charge's ledger rows: a
lapse to the billing period start, the grant dated to that start, and a
lapse to now, so coverage follows the store's periods and every row
verifies by re-running it at its createdAt. A test runs its rows through
the client's own balanceChecked for first charges, monthly and annual
renewals, billing-retry recovery and grace.
An Apple auto-renewable transaction is now claimed by its original
transaction id, which every renewal keeps, so renewals resolve to one
purchase. One function names the ref for both the claim and the real
verifier, so they cannot disagree.
Run: 001-badge-subscriptions, slice 3a
* badge-service: credit a store subscription purchase
The catalog now tells subscription products from one-time ones and maps a
store plan to its tier and months. A subscription receipt is checked with
the store once: with a grantable charge, the service plans the charge's
rows from the store's period start, signs the first month, and writes the
payment, purchase, charge, ledger rows, issuance, state and Play token in
one transaction, answering with the subscription state. Without one, it
answers payment_pending (300 s while the period has not started or the
store is pending, a day otherwise), receipt_invalid for an ended Play
subscription, or test_purchase, and writes nothing. Replays carry the
state. The store verifier interface gains the subscription check, which no
real store implements yet; the fake store does.
Run: 001-badge-subscriptions, slice 3b
* badge-service: renew a subscription once its paid coverage ends
While a subscription purchase's coverage runs, issueBadge is unchanged
and makes no store call. Once it has ended, the service asks the store at
most once an hour per subscription, stamping every attempt, and answers
from the stored state in between; a failed check is retried after the
whole interval. A grantable charge is planned from the tip at the store's
period start, signed, and written with its issuance and state in one
transaction that re-reads the tip, answering internal if it moved. Any
other charge and the state are recorded without a ledger row. Every answer
for a subscription purchase carries its state.
Run: 001-badge-subscriptions, slice 4
* core: keep a subscription badge until the service says it ended
A purchase is a subscription exactly when its ledger replica holds a
charge credit, so the kind is derived with no column or migration. A
subscription is still asked about at zero months, at the shared weekly
moment, and keeps its badge past paidThrough until an answer says the
subscription ended, so a renewed month is presented at the old
credential's expiry with no gap, and a charge the store recovers later
still re-activates it. While it waits, the client records no failure and
raises no support-ended alert; "issued no credential" now fires only while
the ledger still owes a month. Prepaid purchases are unchanged.
Run: 001-badge-subscriptions, slice 5
* badge-service: check Apple subscriptions with the App Store Server API
With an in-app purchase key configured in [apple], the service reads a
subscription's status by its original transaction id from Get All
Subscription Statuses, authenticated by an ES256 token reused until near
expiry. Each signed transaction and renewal info is verified against the
pinned Apple root through the same chain check as one-time purchases, now a
separate function, and a body that fails it is a verifier failure, never a
refusal. Statuses map to renewing, cancelled, billing retry and ended;
family-shared transactions are refused; 401 and 403 are this service's
failure, other errors and timeouts unreachable. A verifier failure thrown
by a store check is answered internal, and a test subscription is refused
in one place for first purchases and renewals. Without the key, Apple
one-time purchases verify as before and subscriptions are not configured.
Run: 001-badge-subscriptions, slice 6
* badge-service: check and acknowledge Google Play subscriptions
The Play subscription check reads purchases.subscriptionsv2 by token
through the existing service-account client, with the same HTTP classes as
product reads, and maps Play's state, base plan, period, order id and
offer phase; the period start is its end minus the plan's length, and a
pending subscription stays pending. A subscription is acknowledged with
purchases.subscriptions.acknowledge before it is credited, skipped when
Play reports it acknowledged, so it never reaches the one-time endpoint.
Each store's subscriptions answer provider_not_configured when that store
is not configured. A charge on a plan the catalog does not sell is pending
rather than a malformed period.
Run: 001-badge-subscriptions, slice 7
* review: round 1 fixes
R1-1: test an App Store subscription renewal through issueBadge, including
a charge recorded before its period starts and granted later under the
same charge id.
R1-2: make the ledger's charge_id index unique, so the schema itself grants
each store charge at most once.
R1-3: pin that a charge on a plan the catalog does not sell, with an empty
period, is pending at purchase and recorded at renewal, never internal.
Run: 001-badge-subscriptions, review round 1
* core: update query plans
getBadgePurchase derives the purchase kind from the ledger replica, and a
subscription test makes a held store receipt due.
Run: 001-badge-subscriptions, final verification
* fixes
* core: move SubscriptionState to Badges.Types (structural)
BadgeState, which lives in Badges.Types, is about to carry a subscription's
state, and Badges.Service imports Badges.Types. Service re-exports it, as it
does BadgeServiceErrorCode. No behaviour change.
Run: 003-badge-subscriptions-ui, slice 1
* core: keep a store subscription's state on the client
The screens and alerts need to know whether a subscription renews, was
cancelled, waits for a charge, or ended, and the client dropped every state
the service sent but ended. It is now stored on the purchase: from the
answer to the first credit, and from a renewal answer only when the
asserted tip's coverage had ended, since while coverage runs the service
repeats what it read at the last renewal (a year old for an annual plan).
BadgeState gains `subscription` (the plan's months, from the latest charge
credit, and the state), and fills renewsAt/willRenew from it. A changed
state is announced with CEvtBadgeChanged. The column goes into the
unreleased M20260925 migration.
Run: 003-badge-subscriptions-ui, slice 2
* core: record the device store's view of a subscription
The service reads the store only once a subscription's paid coverage has
ended, so it never sees a cancellation while the period runs. The apps read
the device's store (StoreKit's renewal state, Play's isAutoRenewing) and
report it with /_badge subscription <state> <payment>, which records it on
the credited subscription purchase the payment resolves to and announces the
change to its owner.
A renewing report does not replace billingRetry or ended: Play lists a
subscription in its grace period with auto-renew on, and the service's next
answer clears billing retry once the charge lands.
Run: 003-badge-subscriptions-ui, slice 3
* core: claim a store-listed transaction only on the device that bought it
A store account's purchases are listed on every device signed into it:
Play's purchase query lists active subscriptions for their whole life, and
Apple's Transaction.updates delivers auto-renewables made on other devices.
A hand-over with no record and an unknown echoed invoice made a new record
under the presenting profile, so another device could claim a buyer's
subscription for its own active profile, or repeat a refused request every
30 days after cleanup.
/_badge purchase now takes a `listed` mark, which the apps' sweeps and
purchase listeners send: it joins only a record this core already has for
the transaction or its echoed invoice, and otherwise records and sends
nothing (CRStoreReceiptNotRecorded). The purchase call and Restore hand over
unmarked, as before.
Run: 003-badge-subscriptions-ui, slice 4
* core: let a held App Store subscription adopt its later transactions
A held Apple subscription record is keyed by its original transaction id,
so every renewal resolves to it. It kept the payment's back-off when a new
transaction arrived, and adopted any payment handed over, including a
revoked renewal, which the service refuses as receipt_invalid and so would
refuse the whole subscription.
A held Apple record now adopts a JWS only for another transaction with a
later purchaseDate and no revocationDate, read from the unverified payload,
and is then due at once with its retry delay and credit error cleared. A
re-delivered or re-signed copy changes nothing. A failed attempt writes its
back-off only if the record still holds the payment it sent.
Run: 003-badge-subscriptions-ui, slice 5
* core: refuse a badge code or invoice while a store receipt is pending
A code redeemed while a store receipt is held put the code's badge on the
profile, and the held receipt then waited behind it; for a subscription the
store kept charging every period meanwhile. Code redemption and invoice
creation now answer "store purchase open" while the profile holds an App
Store subscription receipt, or another receipt whose last failure can clear
on its own. A receipt that failed for good does not block, except an Apple
subscription, which Apple keeps charging; an uncredited Play subscription is
refunded by Play.
Run: 003-badge-subscriptions-ui, slice 6
* core: alert a subscriber that a payment failed, a renewal nears, or it was cancelled or ended
A subscription's alerts were the prepaid ones: a retired subscription said
"support ended", and nothing told the user a payment failed, an annual
renewal was near, or a cancelled subscription still runs. The derived alert
for a subscription is now, in order: subscription_ended once retired,
payment_issue while the store retries, issue_failed as before,
subscription_cancelled before paidThrough, and renewal_approaching from
three days before an annual plan renews, with a wake at that moment. Monthly
plans get no reminder, as there is no opt-out yet.
The unreleased migration's down step clears an acked subscription_cancelled,
which an older core cannot read.
Run: 003-badge-subscriptions-ui, slice 7
* badge-service: let the dev mock vouch for store subscriptions
With [dev] accept_unverified_store_receipts on, every subscription was
answered provider_not_configured, so the apps' subscription screens could
not be tried against a dev service. The mock now credits an App Store
subscription for the plan its product names, and a Play subscription for
the base plan a test token test.<basePlanId>.<uuid> names, or else its
product's monthly plan, from a minute ago; it remembers the plan in memory
and grants each renewal a new charge, answering a subscription it does not
know (after a restart) as ended.
The subscription check is given the product the presented receipt names,
which only the mock reads; it reads the service's badge clock at check time.
Run: 003-badge-subscriptions-ui, slice 8
* ios: hand App Store subscriptions to the core and report their renewal state
A subscription transaction was finished uncredited, so a buyer would pay and
get nothing. Every badge product now goes through a core invoice and is
handed over, and finished only once the core answers it credited or refused.
Transactions the store lists (the launch sweep, Transaction.updates) are
handed over as listed, so another device's purchase is not claimed here;
Restore purchases syncs with the App Store and claims them for this profile.
A revoked renewal is finished without hand-over, as the service would refuse
it and so the whole subscription.
The app reports StoreKit's renewal state to the core at each sweep, after the
manage-subscriptions sheet and after a restore. Monthly and annual are offered
only to an Apple ID with no earlier subscription in the group, which Apple
would fold a new one into.
Run: 003-badge-subscriptions-ui, slice 9
* ios: sell badge subscriptions and show their state on Your badge
Monthly and annual subscriptions are offered on How long and Check your
order, with the App Store's subscription disclosure, Terms of use and
Privacy policy links, and Restore purchases. Your badge shows a
subscription's state - Renews {date} · {price}, Ends {date}, Payment
problem, Renewing or Ended - with why another badge cannot be bought or
redeemed while it waits for its charge, Manage subscription and Restore
purchases. The chat list shows one banner for the current badge alert of
any kind: renewal soon, payment problem, cancelled, ended, as well as the
expired and renewal-failed ones it had.
Run: 003-badge-subscriptions-ui, slice 10
* android: hand Play subscriptions to the core and report their renewal state
The Kotlin port of the iOS store change. A Play subscription was
acknowledged uncredited; every badge product now goes through a core
invoice and is handed over. The sweep queries subscriptions as well as
one-time products, and the sweep and purchases listener hand over as listed,
so another device on the Google account does not claim them; Restore claims
them for this profile. A subscription is bought on its base plan's own
offer, and the app never acknowledges one itself: the service does when it
credits it, so Play still refunds one the service never credits.
The app reports Play's isAutoRenewing to the core as renewing or cancelled.
Run: 003-badge-subscriptions-ui, slice 11
* android, desktop: sell badge subscriptions and show their state on Your badge
The Kotlin port of the iOS screens. How long and Check your order offer
monthly and annual with Google Play's subscription disclosure, the privacy
policy link and Restore purchases. Your badge shows the subscription's state
with the same texts as iOS, the store named Google Play with a store lane and
"the store" without one, and Manage subscription and Restore purchases only
with a store lane on the local host. The chat list shows one banner for the
current badge alert of any kind. Desktop shows the state, footers and banners
without store rows or a price.
Run: 003-badge-subscriptions-ui, slice 12
* docs: describe the one badge alert banner in the apps' chat-list specs
Both chat-list specs described two hand-written badge banners (expired,
renewal failed); the chat list now has one banner for the current badge
alert of any kind. Also moves the line links this run shifted.
Run: 003-badge-subscriptions-ui, slice 13
* review: round 1 fixes
ios: stop selling a subscription once this device has seen one, so a
second profile is not charged for a subscription Apple folds into the
first (R1-12). Continue pins the chosen period on both apps (R1-13).
Only a device with a subscription asks its store for products and status
when reporting, and the purchases are marked checked before the report
(R1-14, R1-5: Kotlin now loads the products, so the price shows after a
restart). Restore says "Nothing to restore" after a cancelled purchase
(R1-7). Android keeps sweeping one-time purchases when the subscriptions
query fails (R1-6). The freshness comment in requestBadgeIssue states the
service's one-hour repeat of its last check (R1-1).
Run: 003-badge-subscriptions-ui, review round 1
* badge-service: answer a long-expired Play subscription as ended, and hash Play order ids
Play answers HTTP 410 for a subscription that expired too long ago to be
queried; it was read as unreachable, so the service never answered ended,
the badge was never retired and the profile stayed blocked from buying or
redeeming (R1-2). Play order ids appear on the buyer's receipt email, so
charges now store a hash of the order id, as purchase tokens already are
(R1-10).
Run: 004-badge-subscriptions-review, review round 1
* review: run 003 round 2 and run 004 round 1 app fixes
ios: buy a subscription only while it is still for sale, after re-reading
the Apple ID's transactions, and disable Pay once it is not, so a Check
your order screen opened before another profile or device subscribed
cannot buy one Apple folds into the earlier subscription (run 003 R2-1,
run 004 R1-4). android: skip the subscriptions query only on a device
whose Play does not support subscriptions, so Restore no longer says
"Nothing to restore" when the query failed (run 003 R2-2).
Run: 003-badge-subscriptions-ui round 2; 004-badge-subscriptions-review round 1
* review: round 3 fixes
ios: a subscription refused because this Apple ID subscribed before has
its own error, and Check your order says why Pay is disabled (R3-2).
android: skip the subscriptions query only when Play does not support
subscriptions, so a disconnected client fails the sweep or Restore
rather than reading as no subscriptions (R3-1).
Run: 003-badge-subscriptions-ui, review round 3
* core: update query plans
Regenerated by the full suite for the purchase, subscription status and adoption queries. Run: 003-badge-subscriptions-ui, final step
* badge-service: say what hashing the Play order id protects
The hash is unkeyed, so a holder of the buyer's receipt can still find the row (R2-1). Run: 004-badge-subscriptions-review, review round 2
* badge-service: name the rule for when a subscription is due a store check
The issue path's purchase read becomes getIssuePurchase and its "ask the
store now" test becomes subscriptionCheckDue, so the request router can
read the same rows by the same rule. No behaviour change.
Run: 005-subscriptions-load-timing, slice 1
* badge-service: answer every request that may ask a store on the store lane
App Store subscription purchases and subscription renewal checks called
their store from the main lane, so one slow or repeated store call held up
code redemptions and every other renewal. The router now reads the
purchase the way the issue path does and sends to the store lane every
request that may ask a store: Play purchases, App Store auto-renewable
purchases, and issue requests for a subscription due its store check,
judged a minute ahead so the handler never finds one due on the main lane.
Run: 005-subscriptions-load-timing, slice 2
* core: send no badge request before the wake a request that issued nothing set
While a subscription waited for its store charge, or a prepaid renewal
kept failing, every launch, foreground, profile switch and badge-state
read sent the issue request again, so the badge service saw the user's
app-open times for weeks. A due request now waits for the wake the last
pass stored, as long as that wake is no more than a stall interval away,
so it is asked again a day later as the renewal design says.
Run: 005-subscriptions-load-timing, slice 3
* fixup! core: send no badge request before the wake a request that issued nothing set
* fixup! badge-service: answer every request that may ask a store on the store lane
* badge-service: ask the App Store about a subscription purchase at most once an hour per claim
Anyone holding a real but uncreditable App Store subscription JWS, such as
their own lapsed subscription, could present it again and again, each time
spending an App Store Server API call from the quota every subscriber's
renewal check needs. The purchase path now remembers, in memory, which
subscription claims it asked about within the hour and answers a repeat
payment_pending with the time left. Keys are original transaction ids from
JWS that verified offline, entries expire after the hour, and a full table
asks rather than refuses, so memory stays bounded and no buyer waits on
another's claim.
Run: 005-subscriptions-load-timing, slice 4
* fixup! badge-service: ask the App Store about a subscription purchase at most once an hour per claim
* review: round 1 fixes
badge-service: a Play charge whose clipped period start leaves its month
already spent is answered as period over, not internal (R1-A1).
docs: the per-store answer classes list Play's 410 and the App Store
subscription check (R1-A2).
tests: a held receipt with no attempt yet blocks an invoice (R1-B2); a
renewing report keeps an ended status (R1-B3); a test comment names
[google] (run 005 C2-R2-1).
ios: a subscription refused because this Apple ID subscribed before
shows its sentence, not the error's name (R1-C2); ios, android, desktop:
the Check your order footnotes share one helper (R1-C3).
Run: 006-subscriptions-branch-review, review round 1
* fixup! review: round 1 fixes
* core: wait a day after a badge request that issued nothing, whatever the service or a snooze says
The hold on the stored wake let two moments the client does not schedule end it early. A renewal whose store check failed was answered with an hour's retryAfter, so the next activation after each hour sent it again, sampling when the app is opened. A snooze set before a request ended its wait at the snooze's end, timing the next request by the user's tap. Now a request that issued nothing waits the stall or a ledger moment: retryAfter only marks the failure transient, and a snooze is not a wake while a request waits; the request's own wake raises the alert again.
Run: 005-subscriptions-load-timing, slice 5
* fixup! review: round 1 fixes
* fixup! core: wait a day after a badge request that issued nothing, whatever the service or a snooze says
* badge-service: ask Play about a subscription purchase at most once an hour per token
The purchase path's hourly bound covered only App Store claims, so a re-presented Play subscription token, uncredited or credited to another key, spent a subscriptionsv2.get call each time, from the quota bucket Play renewal checks use. The bound now lives in purchaseSubscription, which both stores' purchase paths call, with one map per store: Play's keyed by the token's hash, so made-up Play tokens cannot fill the App Store's. Distinct made-up tokens are still one call each.
Run: 005-subscriptions-load-timing, slice 6
* badge-service: read Play's paused subscription as waiting to renew
An unmapped SUBSCRIPTION_STATE_PAUSED was answered internal, so a paused subscriber's renewal failed for the whole pause. Play reports a pause with auto-renewal on and charges again when it ends, so it now maps as an active subscription does: renewing, or cancelled with auto-renewal off. Pause is being turned off on the base plan; this is defence in depth. A pause grants nothing: Play names no new order, and the last one is already granted.
Run: 005-subscriptions-load-timing, slice 9
* core: retire a subscription badge once no store could still charge it, whatever the service answers
A subscription badge retired only on an ended answer, so a service that never sent one (a final error such as unknown_purchase_key, a rollback, a service that never answers) left the badge shown, one request a day forever, and the profile unable to redeem, buy or have a held receipt credited. Now it also retires once paidThrough is older than the longest store recovery window: Apple retries a failed renewal for up to 60 days, the longest with Play's pause off, plus a week. paidThrough counts every month the ledger holds, so banked months are never retired by it.
Run: 005-subscriptions-load-timing, slice 8
* ios, android: no Restore purchases on Your badge, where a restored purchase could not be credited
Your badge shows only while a badge is shown, so a purchase Restore found there with no record on this device was held under a profile whose held receipts are not processed while it shows a badge: not credited, nothing said, and on Android acknowledged, ending Play's three-day refund. Restore stays on Check your order, the one screen where a restored purchase can be processed.
Run: 005-subscriptions-load-timing, slice 7
* review: round 4 fixes
R4-1: a subscription badge is asked about first and retired only after the service answers, judged on the ledger after that answer. Retiring before asking used the client's paidThrough, which moves only when the client asks, so a subscriber who had not opened the app for longer than the recovery window while the store kept charging lost the badge at the next launch and was never asked again. A request that is not answered retires nothing. Tests: testSubscriptionRetiredAfterRecoveryWindow changed, testIdleSubscriptionKeptPastWindow and testSubscriptionNotRetiredWithoutAnswer added.
R4-2: one snooze comment where two contradicted each other.
R4-3: the recovery window's comment names Play's clipped period start.
R4-4: the retirement tests use subscriptionRecoveryWindow.
* badge-service: name the lane each request waits on
The router answered "may this request ask a store" as a Bool; renewal checks are to get a lane of their own, which a Bool cannot say. requestLane now names the lane: main, purchase or renewal. Both store lanes still share one queue, so no request changes lane.
Run: 007-subscriptions-retirement-lane, slice 1
* badge-service: check renewals on a lane no purchase waits on
Renewal checks shared the store lane with every purchase, so made-up Play tokens, which anyone can send, and the weekly burst of genuine purchases delayed them. Renewal checks now wait on a lane of their own, which only a request signed by the purchase key it names, and due its hourly store check, can reach.
Run: 007-subscriptions-retirement-lane, slice 2
* badge-service: name the web limiter's fixed-window step
takeToken counted a request against a minute's limit inline. The step becomes takeFrom, a pure function, so the purchase path's Play read allowance can use the same rule. No behaviour change.
Run: 007-subscriptions-retirement-lane, slice 3a
* badge-service: read Play's subscriptions at most 300 times a minute for purchases
A Play subscription purchase is asked about without any offline check, so any token in the accepted grammar spends a read from the Subscriptions quota renewal checks share. The purchase path now takes one of a minute's 300 reads for each Play subscription it asks about, a tenth of Play's default quota; with none left, the claim is answered rate_limited with the seconds left in the minute and is not held, as Play was not asked. A claim already held takes no read, and App Store claims, verified offline first, take none.
Run: 007-subscriptions-retirement-lane, slice 3
* core: count the subscription retirement window from the first answer that renewed nothing
The window was counted from the client's paidThrough, which moves only when the client asks, so after months away the first answer that granted nothing for any reason, a transient error, Play's clipped last days or a billing retry, retired a subscriber whose store may still have been charging. The purchase now stores its unrenewed run: the first answered request after which the ledger covered nothing, and the latest one. The badge retires once the window has passed since the run started, still only after an answer; a renewal ends the run, and an answer that comes a window or more after the latest one starts a new run, since an absence or an outage that long may hide a renewal. The window stays 67 days, written as Apple's 60-day billing retry plus the week contacts give an expired credential.
Run: 007-subscriptions-retirement-lane, slice 4
* review: round 1 fixes
R1-A1: the docs and the PlayReads comment said the purchase path reads Play's subscriptions at most 300 times a minute; it asks about at most 300 subscriptions, and a credited one is read once more to acknowledge it, so made-up tokens can spend at most a tenth of the quota renewal checks share.
R1-A2: a comment on RequestLane repeated the one above the queues.
R1-B1: a test that a held pass, which sends no request, leaves the unrenewed run unchanged.
R1-B2: the outage test's last wait for the run is 30 s instead of 5 s.
Run: 007-subscriptions-retirement-lane, review round 1
* core: add the badge subscription columns in their own migration
M20261016_badge_store_receipts shipped to master in #7587, so it must
stay as released. Restore it in both dialects and move the
subscription_status, unrenewed_since and last_unrenewed_at columns,
with the down step that clears subscription_cancelled acknowledgements
master cannot read, into M20261016_badge_subscriptions.
Run: 008-subs-migration-split, slice 1
* tests: drop the FilePath import a merge duplicated
The branch and master each added import System.FilePath ((</>)) to
Direct.hs on 2026-10-14 at different positions, and an earlier merge
kept both, so GHC warned that one was redundant. Keep master's.
Run: 008-subs-migration-split, slice 2
* fixup! core: add the badge subscription columns in their own migration
* ios, android, desktop: choose a badge in the app
* ios, android, desktop: use the dev badge page for testing (don't merge)
* update postgres schema
* update ios lib
* ios, android: hide Restore purchases on the order screen
* docs: summarize the badge subscriptions PR for reviewers, with diagrams
A summary of PR #7716 as built: buying, renewing and retiring on each
store, the retirement window, lanes and store limits, RPC, API and
database changes, alerts, tests, open items, and a review map. Seven
SVG diagrams, an HTML page with them inline, and a link from the plan.
* ios, android, desktop: restore purchases on the Support SimpleX screen
* ios, android, desktop: show the badge privacy policy in the app
* docs: keep only the badge subscription diagrams, with a README
The reviewer summary leaves the repo; the folder keeps the seven
diagrams with a README that captions each, and the plan links the
README.
* ios, android, desktop: smaller Restore purchases label
* ios: no alert when a badge purchase is cancelled
* docs: replace the badge subscriptions diagrams README with a short summary
A plain-English summary for anyone on the team, with the seven
diagrams and a self-contained HTML page; the plan links it again.
Diagrams follow the branch: Restore purchases is on Support SimpleX,
"Renewing" shows past paidThrough, and only a present retryAfter is
raised to an hour.
* ui
* ui wip
* core: retire a subscription badge as soon as its store says it ended
A subscription badge retired only on an ended answer to a request that was due, and only once the ledger's paidThrough had passed, so an ended answer while the ledger still covered, or the iOS app's report of StoreKit's expired or revoked state, left the badge shown, Support SimpleX unreachable and every purchase refused until a later request. Now an answered ended state is stored even while coverage runs (the service writes it only from a store check, after which it grants nothing), and every pass retires a subscription whose state, from this pass's answer or else as stored, is ended, whatever the ledger covers. The paidThrough guard stays at the prepaid call site, its only remaining user.
Run: 010-subscription-lifecycle, slice S1
* docs: record that a badge subscription cannot be restored or bought again
Restoring a subscription on a new device or under another profile fails for two independent reasons, the client's restore reading only unfinished transactions on iOS and the service answering any key but the one it credited receipt_used, and a lapsed iOS subscriber cannot subscribe again on the same install either. Both gaps files record it in their own format, and both restorePurchases() say why reading the store's entitlements alone would not help.
Run: 010-subscription-lifecycle, slice S2c
* fixup! core: retire a subscription badge as soon as its store says it ended
* transfer plan
* shorter plan
* update plan
* badge-service: let a dev deployment ask its mock store while coverage runs
[dev] check_store_during_coverage = on makes every issueBadge for a
subscription ask the dev mock, during paid coverage too, and bank the
month of a charge it can grant, issued once coverage reaches it. So a
renewal can be watched by hand without waiting a month, and a mock that
forgot the plan after a restart answers ended at once.
Off by default, and refused unless accept_unverified_store_receipts is
on, which is itself refused beside a real store: a real store has not
started its next charge while coverage runs, and asking spends the
quota every subscriber shares.
Run: 011-subscription-tools, slice S3a
* core: send a badge request at once from a build for the dev badge service
/_badge request <userId> sends the profile's badge request now, while
its badge is shown, and runs the badge pass on the answer, so a renewal
or an ended subscription can be watched by hand against the dev
service.
It is allowed only when ChatConfig's badgeDevRequests is set, which no
shipped build does and nothing sets at runtime: the dev-service branch
sets it beside its own badge service overrides. A request off the shared
expiry would tell requests apart, so every other build refuses it, and
it is refused from a paired remote controller.
Run: 011-subscription-tools, slice S3b
* fixup! badge-service: let a dev deployment ask its mock store while coverage runs
* fixup! badge-service: let a dev deployment ask its mock store while coverage runs
* fixup! core: send a badge request at once from a build for the dev badge service
* core: split the badge request's lock from its body
The receipt worker's attempt already holds the owner's badge lock, which is not reentrant, so it cannot call requestBadgeIssue. The body becomes sendBadgeIssue, and both answer a service error as Left (code, retryAfter) instead of Nothing, so that caller can classify it as it does today. No behaviour change.
Run: 011-subscription-resume, slice S2-0
* core: retire on a device's ended report only once the paid period is over
StoreKit can report a subscription expired during Apple's billing retry, and Apple may then recover the charge, so retiring at once on that report left a paying user without the badge. The service's answered ended still retires at once, also while the ledger covers. A stored ended, which is how the device's report arrives, retires once paidThrough has passed.
Run: 011-subscription-resume, slice S1c
* core: resume a retired Apple subscription when its store charges it again
A same-install resubscription keeps Apple's original transaction id, so its hand-over found the old credited record and was answered from it with the old credential: the subscriber paid and got nothing. A credited record is now held again when a later charge of its subscription is handed over, the charge is not revoked, its paid period runs and it is dated less than a day ahead of this device's clock, and the record's purchase is its owner's newest, a subscription and not shown, with no other receipt held. The receipt worker then sends the purchase's issueBadge, and the service grants the charge as a renewal. A covered answer shows the purchase again with the newest credential and clears an ended state. A charge the service answers without crediting is deferred an hour and refused a day after its purchase date, so it holds the profile for about a day. A refused resume is remembered on the record (every credit, re-hold and resume clears credit_error), so the app's sweep does not hold the same charge again after its day.
Run: 011-subscription-resume, slice S2a
* fixup! core: resume a retired Apple subscription when its store charges it again
Review round 1 fixes:
- R1-1: a resumable charge waiting behind another held receipt of the owner is answered held and left unfinished, rather than answered from the record and finished uncredited.
- R1-3: a resume shows the purchase again only with a credential that has not expired.
- R1-2, R1-8: tests of the resumable-charge rule and the hold's edge, of a held charge whose paid period ends before it is sent, and that a resumed profile shows the newest credential. The resume test is split in two, one environment each.
- R2-V1: a test comment that the reordered steps made false.
Run: 011-subscription-resume, review rounds 1 and 2
* core, ios, android, desktop: let a lapsed iOS subscriber subscribe again to the badge the profile retired
The iOS app refused any subscription to an Apple ID that ever subscribed, so a lapsed subscriber could never subscribe again in the app. Core now tells the apps each subscription's store reference (BadgeSubscription.transactionRef, optional in JSON), and the iOS gate opens a subscription card only when every earlier subscription of the Apple ID is the active profile's newest purchase, retired, of the card's badge: the one charge core resumes. Kotlin gets the model field only, as Play gives a resubscription a new token and needs no gate.
Run: 011-subscription-resume, slice S2b
* docs: bound a badge move by the previous credential's expiry
* badge-service: credit test purchases and check the store during coverage in a dev deployment
* core: let a dev build ask the badge service on an interval
* badge-service: log each request's command and each store check's outcome
* fix compilation
* badge-service: name the purchase each request came from in the log
* badge-service: name the purchase each request came from in the log
* core, ios, android: explain a failed badge renewal and stop retrying a subscription the store forgot; tests (#7788)
* core, badge-service, ios, android: change badge tier in the store, and restore a subscription on another device (#7795)
* core: tell the apps when a badge request banks a month without issuing it
A pass announced the badge state only when the balance start moved, so a charge granted onto running coverage, or a debit the service wrote, changed months left and paid-through without an event, and the apps kept showing the old renewal date until the screen was reopened. The pass now announces whenever the ledger's last entry is not the one it started from, which a moved balance start implies.
Run: 015-badge-fixes, slice 1
* core: test that every Play charge of a month-end subscription funds its month
Play reports only a period's end, and the service dates the charge a plan length before it, so month-end clipping could leave a charge funding less than its month. Walk a monthly and an annual Play plan anchored on 31 January through their renewals at the device's request moments, through the deployed Play verifier: each charge funds exactly its months, paid-through stays at most the grace behind Play's period end (three days at most in this walk), and no charge is left without a grant.
Run: 015-badge-fixes, slice 2
* core: test that the newest issued badge credential is taken by its ledger row
After a tier change the newer issuance can end before the older one, so ordering issuances by period end would answer the superseded credential to the worker and to the resume and tier-change paths. Pin the row order: the test fails if the query goes back to period_end order.
Run: 015-badge-fixes, slice 3
* review: round 1 fixes
The App Store tier-change hold, reviewed for the first time:
- R1-B2: a tier change's credit now shows its purchase again (shown_badge_id) in the same transaction, as a resume's does, so a retire that ran while the change was with the service cannot leave a paid purchase unshown and never renewed.
- R1-B5: a tier change of a shown purchase is held whatever other receipt is held, as the worker serves it while the badge is shown; only a resume waits for other held receipts.
- R1-B3: test a tier change the store does not vouch for: refused in silence, the badge kept, and answered from the record after.
- R1-B8: the changeTier comment names when the record settles.
Run: 015-badge-fixes, review round 1
* review: round 2 fixes
- R2-1: a granted tier change clears an ended state the device reported before it. A renewing report never replaces ended, and a charge of the new tier granted proves the subscription has not ended, so without this the worker retired the new tier's badge at its paid-through while the subscription renewed.
- R1-B3: test a tier change whose credential does not verify: the failure stays on the receipt record, not the purchase, and Supporter stays shown.
- R2-3: the refused tier change's test buys Supporter through an invoice, so it shows the refusal announces nothing.
- R2-2: the changeTier comment says what follows each way the record settles.
Run: 015-badge-fixes, review round 2
* review: round 3 fixes
- R3-1: a tier change whose answer says the subscription ended is not credited, as a resume is not, so the credit's clearing of a stored ended never drops the one this answer carries.
- R3-2: the changeTier comment in two lines.
Run: 015-badge-fixes, review round 3
* core: apply an App Store tier change at once only when it raises the tier
Apple keeps charging the old plan to the end of the period, so applying a downgrade at once took away a badge the subscriber had already paid for. A charge of another tier is now held and sent at once only from supporter to legend; a lower tier, or one that is not ranked (investor, unknown), is answered from the record and the renewal check grants it, as badges-rpc.md says. A record already held for such a change settles silently.
Run: 016-tier-change-direction
* core: test that an App Store change to a lower tier waits for the renewal
A Supporter charge handed over while Legend is shown is answered from the record and sends nothing, and the renewal check grants Supporter, shown once the Legend credential expires; a record an older build held for a lower tier settles with no request. Both fail if every change of tier is sent at once again.
Run: 016-tier-change-direction
* badge-service: let a restore ask the store without waiting for the purchase's own check
* docs: describe badge tier changes and restore as the service handles them
The RPC document splits a store tier change by store and direction: the
app never starts one, an App Store raise seen within a day of its charge
is sent as upgradeBadgeSubscription, every other change waits for the
renewal check, and a Play plan change is a new token, a new purchase.
transferBadge and its limits are checked against the handlers, and the
upgrades that are not built are marked so.
The overview admits what Restore discloses: the service links the two
purchase keys, a store receipt moves its subscription to whoever presents
it within the move limit, and a new badge or tier is shown as soon as it
is issued. The Android gap names what remains of Restore.
* docs: tell the badge subscriptions story with tier changes and restore
The summary now covers the whole lifecycle: buying, renewing, changing
tier, moving to another device or profile, and ending. The badge retires
as soon as the store says the subscription ended, a lapsed iOS subscriber
can resume the retired badge, an App Store raise is granted at once and
a lower tier at the renewal, and a Play plan change is a new purchase.
The known limits and the before-sale list follow the code.
The seven diagrams are updated, with stale file and line references
dropped, and two are added: a tier change and a restore. The page now
points at the diagram files instead of carrying copies of them.
* fixup! docs: describe badge tier changes and restore as the service handles them
* fixup! docs: tell the badge subscriptions story with tier changes and restore
* fixup! docs: describe badge tier changes and restore as the service handles them
* fixup! docs: tell the badge subscriptions story with tier changes and restore
* core: make the badge subscription tests fail on the defects they name (#7798)
* fix compilation
* fix api
* ios, android, desktop: open the badge page on the site again
* ios: choose a badge on the site, not in the app
* tests: hold the move with no charge to grant, not with the purchase's store check
* unfocus test
* update postgres schema
* badge-service: break a tie between issuances by their period, so both databases agree
* badge subscription review fixes (#7799)
* update badge subscriptions docs (#7802)
* core: show a changed badge tier to contacts as soon as it is granted
* update plans
* core: show a raised badge tier to contacts at once, hold back a lower one
* update sqlite schema
* badge subscriptions review fixes (#7903)
* update ios lib
* update query plans
* ios: one property wrapper on the chat view's chat (#7910)
* android: a shorter note under Restore purchases
* Revert "ios: one property wrapper on the chat view's chat (#7910)"
This reverts commit d5a24bb342.
* ci: larger RAM disk so tests do not run out of space
* update sqlite schema
* ios: preview references for the badge screens
---------
Co-authored-by: spacedandy-agents-simplex <342056592+spacedandy-agents-simplex@users.noreply.github.com>
3740 lines
189 KiB
Haskell
3740 lines
189 KiB
Haskell
{-# LANGUAGE CPP #-}
|
|
{-# LANGUAGE DuplicateRecordFields #-}
|
|
{-# LANGUAGE LambdaCase #-}
|
|
{-# LANGUAGE NamedFieldPuns #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE TupleSections #-}
|
|
|
|
module Bots.BadgeService.WebTests (badgeWebTests) where
|
|
|
|
import BadgeService.Catalog (catalogCurrency, defaultCatalog)
|
|
import BadgeService.Config (BTCPayConfig (..), ListenerConfig (..), PollConfig (..), ServiceConfig (..), SpeedPolicy (..), StripeConfig (..))
|
|
import BadgeService.Orders (codeLifetime, settleOrder)
|
|
import BadgeService.Poller
|
|
import BadgeService.Providers
|
|
import BadgeService.Providers.BTCPay (btcpayProvider, listPageSize, maxListPages)
|
|
import BadgeService.Providers.Stripe (stripeProvider)
|
|
import BadgeService.Store (CreditedPurchase (..), FundingCredit (..), KeyPurchase (..), KeyRedemption (..), ManagedGroup (..), NewCodePurchase (..), NewStorePurchase (..), PaymentRebind (..), PurchaseSubscription (..), RevokeResult (..), appendLedgerPlan, createCodePurchase, createStorePurchase, getCodePurchaseForKey, getLedgerEntries, getLedgerTip, getManagedGroup, getMovedFromExpiry, getPurchaseByKey, getPurchaseSubscription, getStorePaymentCredit, insertBadgeCode, insertManagedGroup, insertSubscriptionCharge, markOwnerBootstrapped, rebindStorePayment, revokeCode)
|
|
import BadgeService.StoreReceipts (StoreCharge (..))
|
|
import BadgeService.Store.Invoices
|
|
import BadgeService.Waiters (awaitStatus, newWaiters, publish, waitingCount)
|
|
import BadgeService.Web.Server
|
|
import Bots.BadgeService.BotTests (codeCounts, newPurchaseKeys)
|
|
import Bots.BadgeService.CatalogTests (WebOffer (..), WebPrice (..), parseCatalogSource)
|
|
import Bots.BadgeService.FakeBTCPay
|
|
import Bots.BadgeService.FakeStripe (FakeStripe (..), fakeIntentStatus, setIntentState, stripeEvent, stripeSigHeader, withFakeStripe)
|
|
import Control.Concurrent (forkIO, threadDelay)
|
|
import Control.Concurrent.Async (async, wait)
|
|
import qualified Control.Concurrent.Async as Async
|
|
import Control.Concurrent.MVar (MVar, newEmptyMVar, newMVar, putMVar, takeMVar, withMVar)
|
|
import Control.Concurrent.STM (atomically, modifyTVar', readTVarIO)
|
|
import qualified Control.Exception as E
|
|
import Control.Monad (forM_, join, replicateM, replicateM_, void, when)
|
|
import Data.Aeson ((.=))
|
|
import qualified Data.Aeson as J
|
|
import qualified Data.Aeson.Key as K
|
|
import qualified Data.Aeson.KeyMap as KM
|
|
import Data.ByteString (ByteString)
|
|
import qualified Data.ByteString as BS
|
|
import qualified Data.ByteString.Base64.URL as B64U
|
|
import qualified Data.ByteString.Char8 as BC
|
|
import qualified Data.ByteString.Lazy.Char8 as LB
|
|
import Data.Char (toLower)
|
|
import Data.Either (isLeft)
|
|
import Data.Functor ((<&>))
|
|
import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef)
|
|
import Data.Int (Int64)
|
|
import Data.List (isInfixOf, sort, sortOn)
|
|
import qualified Data.Map.Strict as Map
|
|
import Data.Maybe (catMaybes, isJust, isNothing, fromMaybe, mapMaybe)
|
|
import Data.Text (Text)
|
|
import qualified Data.Text as T
|
|
import Data.Text.Encoding (encodeUtf8)
|
|
import qualified Data.Text.IO as T
|
|
import Data.Time.Calendar (fromGregorian)
|
|
import Data.Time.Clock (NominalDiffTime, UTCTime (..), addUTCTime, diffUTCTime, getCurrentTime, picosecondsToDiffTime, secondsToDiffTime)
|
|
import Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds)
|
|
import Data.Word (Word32, Word8)
|
|
import qualified GHC.IO.Device as IODevice
|
|
import qualified GHC.IO.FD as FD
|
|
import GHC.IO.Handle.FD (handleToFd)
|
|
import Network.HTTP.Client (Manager, Request (..), RequestBody (..), Response, defaultManagerSettings, httpLbs, newManager, parseRequest, responseBody, responseHeaders, responseStatus, responseTimeoutMicro)
|
|
import Network.HTTP.Types (Header, HeaderName, hCacheControl, hContentType)
|
|
import Network.HTTP.Types.Status (statusCode)
|
|
import qualified Network.Wai.Handler.Warp as Warp
|
|
import Simplex.Chat.Badges (BadgeCredential (..), BadgeInfo (..), BadgeMasterKey (..), BadgeType (..))
|
|
import Simplex.Chat.Badges.Ledger (addMonths, debitEntry, emptyEntry, grantEntry, issueEntry)
|
|
import Simplex.Chat.Badges.Service (BadgeOffer (..), BadgePrice (..), StatementCreditType (..), StatementDebitType (..), StatementEntry (..), SubscriptionState (..))
|
|
import Simplex.Chat.Badges.Types (BadgeCodePaymentStatus (..), BadgeItemStatus (..), BadgeOfferId (..), BadgePriceId (..), OfferDiscount (..))
|
|
import Simplex.Chat.PaymentService.Types (CryptoCurrency (..), CurrencyAmount (..), InvoiceId (..), InvoiceStatus (..), PaymentProvider (..), PaymentStatus (..), ServicePaymentDestination (..), ServicePaymentMethod (..))
|
|
import Simplex.Messaging.Agent.Store.Common (DBStore (..), withConnection, withTransaction)
|
|
import qualified Simplex.Messaging.Agent.Store.DB as DB
|
|
import Simplex.Messaging.Agent.Store.Interface
|
|
import Simplex.Messaging.Agent.Store.Shared (Migration (..), MigrationConfig (..), MigrationConfirmation (..), MigrationsToRun (..), toDownMigration)
|
|
import qualified Simplex.Messaging.Crypto as C
|
|
import Simplex.Messaging.Crypto.BBS (BBSSignature (..))
|
|
import Simplex.Messaging.Encoding.String (textDecode, textEncode)
|
|
import Simplex.Messaging.Util (safeDecodeUtf8, tshow)
|
|
import System.Directory (createDirectoryIfMissing, createFileLink, doesFileExist, listDirectory)
|
|
import System.FilePath ((</>))
|
|
import System.IO (IOMode (..), hFlush, stderr, withFile)
|
|
import System.IO.Unsafe (unsafePerformIO)
|
|
import System.Timeout (timeout)
|
|
import Test.Hspec
|
|
import Text.Read (readMaybe)
|
|
import UnliftIO.Temporary (withTempDirectory)
|
|
|
|
#if defined(dbPostgres)
|
|
import BadgeService.Store.Postgres.Migrations (badgeServiceSchemaMigrations)
|
|
import ChatClient (testDBConnstr)
|
|
import Database.PostgreSQL.Simple (Only (..))
|
|
import qualified Simplex.Messaging.Agent.Store.Postgres.Migrations as Migrations
|
|
#else
|
|
import BadgeService.Store.SQLite.Migrations (badgeServiceSchemaMigrations)
|
|
import Data.String (fromString)
|
|
import Database.SQLite.Simple (Only (..))
|
|
import qualified Database.SQLite.Simple as SQL
|
|
import Simplex.Messaging.Agent.Store.DB (TrackQueries (..))
|
|
import qualified Simplex.Messaging.Agent.Store.SQLite.Migrations as Migrations
|
|
#endif
|
|
|
|
#if defined(dbPostgres)
|
|
withServiceStore :: (DBStore -> IO a) -> IO a
|
|
withServiceStore action = do
|
|
n <- atomicModifyIORef' serviceSchemaCounter (\i -> (i + 1, i))
|
|
Right st <- createDBStore (serviceDBOpts n) badgeServiceSchemaMigrations (MigrationConfig MCError Nothing)
|
|
action st `E.finally` closeDBStore st
|
|
where
|
|
serviceDBOpts :: Int -> DBOpts
|
|
serviceDBOpts n =
|
|
DBOpts
|
|
{ connstr = BC.pack testDBConnstr,
|
|
schema = "sx_badge_service_web_test_" <> BC.pack (show n),
|
|
poolSize = 4,
|
|
createSchema = True
|
|
}
|
|
|
|
serviceSchemaCounter :: IORef Int
|
|
serviceSchemaCounter = unsafePerformIO $ newIORef 0
|
|
{-# NOINLINE serviceSchemaCounter #-}
|
|
#else
|
|
withServiceStore :: (DBStore -> IO a) -> IO a
|
|
withServiceStore action = do
|
|
createDirectoryIfMissing True "tests/tmp"
|
|
withTempDirectory "tests/tmp" "badge-web" $ \dir -> do
|
|
Right st <- createDBStore (DBOpts (dir </> "badge_service_test.db") [] "" False True TQOff) badgeServiceSchemaMigrations (MigrationConfig MCError Nothing)
|
|
action st `E.finally` closeDBStore st
|
|
#endif
|
|
|
|
columnsOf :: DBStore -> Text -> IO [Text]
|
|
columnsOf st table = withConnection st $ \db ->
|
|
#if defined(dbPostgres)
|
|
map fromOnly
|
|
<$> DB.query
|
|
db
|
|
"SELECT column_name FROM information_schema.columns WHERE table_schema = current_schema() AND table_name = ?"
|
|
(Only table)
|
|
#else
|
|
map fromOnly
|
|
<$> DB.query_ db (fromString ("SELECT name FROM pragma_table_info('" ++ T.unpack table ++ "')"))
|
|
#endif
|
|
|
|
badgeWebTests :: Spec
|
|
badgeWebTests = do
|
|
describe "badge service schema" $ do
|
|
it "carries the service-only columns, and none of the subscription columns it never wrote" testServiceColumns
|
|
it "refuses a duplicate provider_ref" testProviderRefUnique
|
|
it "M20260918 adds the multi-use columns and the group table" testGroupOpsColumns
|
|
it "M20260918 defaults a fresh code to one use with none spent" testGroupOpsRedeemCounts
|
|
it "migrates all the way down and up again" testSchemaDownUpCycle
|
|
it "rolls back only the group migration and re-applies it, keeping a code redeemed twice spent" testGroupOpsDownUp
|
|
it "rolls back only the subscription migration, restoring the columns it dropped, and re-applies it" testSubscriptionsDownUp
|
|
describe "badge service store" $ do
|
|
it "writes the invoice, its code and their link atomically" testCreationIsAtomic
|
|
it "newInvoiceId is 128 CSPRNG bits, base64url, and two calls differ" testNewInvoiceIdRandom
|
|
it "codeHashExists is true for a hash already written" testCodeHashExists
|
|
it "expireOverdue moves only open, past-expiry rows, and names them" testExpireOverdueMovesOnlyQualifying
|
|
it "expireOverdue moves only the overdue invoices it is given" testExpireOverdueMovesOnlyTheNamed
|
|
it "expireOverdue never sweeps an invoice that has been paid into" testExpireOverdueSparesAFundedInvoice
|
|
it "expireOverdue spares an invoice funded by dust, or by the verdict alone" testExpireOverdueSparesAZeroAmount
|
|
it "readCatalogRows drops every disabled row" testReadCatalogRowsDropsDisabled
|
|
it "a revoked code cannot be redeemed, and a redeemed code cannot be revoked" testRevokeAndRedeemExcludeEachOther
|
|
it "a multi-use code can be revoked while it has uses left, and not once they are gone" testRevokeMultiUseCode
|
|
it "every timestamp round-trips to the second" testTimestampRoundTrip
|
|
it "stores a charge credit with its charge, and reads it back at the tip and in the statement" testChargeCreditRoundTrip
|
|
it "stores transfers and an upgrade with the purchase each names, and reads them back at the tip and in the statement" testTransferEntriesRoundTrip
|
|
it "refuses a ledger row naming a purchase key with no purchase, writing nothing" testUnknownPurchaseKeyRefused
|
|
it "moves a store payment to a new key, ending the old purchase's share with a transferOut naming it" testPaymentRebind
|
|
it "moves nothing when the old purchase's ledger or the payment's binding moved since they were read" testPaymentRebindLostRace
|
|
it "reads the latest credential expiry of the purchase a payment last moved from" testMovedFromExpiry
|
|
describe "managed group" $ do
|
|
it "round-trips and bootstraps once" testManagedGroupRoundTripsAndBootstrapsOnce
|
|
it "refuses a second row and burns the flag per group" testManagedGroupIsSingleRow
|
|
describe "multi-use" $ do
|
|
it "finds a key's own purchase with its newest credential, and none for another key" testKeyPurchaseLookup
|
|
it "gives concurrent claims exactly the code's uses" testMultiUseConcurrentClaimsUpToLimit
|
|
it "refuses a second claim by the same key without using up a use" testSameKeyClaimsOnce
|
|
describe "badge service catalog seed" $ do
|
|
it "writes the compiled-in catalog into an empty database" testSeedWritesTheCatalog
|
|
it "leaves exactly one row per id when the service starts twice" testSeedIsIdempotent
|
|
it "leaves a price and an offer an operator withdrew withdrawn" testSeedNeverResurrectsAWithdrawnRow
|
|
it "seeds exactly what web/src/catalog.ts compiles into the page" testSeedMatchesWebCatalog
|
|
it "prices a btc checkout, and answers card provider_unavailable" testSeededCatalogSellsSomething
|
|
describe "BadgeService.Providers stub" $ do
|
|
it "constructs a Provider record and records every call, in order" testStubProviderRecordsCalls
|
|
it "makes pCreateInvoice fail on demand, so provider_unavailable is exercisable" testStubProviderCreateFailsOnDemand
|
|
it "records nothing when the caller never reaches the provider" testStubProviderNotCalledWhenSkipped
|
|
describe "badge service web" $ do
|
|
it "serves the shell at / and a hashed asset under /assets" testServesTheBuild
|
|
it "fills the shell's publishable key from the ini at boot" testShellCarriesPublishableKey
|
|
it "caches by where the file is, not by how the request spelled it" testCachingFollowsTheResolvedPath
|
|
it "serves the built web app, exactly as it is shipped" testServesBuiltWebApp
|
|
it "serves no static routes when serve_webapp is off, and still answers the API" testServeWebappOff
|
|
it "exports the injected webapp to a folder for a proxy to serve" testExportWebapp
|
|
it "refuses every traversal spelling, by canonicalisation" testTraversalRefused
|
|
it "answers the read fields, with cryptoCurrency lowercase" testInvoiceView
|
|
it "names the confirmations settlement needs, from the speed policy" testViewNamesTheConfirmationsSettlementNeeds
|
|
it "omits the confirmations where no provider is configured" testViewOmitsConfirmationsWithoutBTCPay
|
|
it "carries the provider's paid-in-full verdict, which the amounts cannot give" testViewCarriesTheProvidersPaidVerdict
|
|
it "never withdraws a paid-in-full verdict on a later read" testPaidVerdictIsNotWithdrawnByALaterRead
|
|
it "answers an unknown id with 404 not_found and nothing else" testUnknownInvoiceIsOpaque
|
|
it "releases a held wait when a payment lands without settling" testHeldWaitWakesOnAPaymentThatDoesNotSettle
|
|
it "leaves a held wait alone when a pass writes nothing" testHeldWaitIsNotWokenByAPassThatWroteNothing
|
|
it "is not woken by the same figures arriving again" testARepeatedSignalDoesNotWakeAHold
|
|
it "carries Cache-Control: no-store on every API response" testApiIsNeverCached
|
|
it "answers a known path reached with the wrong method with 405" testWrongMethodIs405
|
|
it "answers a path this task does not implement with 404" testUnroutedPathIs404
|
|
it "answers ?wait= at once when it is terminal, stale or unparseable" testWaitAnswersAtOnce
|
|
it "answers at once when it holds a payment the page has not seen" testHoldAnswersAPaymentThePageHasNotSeen
|
|
it "answers a verdict that arrived with no figure to go with it" testHoldAnswersAVerdictWithNoFigure
|
|
it "holds ?wait=open, and is woken by publish rather than polled" testHoldIsWokenNotPolled
|
|
it "refuses over sixty reads a minute from one IP" testReadRateLimit
|
|
it "takes the client from X-Forwarded-For only when it is trusted" testForwardedForOnlyWhenTrusted
|
|
it "uses a forwarded client only when it parses as an IP address" testForwardedForMustBeAnAddress
|
|
it "holds the bucket map under its cap through a flood of distinct clients" testBucketsStayBounded
|
|
it "answers a hold from the row it read, not from the status it woke on" testHoldReportsTheRowNotTheWake
|
|
it "answers a hold that timed out with a change nothing published" testHoldTimeoutReportsAnUnpublishedChange
|
|
it "answers a handler exception with 500 internal, and keeps serving" testHandlerExceptionIsContained
|
|
describe "badge service settlement" $ do
|
|
it "settles an open invoice: paid, a settled payment row, and the code" testSettlesAnOpenInvoice
|
|
it "settles an expired invoice, because late settlement is routine" testLateSettlementIsLegal
|
|
it "records what arrived without moving an unsettled invoice" testFundedRecordsWithoutMoving
|
|
it "expires an open invoice whose window closed, recording what arrived" testClosedExpiresAnOpenInvoice
|
|
it "writes no payment for a window that closed on nothing" testClosedWithNothingWritesNoPayment
|
|
it "rewrites the same values when a closed window is redelivered" testClosedReplayIsIdempotent
|
|
it "changes nothing for any signal against a paid invoice" testPaidRefusesEverySignal
|
|
it "takes the larger of the stored and the reported amount" testAmountIsMonotonic
|
|
it "measures the code deadline from the first settlement" testDeadlineIsFromTheFirstSettlement
|
|
it "leaves an invoice another transaction moved first alone" testStatusGuardRefusesAStaleObservation
|
|
it "publishes what it found when it loses the status guard" testLosingTheStatusGuardStillWakesTheHold
|
|
it "never downgrades a settled payment row" testSettledPaymentIsNotDowngraded
|
|
it "fills in a crypto amount that only arrived later" testCryptoAmountFillsInFromNull
|
|
it "answers Left for an invoice this service does not hold" testUnknownInvoiceSettlesNothing
|
|
it "publishes after the commit, so a woken reader finds the row" testPublishIsAfterCommit
|
|
it "wakes a request the listener is holding, from settleOrder itself" testSettlementWakesAHeldRequest
|
|
it "reports settledAt from the payment row, not from the invoice" testSettledAtIsThePaymentRow
|
|
it "refuses a settlement instant the provider cannot have meant" testAbsurdSettledInstantIsRefused
|
|
it "refuses a settlement instant in the future, as a millisecond clock gives" testFutureSettledInstantIsRefused
|
|
describe "badge service poller" $ do
|
|
it "settles a payment with no webhook delivered anywhere" testSettlesWithNoWebhookAtAll
|
|
it "reads only the invoices it is waiting on, and lists on the stray cadence" testPassReadsWhatItAwaits
|
|
it "asks the provider nothing when it is waiting on nothing" testIdlePassAsksNothing
|
|
it "lists instead of reading once too many invoices are open" testManyOpenInvoicesList
|
|
it "sweeps nothing when no provider can account for the rows" testNoProviderAccountsForNothing
|
|
it "holds the sweep for one row a configured provider does not own" testMixedProvidersHoldTheSweep
|
|
it "sends one list for a bulk pass, and none for the next one that reads" testBulkListIsTheOnlyList
|
|
it "hands every signal the pass returned to settleOrder, unless the row answers it" testEverySignalSettles
|
|
it "passes over a listed invoice this service does not hold" testForeignRefIsPassedOver
|
|
it "changes nothing when the provider fails, and settles on the next pass" testProviderFailureLosesNothing
|
|
it "reads the cadence fresh from the waiters each pass" testCadenceFollowsTheWaiters
|
|
it "cuts an idle sleep short when a browser arrives during it" testWaiterCutsTheIdleSleepShort
|
|
it "serves a hint batch without postponing a pass that falls due" testHintsDoNotPostponeThePass
|
|
it "floors the cadence, so a zero in the ini is not a busy loop" testCadenceHasAFloor
|
|
it "wakes a request the listener is holding, from a poller pass" testPollerWakesAHeldRequest
|
|
it "expires an open invoice past the ten-minute grace, and reads before it does" testSweepExpiresPastTheGrace
|
|
it "writes status alone, so a later SigClosed still records what arrived" testSweepWritesStatusAlone
|
|
it "wakes a request held on an invoice it expires" testSweepWakesAHeldRequest
|
|
it "cancels at a provider that keeps its invoice payable, then expires it" testSweepCancelsBeforeExpiring
|
|
it "keeps an invoice open while its provider refuses the cancel" testSweepKeepsOpenWhenCancelFails
|
|
it "settles an invoice past the settle window whose cancel is refused" testSweepSettlesWhatItCannotCancel
|
|
it "expires an invoice whose cancel answer was lost, from the read that follows" testSweepExpiresWhatAReadShowsCancelled
|
|
it "expires an invoice past the settle window once its cancel has failed for an hour, and reports it" testSweepGivesUpPastTheWindow
|
|
it "cancels overdue invoices oldest first, keeping the failures of those left for later" testSweepKeepsFailuresBeyondTheCap
|
|
it "expires an old invoice whose provider is gone, without a call" testSweepExpiresWithoutItsProvider
|
|
it "warns once per order while a cancel keeps failing" testSweepWarnsOncePerOrder
|
|
it "cancels at most a pass-sized batch, leaving the rest for the next pass" testSweepCapsCancelsPerPass
|
|
it "reports a skipped invoice once, and again only after the interval" testSkipWarningsAreRateLimited
|
|
it "warns once for a provider that stays down, not once a pass" testOutageWarnsOnceNotEveryPass
|
|
it "holds the skip log under its cap when every reason is fresh" testSkipReasonsStayBounded
|
|
it "warns once for all the invoices it did not sell, not once per invoice" testStrangerSkipsShareOneWarning
|
|
it "raises a skip naming an invoice this service sold" testSkipNamingOurInvoiceIsRaised
|
|
it "holds the sweep back until a pass has accounted for every invoice" testSweepWaitsForAPassThatSawEverything
|
|
it "settles the rest of the pass around an invoice that throws" testOneBadInvoiceDoesNotStopThePass
|
|
it "pages past a hundred open invoices, a request per hundred" testListPaginates
|
|
it "stops paging at its ceiling rather than looping on a server that ignores take" testPagingStopsAtTheCeiling
|
|
describe "badge service webhook" $ do
|
|
it "verifies a real BTCPay signature over the bytes as received, and queues" testWebhookVerifiesARealSignature
|
|
it "hands the adapter the raw body, byte for byte" testWebhookPassesTheRawBytes
|
|
it "queues a read and answers 200 empty, reaching no provider" testWebhookQueuesARead
|
|
it "settles by the poller's own path, so there is one settlement lane" testWebhookSettlesByThePollerPath
|
|
it "answers at once even when a read at the provider takes a second" testWebhookDoesNotWaitOnTheProvider
|
|
it "answers 400 empty, with no detail, for a signature that does not verify" testWebhookRefusesASignature
|
|
it "answers 200 for an unhandled type, an unknown ref and the other lane's ref" testWebhookIgnoresWhatItCannotActOn
|
|
it "refuses a body over the 64 KB cap before parsing or verifying it" testWebhookRefusesAnOversizedBody
|
|
it "queues a read of an order once, however often it is hinted before being served" testReadHintQueuedOnce
|
|
it "drops a hint rather than blocking when the queue is full" testWebhookDropsAHintWhenFull
|
|
it "answers 200 rather than any 5xx when the adapter or the store throws" testWebhookNeverAnswers5xx
|
|
describe "badge service checkout" $ do
|
|
it "answers the checkout fields and writes the three rows" testCreateInvoice
|
|
it "carries no code and no code hash, over the raw bytes" testCreateCarriesNoCode
|
|
it "tells the provider xmr rather than the chain another request used" testXmrReachesTheProviderAsXmr
|
|
it "derives badgeType, months and amount from the catalog, never from the body" testCreateDerivesFromCatalog
|
|
it "refuses every catalog_changed condition before the provider" testCatalogRefusalCostsNothing
|
|
it "refuses a code_hash already sold before the provider" testCodeConflictCostsNothing
|
|
it "maps a code_hash unique violation that raced the check to 409, not 500" testRacingCodeHashIsConflict
|
|
it "answers 500 and names the abandoned invoice when the store is lost" testStoreLostAfterTheProviderCreated
|
|
it "refuses a malformed body, an unknown method and a malformed codeHash" testBadRequestCostsNothing
|
|
it "refuses a body over the size cap before reading it all" testOversizedBodyCostsNothing
|
|
it "answers method card with provider_unavailable when no Stripe provider is configured" testCardUnconfigured503
|
|
it "answers a provider that failed to create with provider_unavailable, writing nothing" testProviderFailureWritesNothing
|
|
it "refuses the sixth create in a minute, without reaching the provider" testCreateRateLimit
|
|
describe "badge service card" $ do
|
|
it "creates a Stripe PaymentIntent, carrying its clientSecret and a stripe invoice row" testCardCreatesSession
|
|
it "cancels an overdue card order's intent at Stripe before expiring it" testCardSweepCancelsTheIntent
|
|
it "derives the shown expiry from stripe.session_minutes, not the btcpay window" testCardExpiryFollowsSessionMinutes
|
|
it "settles a card invoice from a signed payment_intent.succeeded and a pass" testCardWebhookSettles
|
|
describe "badge service cancel" $ do
|
|
it "expires the invoice here and invalidates it at the provider" testCancelClosesTheInvoiceAtBothEnds
|
|
it "wakes a hold another tab is sitting on" testCancelWakesAHeldRequest
|
|
it "refuses to cancel an invoice that is no longer open" testCancelIsRefusedOnceItIsNotOpen
|
|
it "refuses to cancel an invoice awaiting confirmation" testCancelIsRefusedOnceItIsFunded
|
|
it "leaves the invoice open when the provider refuses" testCancelLeavesTheInvoiceOpenWhenTheProviderFails
|
|
it "expires an invoice a payment landed on while the provider was being told" testCancelExpiresAFundedInvoice
|
|
it "answers an unknown id with the same 404 the read does" testCancelIsOpaqueForAnUnknownInvoice
|
|
it "answers GET with 405 and Allow: POST" testCancelRefusesOtherMethods
|
|
describe "badge service scenarios" $ do
|
|
it "buys a code: create, pay at BTCPay, one pass, paid" scenarioPaidPurchase
|
|
it "wakes a wait held from before the settlement, within a second of it" scenarioHeldWaitWakes
|
|
it "reports a partial payment and leaves the invoice open" scenarioPartPaymentIsReported
|
|
it "reports what an expiry received, and sells no code for it" scenarioExpiryReportsWhatArrived
|
|
it "settles an expired invoice late, because confirmation after expiry is routine" scenarioLateSettlement
|
|
it "changes nothing when the same settlement is seen a second time" scenarioReplayChangesNothing
|
|
it "closes an invalid invoice as expired, on the same screen" scenarioInvalidClosesAsExpired
|
|
it "refuses a second invoice for one code hash, creating none at BTCPay" scenarioCodeConflictCreatesNothing
|
|
it "settles with no webhook delivered, by reading the invoice it is waiting on" scenarioNoWebhookAnywhere
|
|
|
|
testServiceColumns :: IO ()
|
|
testServiceColumns = withServiceStore $ \st -> do
|
|
columnsOf st "sx_badge_service_badge_code_invoices"
|
|
>>= (`shouldSatisfy` \cs -> all (`elem` cs) ["badge_code_id", "provider_ref"])
|
|
columnsOf st "sx_badge_service_payments" >>= (`shouldSatisfy` elem "crypto_paid")
|
|
columnsOf st "sx_badge_service_badge_codes"
|
|
>>= (`shouldSatisfy` \cs -> all (`elem` cs) ["expires_at", "revoked_at"])
|
|
assertSubscriptionColumns st
|
|
|
|
assertSubscriptionColumns :: HasCallStack => DBStore -> IO ()
|
|
assertSubscriptionColumns st = do
|
|
columnsOf st "sx_badge_service_subscription_charges"
|
|
>>= (`shouldSatisfy` \cs -> all (`elem` cs) ["charge_id", "payment_id", "provider_charge_ref", "plan_id", "period_start", "period_end", "amount", "currency", "created_at"])
|
|
columnsOf st "sx_badge_service_badge_ledger" >>= (`shouldSatisfy` \cs -> all (`elem` cs) ["charge_id", "from_purchase_id", "to_purchase_id"])
|
|
payments <- columnsOf st "sx_badge_service_payments"
|
|
payments `shouldSatisfy` \cs -> all (`elem` cs) ["subscription_state", "subscription_checked_at", "provider_token", "rebound_at"]
|
|
payments `shouldSatisfy` \cs -> not (any (`elem` cs) ["subscription_renews_at", "grace_until", "cancelled"])
|
|
|
|
testGroupOpsColumns :: IO ()
|
|
testGroupOpsColumns = withServiceStore assertGroupOpsColumns
|
|
|
|
assertGroupOpsColumns :: HasCallStack => DBStore -> IO ()
|
|
assertGroupOpsColumns st = do
|
|
columnsOf st "sx_badge_service_badge_codes"
|
|
>>= (`shouldSatisfy` \cs -> all (`elem` cs) ["redeem_limit", "redeem_count", "group_item_id", "group_item_sent_at"])
|
|
columnsOf st "sx_badge_service_group"
|
|
>>= (`shouldSatisfy` \cs -> all (`elem` cs) ["group_id", "group_link", "owner_bootstrapped", "created_at"])
|
|
|
|
runMigrations :: DBStore -> MigrationsToRun -> IO ()
|
|
#if defined(dbPostgres)
|
|
runMigrations st = Migrations.run st Nothing
|
|
#else
|
|
runMigrations st = Migrations.run st Nothing True
|
|
#endif
|
|
|
|
testSchemaDownUpCycle :: IO ()
|
|
testSchemaDownUpCycle = withServiceStore $ \st -> do
|
|
let downMigrations = mapMaybe toDownMigration badgeServiceSchemaMigrations
|
|
length downMigrations `shouldBe` length badgeServiceSchemaMigrations
|
|
runMigrations st $ MTRDown downMigrations
|
|
columnsOf st "sx_badge_service_badge_codes" `shouldReturn` []
|
|
columnsOf st "sx_badge_service_group" `shouldReturn` []
|
|
columnsOf st "sx_badge_service_subscription_charges" `shouldReturn` []
|
|
runMigrations st $ MTRUp badgeServiceSchemaMigrations
|
|
assertGroupOpsColumns st
|
|
assertSubscriptionColumns st
|
|
|
|
testSubscriptionsDownUp :: IO ()
|
|
testSubscriptionsDownUp = withServiceStore $ \st -> do
|
|
let subscriptions = [m | m@Migration {name = "20261012_badge_subscriptions"} <- badgeServiceSchemaMigrations]
|
|
length subscriptions `shouldBe` 1
|
|
runMigrations st $ MTRDown (mapMaybe toDownMigration subscriptions)
|
|
columnsOf st "sx_badge_service_subscription_charges" `shouldReturn` []
|
|
columnsOf st "sx_badge_service_badge_ledger" >>= (`shouldNotSatisfy` \cs -> any (`elem` cs) ["charge_id", "from_purchase_id", "to_purchase_id"])
|
|
payments <- columnsOf st "sx_badge_service_payments"
|
|
payments `shouldSatisfy` \cs -> all (`elem` cs) ["subscription_renews_at", "grace_until", "cancelled"]
|
|
payments `shouldSatisfy` \cs -> not (any (`elem` cs) ["subscription_state", "subscription_checked_at", "provider_token", "rebound_at"])
|
|
runMigrations st $ MTRUp subscriptions
|
|
assertSubscriptionColumns st
|
|
|
|
testGroupOpsDownUp :: IO ()
|
|
testGroupOpsDownUp = withServiceStore $ \st -> do
|
|
now <- truncateToSecond <$> getCurrentTime
|
|
let redeemedHash = digestFixture 44
|
|
unredeemedHash = digestFixture 45
|
|
groupOps = [m | m@Migration {name = "20260918_badge_group_ops"} <- badgeServiceSchemaMigrations]
|
|
redeemed <- insertCode st redeemedHash CPSPaid 2 now
|
|
void $ insertCode st unredeemedHash CPSPaid 1 now
|
|
-- Two purchases of one code would break a down migration that restored the unique index.
|
|
replicateM_ 2 $ newPurchaseKeys >>= claimUse st redeemed now >>= (`shouldSatisfy` isJust)
|
|
runMigrations st $ MTRDown (mapMaybe toDownMigration groupOps)
|
|
columnsOf st "sx_badge_service_badge_codes" >>= (`shouldNotSatisfy` elem "redeem_count")
|
|
runMigrations st $ MTRUp groupOps
|
|
codeCounts st redeemedHash `shouldReturn` Just (1, 1)
|
|
codeCounts st unredeemedHash `shouldReturn` Just (1, 0)
|
|
|
|
testGroupOpsRedeemCounts :: IO ()
|
|
testGroupOpsRedeemCounts = withServiceStore $ \st -> do
|
|
let codeHash = digestFixture 43
|
|
withConnection st $ \db ->
|
|
DB.execute
|
|
db
|
|
"INSERT INTO sx_badge_service_badge_codes (code_hash, badge_type, months, code_payment_status, created_at) VALUES (?,?,?,?,?)"
|
|
(DB.Binary codeHash, "supporter" :: Text, 1 :: Int, "free" :: Text, someCreated)
|
|
codeCounts st codeHash `shouldReturn` Just (1, 0)
|
|
|
|
testProviderRefUnique :: IO ()
|
|
testProviderRefUnique = withServiceStore $ \st -> do
|
|
seedBadgePrice st "price1"
|
|
seedInvoice st "inv1"
|
|
seedInvoice st "inv2"
|
|
insertBadgeCodeInvoice st "inv1" "price1" "same-provider-ref"
|
|
insertBadgeCodeInvoice st "inv2" "price1" "same-provider-ref"
|
|
`shouldThrow` anyException
|
|
|
|
seedInvoice :: DBStore -> Text -> IO ()
|
|
seedInvoice st invoiceId = withConnection st $ \db ->
|
|
DB.execute
|
|
db
|
|
"INSERT INTO sx_badge_service_invoices (invoice_id, provider, price, amount, currency, expires_at, status, created_at, updated_at) VALUES (?,?,?,?,?,?,?,?,?)"
|
|
(invoiceId, "btcpay" :: Text, 500 :: Int, 500 :: Int, "usd" :: Text, "2030-01-01T00:00:00Z" :: Text, "open" :: Text, "2026-08-31T00:00:00Z" :: Text, "2026-08-31T00:00:00Z" :: Text)
|
|
|
|
seedBadgePrice :: DBStore -> Text -> IO ()
|
|
seedBadgePrice st priceId = withConnection st $ \db ->
|
|
DB.execute
|
|
db
|
|
"INSERT INTO sx_badge_service_badge_prices (price_id, badge_type, month_price, currency, status, created_at) VALUES (?,?,?,?,?,?)"
|
|
(priceId, "supporter" :: Text, 500 :: Int, "usd" :: Text, "active" :: Text, "2026-08-31T00:00:00Z" :: Text)
|
|
|
|
insertBadgeCodeInvoice :: DBStore -> Text -> Text -> Text -> IO ()
|
|
insertBadgeCodeInvoice st invoiceId priceId providerRef = withConnection st $ \db -> do
|
|
let codeHash = DB.Binary (digestFixture (fromIntegral (sum (map fromEnum (T.unpack invoiceId)))))
|
|
DB.execute
|
|
db
|
|
"INSERT INTO sx_badge_service_badge_codes (code_hash, badge_type, months, code_payment_status, created_at) VALUES (?,?,?,?,?)"
|
|
(codeHash, "supporter" :: Text, 1 :: Int, "unpaid" :: Text, "2026-08-31T00:00:00Z" :: Text)
|
|
DB.execute
|
|
db
|
|
"INSERT INTO sx_badge_service_badge_code_invoices (invoice_id, badge_code_id, price_id, created_at, provider_ref) SELECT ?, badge_code_id, ?, ?, ? FROM sx_badge_service_badge_codes WHERE code_hash = ?"
|
|
(invoiceId, priceId, "2026-08-31T00:00:00Z" :: Text, providerRef, codeHash)
|
|
|
|
someExpiry :: UTCTime
|
|
someExpiry = UTCTime (fromGregorian 2030 1 1) 0
|
|
|
|
someCreated :: UTCTime
|
|
someCreated = UTCTime (fromGregorian 2026 8 31) 0
|
|
|
|
-- | These 32 bytes are all above 0x7f, so the value is not valid UTF-8 and catches the
|
|
-- postgresql-simple bug where a plain ByteString is written as escaped text.
|
|
digestFixture :: Word8 -> ByteString
|
|
digestFixture n = BS.pack [0x80 + ((n * 7 + i) `mod` 0x80) | i <- [0 .. 31]]
|
|
|
|
sampleInvoice :: NewInvoice
|
|
sampleInvoice =
|
|
NewInvoice
|
|
{ niInvoiceId = InvoiceId "inv1",
|
|
niProviderRef = "provider-ref-1",
|
|
niCodeHash = digestFixture 1,
|
|
niPriceId = BadgePriceId "price1",
|
|
niOfferId = Nothing,
|
|
niBadgeType = BTSupporter,
|
|
niMonths = 1,
|
|
niPrice = CurrencyAmount 500,
|
|
niAmount = CurrencyAmount 500,
|
|
niCurrency = "usd",
|
|
niProvider = PPCrypto,
|
|
niDestination = SPDCrypto CCBtc "bc1qexampleaddress" "0.00050000",
|
|
niExpiresAt = someExpiry,
|
|
niCreatedAt = someCreated
|
|
}
|
|
|
|
codeInvoiceRow :: DBStore -> InvoiceId -> IO (Maybe Text)
|
|
codeInvoiceRow st (InvoiceId invId) = withConnection st $ \db -> do
|
|
rows <- DB.query db "SELECT invoice_id FROM sx_badge_service_badge_code_invoices WHERE invoice_id = ?" (Only invId) :: IO [Only Text]
|
|
pure $ case rows of
|
|
[] -> Nothing
|
|
(Only r : _) -> Just r
|
|
|
|
markPaid :: DBStore -> InvoiceId -> IO ()
|
|
markPaid st (InvoiceId invId) = withConnection st $ \db ->
|
|
DB.execute db "UPDATE sx_badge_service_invoices SET status = 'paid' WHERE invoice_id = ?" (Only invId)
|
|
|
|
insertPrice :: DBStore -> Text -> Text -> Int -> Text -> IO ()
|
|
insertPrice st priceId badgeType monthPrice status = withConnection st $ \db ->
|
|
DB.execute
|
|
db
|
|
"INSERT INTO sx_badge_service_badge_prices (price_id, badge_type, month_price, currency, status, created_at) VALUES (?,?,?,?,?,?)"
|
|
(priceId, badgeType, monthPrice, "usd" :: Text, status, "2026-08-31T00:00:00Z" :: Text)
|
|
|
|
insertOffer :: DBStore -> Text -> Maybe Text -> Int -> Int -> Text -> IO ()
|
|
insertOffer st offerId priceId months discount status = withConnection st $ \db ->
|
|
DB.execute
|
|
db
|
|
"INSERT INTO sx_badge_service_badge_offers (offer_id, price_id, months, discount, status, created_at) VALUES (?,?,?,?,?,?)"
|
|
(offerId, priceId, months, discount, status, "2026-08-31T00:00:00Z" :: Text)
|
|
|
|
testCreationIsAtomic :: IO ()
|
|
testCreationIsAtomic = withServiceStore $ \st -> do
|
|
seedBadgePrice st "price1"
|
|
let duplicateHash = digestFixture 9
|
|
planted = sampleInvoice {niInvoiceId = InvoiceId "other", niProviderRef = "p-other", niCodeHash = duplicateHash}
|
|
ni = sampleInvoice {niCodeHash = duplicateHash}
|
|
planted' <- createInvoiceRows st planted
|
|
planted' `shouldBe` Right ()
|
|
r <- createInvoiceRows st ni
|
|
r `shouldSatisfy` isLeft
|
|
r `shouldBe` Left CECodeConflict
|
|
getInvoice st (niInvoiceId ni) `shouldReturn` Nothing
|
|
codeInvoiceRow st (niInvoiceId ni) `shouldReturn` Nothing
|
|
|
|
testNewInvoiceIdRandom :: IO ()
|
|
testNewInvoiceIdRandom = do
|
|
InvoiceId a <- newInvoiceId
|
|
InvoiceId b <- newInvoiceId
|
|
a `shouldNotBe` b
|
|
T.length a `shouldBe` 22
|
|
T.any (== '=') a `shouldBe` False
|
|
|
|
testCodeHashExists :: IO ()
|
|
testCodeHashExists = withServiceStore $ \st -> do
|
|
seedBadgePrice st "price1"
|
|
createInvoiceRows st sampleInvoice `shouldReturn` Right ()
|
|
codeHashExists st (niCodeHash sampleInvoice) `shouldReturn` True
|
|
codeHashExists st "no-such-hash" `shouldReturn` False
|
|
|
|
testExpireOverdueMovesOnlyQualifying :: IO ()
|
|
testExpireOverdueMovesOnlyQualifying = withServiceStore $ \st -> do
|
|
seedBadgePrice st "price1"
|
|
now <- getCurrentTime
|
|
let pastExpiry = addUTCTime (-3600) now
|
|
futureExpiry = addUTCTime 3600 now
|
|
overdue = sampleInvoice {niExpiresAt = pastExpiry}
|
|
notYet = sampleInvoice {niInvoiceId = InvoiceId "inv-notyet", niProviderRef = "p-notyet", niCodeHash = digestFixture 13, niExpiresAt = futureExpiry}
|
|
alreadyPaid = sampleInvoice {niInvoiceId = InvoiceId "inv-paid", niProviderRef = "p-paid", niCodeHash = digestFixture 14, niExpiresAt = pastExpiry}
|
|
createInvoiceRows st overdue `shouldReturn` Right ()
|
|
createInvoiceRows st notYet `shouldReturn` Right ()
|
|
createInvoiceRows st alreadyPaid `shouldReturn` Right ()
|
|
markPaid st (niInvoiceId alreadyPaid)
|
|
map (\OverdueInvoice {oiInvoiceId, oiProviderRef} -> (oiInvoiceId, oiProviderRef)) <$> overdueInvoices st now `shouldReturn` [(niInvoiceId overdue, niProviderRef overdue)]
|
|
moved <- expireAllOverdue st now
|
|
moved `shouldBe` [niInvoiceId overdue]
|
|
Just overdueRow <- getInvoice st (niInvoiceId overdue)
|
|
irStatus overdueRow `shouldBe` ISExpired
|
|
Just notYetRow <- getInvoice st (niInvoiceId notYet)
|
|
irStatus notYetRow `shouldBe` ISOpen
|
|
Just paidRow <- getInvoice st (niInvoiceId alreadyPaid)
|
|
irStatus paidRow `shouldBe` ISPaid
|
|
|
|
testExpireOverdueMovesOnlyTheNamed :: IO ()
|
|
testExpireOverdueMovesOnlyTheNamed = withServiceStore $ \st -> do
|
|
seedBadgePrice st "price1"
|
|
now <- getCurrentTime
|
|
let pastExpiry = addUTCTime (-3600) now
|
|
named = sampleInvoice {niExpiresAt = pastExpiry}
|
|
unnamed = sampleInvoice {niInvoiceId = InvoiceId "inv-unnamed", niProviderRef = "p-unnamed", niCodeHash = digestFixture 13, niExpiresAt = pastExpiry}
|
|
createInvoiceRows st named `shouldReturn` Right ()
|
|
createInvoiceRows st unnamed `shouldReturn` Right ()
|
|
expireOverdue st now [niInvoiceId named] `shouldReturn` [niInvoiceId named]
|
|
invoiceStatus st (niInvoiceId named) `shouldReturn` ISExpired
|
|
invoiceStatus st (niInvoiceId unnamed) `shouldReturn` ISOpen
|
|
expireOverdue st now [niInvoiceId named] `shouldReturn` []
|
|
|
|
expireAllOverdue :: DBStore -> UTCTime -> IO [InvoiceId]
|
|
expireAllOverdue st now = overdueInvoices st now >>= expireOverdue st now . map oiInvoiceId
|
|
|
|
testRevokeAndRedeemExcludeEachOther :: IO ()
|
|
testRevokeAndRedeemExcludeEachOther = withServiceStore $ \st -> do
|
|
now <- truncateToSecond <$> getCurrentTime
|
|
keys <- newPurchaseKeys
|
|
let newCode codeHash = insertCode st codeHash CPSPaid 1 now
|
|
redeem badgeCodeId = claimUse st badgeCodeId now keys
|
|
revoke codeHash = withTransaction st $ \db -> revokeCode db codeHash now
|
|
revokedFirst <- newCode "revoked-first"
|
|
revoke "revoked-first" `shouldReturn` Revoked revokedFirst
|
|
redeem revokedFirst `shouldReturn` Nothing
|
|
codeCounts st "revoked-first" `shouldReturn` Just (1, 0)
|
|
redeemedFirst <- newCode "redeemed-first"
|
|
isJust <$> redeem redeemedFirst `shouldReturn` True
|
|
revoke "redeemed-first" `shouldReturn` AlreadyRedeemed
|
|
redeem redeemedFirst `shouldReturn` Nothing
|
|
|
|
testRevokeMultiUseCode :: IO ()
|
|
testRevokeMultiUseCode = withServiceStore $ \st -> do
|
|
now <- truncateToSecond <$> getCurrentTime
|
|
let newCode codeHash = insertCode st codeHash CPSPaid 2 now
|
|
-- A purchase key redeems once, so every redemption here brings its own.
|
|
redeem badgeCodeId = newPurchaseKeys >>= claimUse st badgeCodeId now
|
|
revoke codeHash = withTransaction st $ \db -> revokeCode db codeHash now
|
|
partlyUsed <- newCode "partly-used"
|
|
isJust <$> redeem partlyUsed `shouldReturn` True
|
|
revoke "partly-used" `shouldReturn` Revoked partlyUsed
|
|
redeem partlyUsed `shouldReturn` Nothing
|
|
usedUp <- newCode "used-up"
|
|
isJust <$> redeem usedUp `shouldReturn` True
|
|
isJust <$> redeem usedUp `shouldReturn` True
|
|
revoke "used-up" `shouldReturn` AlreadyRedeemed
|
|
|
|
testReadCatalogRowsDropsDisabled :: IO ()
|
|
testReadCatalogRowsDropsDisabled = withServiceStore $ \st -> do
|
|
insertPrice st "price-active" "supporter" 500 "active"
|
|
insertPrice st "price-disabled" "supporter" 500 "disabled"
|
|
insertOffer st "offer-active" (Just "price-active") 3 10 "active"
|
|
insertOffer st "offer-disabled" (Just "price-active") 3 10 "disabled"
|
|
(prices, offers) <- readCatalogRows st
|
|
map (\BadgePrice {priceId} -> priceId) prices `shouldBe` [BadgePriceId "price-active"]
|
|
map (\BadgeOffer {offerId} -> offerId) offers `shouldBe` [BadgeOfferId "offer-active"]
|
|
|
|
seedDefaultCatalog :: DBStore -> UTCTime -> IO (Int, Int)
|
|
seedDefaultCatalog st at = uncurry (seedCatalog st) (defaultCatalog at)
|
|
|
|
priceFacts :: BadgePrice -> (Text, Text, Word32, Text, BadgeItemStatus)
|
|
priceFacts BadgePrice {priceId = BadgePriceId pId, badgeType = bType, monthPrice = CurrencyAmount mPrice, currency = cur, status = pStatus} =
|
|
(pId, textEncode bType, mPrice, cur, pStatus)
|
|
|
|
offerFacts :: BadgeOffer -> (Text, Maybe Text, Word8, OfferDiscount, BadgeItemStatus)
|
|
offerFacts BadgeOffer {offerId = BadgeOfferId oId, priceId = oPriceId, months = oMonths, discount = oDiscount, status = oStatus} =
|
|
(oId, (\(BadgePriceId p) -> p) <$> oPriceId, oMonths, oDiscount, oStatus)
|
|
|
|
allPriceRows :: DBStore -> IO [(Text, Text, Word32, Text, Text, UTCTime)]
|
|
allPriceRows st = withConnection st $ \db ->
|
|
DB.query_ db "SELECT price_id, badge_type, month_price, currency, status, created_at FROM sx_badge_service_badge_prices ORDER BY price_id"
|
|
|
|
allOfferRows :: DBStore -> IO [(Text, Maybe Text, Word32, Maybe Word32, Maybe Word32, Text, UTCTime)]
|
|
allOfferRows st = withConnection st $ \db ->
|
|
DB.query_ db "SELECT offer_id, price_id, months, free_months, discount, status, created_at FROM sx_badge_service_badge_offers ORDER BY offer_id"
|
|
|
|
testSeedWritesTheCatalog :: IO ()
|
|
testSeedWritesTheCatalog = withServiceStore $ \st -> do
|
|
readCatalogRows st `shouldReturn'` (0, 0)
|
|
seedDefaultCatalog st someCreated `shouldReturn` (2, 4)
|
|
(prices, offers) <- readCatalogRows st
|
|
sortOn (\(i, _, _, _, _) -> i) (map priceFacts prices)
|
|
`shouldBe` [ ("price_legend", "legend", 7000, "usd", BISActive),
|
|
("price_supporter", "supporter", 700, "usd", BISActive)
|
|
]
|
|
sortOn (\(i, _, _, _, _) -> i) (map offerFacts offers)
|
|
`shouldBe` [ ("offer_12m", Just "price_legend", 12, ODDiscount 50, BISActive),
|
|
("offer_12m_s", Just "price_supporter", 12, ODDiscount 50, BISActive),
|
|
("offer_3m", Just "price_legend", 3, ODFreeMonths 1, BISActive),
|
|
("offer_3m_s", Just "price_supporter", 3, ODFreeMonths 1, BISActive)
|
|
]
|
|
where
|
|
shouldReturn' action expected = do
|
|
(ps, os) <- action
|
|
(length ps, length os) `shouldBe` expected
|
|
|
|
testSeedIsIdempotent :: IO ()
|
|
testSeedIsIdempotent = withServiceStore $ \st -> do
|
|
seedDefaultCatalog st someCreated `shouldReturn` (2, 4)
|
|
let restartedAt = addUTCTime 86400 someCreated
|
|
seedDefaultCatalog st restartedAt `shouldReturn` (0, 0)
|
|
priceRows <- allPriceRows st
|
|
offerRows <- allOfferRows st
|
|
map (\(i, _, _, _, _, _) -> i) priceRows `shouldBe` ["price_legend", "price_supporter"]
|
|
map (\(i, _, _, _, _, _, _) -> i) offerRows `shouldBe` ["offer_12m", "offer_12m_s", "offer_3m", "offer_3m_s"]
|
|
map (\(_, _, _, _, _, at) -> at) priceRows `shouldBe` replicate 2 someCreated
|
|
map (\(_, _, _, _, _, _, at) -> at) offerRows `shouldBe` replicate 4 someCreated
|
|
|
|
testSeedNeverResurrectsAWithdrawnRow :: IO ()
|
|
testSeedNeverResurrectsAWithdrawnRow = withServiceStore $ \st -> do
|
|
insertPrice st "price_supporter" "supporter" 900 "deprecated"
|
|
insertPrice st "price_legend" "legend" 9000 "disabled"
|
|
insertOffer st "offer_12m" (Just "price_legend") 12 25 "disabled"
|
|
seedDefaultCatalog st someCreated `shouldReturn` (0, 3)
|
|
priceRows <- allPriceRows st
|
|
map (\(i, _, mp, _, s, _) -> (i, mp, s)) priceRows
|
|
`shouldBe` [("price_legend", 9000, "disabled"), ("price_supporter", 900, "deprecated")]
|
|
offerRows <- allOfferRows st
|
|
map (\(i, _, m, _, d, s, _) -> (i, m, d, s)) offerRows
|
|
`shouldBe` [ ("offer_12m", 12, Just 25, "disabled"),
|
|
("offer_12m_s", 12, Just 50, "active"),
|
|
("offer_3m", 3, Nothing, "active"),
|
|
("offer_3m_s", 3, Nothing, "active")
|
|
]
|
|
(prices, offers) <- readCatalogRows st
|
|
sortOn (\(i, _, _, _, _) -> i) (map priceFacts prices)
|
|
`shouldBe` [("price_supporter", "supporter", 900, "usd", BISDeprecated)]
|
|
map (\(i, _, _, _, _) -> i) (sortOn (\(i, _, _, _, _) -> i) (map offerFacts offers))
|
|
`shouldBe` ["offer_12m_s", "offer_3m", "offer_3m_s"]
|
|
|
|
testSeedMatchesWebCatalog :: IO ()
|
|
testSeedMatchesWebCatalog = withServiceStore $ \st -> do
|
|
src <- T.readFile "apps/simplex-badge-service/web/src/catalog.ts"
|
|
(webPrices, webOffers) <- case parseCatalogSource src of
|
|
Nothing -> failWith "could not parse CATALOG out of web/src/catalog.ts -- its shape has changed"
|
|
Just parsed -> pure parsed
|
|
webPrices `shouldNotBe` []
|
|
webOffers `shouldNotBe` []
|
|
seedDefaultCatalog st someCreated `shouldReturn` (length webPrices, length webOffers)
|
|
(prices, offers) <- readCatalogRows st
|
|
sortOn (\(i, _, _, _) -> i) (map (\(i, t, mp, cur, _) -> (i, t, mp, cur)) (map priceFacts prices))
|
|
`shouldBe` sortOn (\(i, _, _, _) -> i) (map (\WebPrice {wpPriceId, wpBadgeType, wpMonthPrice, wpCurrency} -> (wpPriceId, wpBadgeType, wpMonthPrice, wpCurrency)) webPrices)
|
|
sortOn (\(i, _, _, _) -> i) (map (\(i, p, m, d, _) -> (i, p, m, d)) (map offerFacts offers))
|
|
`shouldBe` sortOn (\(i, _, _, _) -> i) (map (\WebOffer {woOfferId, woPriceId, woMonths, woDiscount} -> (woOfferId, Just woPriceId, woMonths, woDiscount)) webOffers)
|
|
|
|
testSeededCatalogSellsSomething :: IO ()
|
|
testSeededCatalogSellsSomething = bounded "seeded catalog sells" $ withSeededCheckout $ \client -> do
|
|
card <- postCreateAs client 1 (createBody "price_legend" (Just "offer_12m") "card" (codeHashText sampleCode))
|
|
statusOf card `shouldBe` 503
|
|
responseBody card `shouldBe` errorBody "provider_unavailable"
|
|
priced <- postCreateAs client 2 (createBody "price_legend" (Just "offer_12m") "btc" (codeHashText sampleCode))
|
|
statusOf priced `shouldBe` 200
|
|
o <- jsonObject priced
|
|
fieldOf o "badgeType" `shouldBe` Just (J.String "legend")
|
|
fieldOf o "months" `shouldBe` Just (J.Number 12)
|
|
fieldOf o "amount" `shouldBe` Just (J.Number 42000)
|
|
fieldOf o "currency" `shouldBe` Just (J.String catalogCurrency)
|
|
|
|
withSeededCheckout :: (WebClient -> IO a) -> IO a
|
|
withSeededCheckout action =
|
|
withServiceStore $ \st -> do
|
|
createDirectoryIfMissing True "tests/tmp"
|
|
withTempDirectory "tests/tmp" "badge-seeded" $ \root -> do
|
|
staticDir <- prepareStaticDir root
|
|
_ <- seedDefaultCatalog st someCreated
|
|
ref <- newIORef (newStubState (Right sampleProviderInvoice))
|
|
let cfg = (testServiceConfig staticDir True) {btcpay = Just testBTCPayConfig}
|
|
withListener [stubProvider ref] True holdMicros st cfg (const action)
|
|
|
|
testTimestampRoundTrip :: IO ()
|
|
testTimestampRoundTrip = withServiceStore $ \st -> do
|
|
seedBadgePrice st "price1"
|
|
let subSecond = UTCTime (fromGregorian 2026 8 31) (picosecondsToDiffTime 12500000000000)
|
|
truncated = UTCTime (fromGregorian 2026 8 31) (picosecondsToDiffTime 12000000000000)
|
|
ni = sampleInvoice {niExpiresAt = subSecond, niCreatedAt = subSecond}
|
|
createInvoiceRows st ni `shouldReturn` Right ()
|
|
Just row <- getInvoice st (niInvoiceId ni)
|
|
irExpiresAt row `shouldBe` truncated
|
|
irCreatedAt row `shouldBe` truncated
|
|
|
|
testChargeCreditRoundTrip :: IO ()
|
|
testChargeCreditRoundTrip = withServiceStore $ \st -> do
|
|
now <- truncateToSecond <$> getCurrentTime
|
|
(purchaseKey, masterKey) <- newPurchaseKeys
|
|
Just purchaseId <- withTransaction st $ \db ->
|
|
createStorePurchase db NewStorePurchase {paymentId = "pay1", provider = PPApple, providerRef = "2000000812345671", paid = Nothing, purchaseKey, masterKey, badgeType = BTSupporter, subscriptionState = Just SSRenewing, providerToken = Nothing} now
|
|
withTransaction st $ \db ->
|
|
insertSubscriptionCharge db "pay1" "ch1" StoreCharge {chargeRef = "2000000812345672", planId = "SUBSCR_BADGE_SUPPORTER_MONTH_01", periodStart = now, periodEnd = addMonths 1 now, chargePaid = Nothing, revoked = False, offer = False} now
|
|
let charge = grantEntry now "e1" BTSupporter 1 (SCCharge "ch1") (emptyEntry now BTSupporter)
|
|
withTransaction st $ \db -> appendLedgerPlan db purchaseId Nothing [charge] Nothing
|
|
withTransaction st (\db -> getLedgerEntries db purchaseId 0) >>= (`shouldBe` Just [J.toJSON charge]) . fmap (map J.toJSON)
|
|
withTransaction st (`getLedgerTip` purchaseId) >>= (`shouldBe` Just (J.toJSON charge)) . fmap J.toJSON
|
|
|
|
testTransferEntriesRoundTrip :: IO ()
|
|
testTransferEntriesRoundTrip = withServiceStore $ \st -> do
|
|
now <- truncateToSecond <$> getCurrentTime
|
|
(purchaseKey, masterKey) <- newPurchaseKeys
|
|
(otherKey, otherMasterKey) <- newPurchaseKeys
|
|
Just purchaseId <- withTransaction st $ \db ->
|
|
createStorePurchase db NewStorePurchase {paymentId = "pay1", provider = PPApple, providerRef = "2000000812345671", paid = Nothing, purchaseKey, masterKey, badgeType = BTSupporter, subscriptionState = Just SSRenewing, providerToken = Nothing} now
|
|
Just _ <- withTransaction st $ \db ->
|
|
createStorePurchase db NewStorePurchase {paymentId = "pay2", provider = PPApple, providerRef = "2000000812345673", paid = Nothing, purchaseKey = otherKey, masterKey = otherMasterKey, badgeType = BTSupporter, subscriptionState = Just SSRenewing, providerToken = Nothing} now
|
|
let transferIn = grantEntry now "e1" BTSupporter 2 (SCTransferIn otherKey) (emptyEntry now BTSupporter)
|
|
upgrade = debitEntry now "e2" (SDUpgrade purchaseKey) transferIn
|
|
transferOut = debitEntry now "e3" (SDTransferOut otherKey) upgrade
|
|
rows = [transferIn, upgrade, transferOut]
|
|
withTransaction st $ \db -> appendLedgerPlan db purchaseId Nothing rows Nothing
|
|
withTransaction st (\db -> getLedgerEntries db purchaseId 0) >>= (`shouldBe` Just (map J.toJSON rows)) . fmap (map J.toJSON)
|
|
withTransaction st (`getLedgerTip` purchaseId) >>= (`shouldBe` Just (J.toJSON transferOut)) . fmap J.toJSON
|
|
|
|
testUnknownPurchaseKeyRefused :: IO ()
|
|
testUnknownPurchaseKeyRefused = withServiceStore $ \st -> do
|
|
now <- truncateToSecond <$> getCurrentTime
|
|
(purchaseKey, masterKey) <- newPurchaseKeys
|
|
(unknownKey, _) <- newPurchaseKeys
|
|
Just purchaseId <- withTransaction st $ \db ->
|
|
createStorePurchase db NewStorePurchase {paymentId = "pay1", provider = PPApple, providerRef = "2000000812345671", paid = Nothing, purchaseKey, masterKey, badgeType = BTSupporter, subscriptionState = Nothing, providerToken = Nothing} now
|
|
let granted = grantEntry now "e1" BTSupporter 2 SCCode (emptyEntry now BTSupporter)
|
|
withTransaction st $ \db -> appendLedgerPlan db purchaseId Nothing [granted] Nothing
|
|
let upgraded = debitEntry now "e2" (SDUpgrade purchaseKey) granted
|
|
refused <- E.try $ withTransaction st $ \db -> appendLedgerPlan db purchaseId Nothing [upgraded, debitEntry now "e3" (SDTransferOut unknownKey) upgraded] Nothing
|
|
(refused :: Either E.SomeException ()) `shouldSatisfy` isLeft
|
|
withTransaction st (\db -> getLedgerEntries db purchaseId 0) >>= (`shouldBe` Just [J.toJSON granted]) . fmap (map J.toJSON)
|
|
|
|
testPaymentRebind :: IO ()
|
|
testPaymentRebind = withServiceStore $ \st -> do
|
|
now <- truncateToSecond <$> getCurrentTime
|
|
(k2, mk2) <- newPurchaseKeys
|
|
(p1, k1Rows@[_, issued1]) <- chargedStorePurchase st now
|
|
reboundAt st "pay1" `shouldReturn` [Nothing]
|
|
let transferOut = debitEntry now "e3" (SDTransferOut k2) issued1
|
|
charge2 = grantEntry now "e4" BTSupporter 1 (SCCharge "ch1") (emptyEntry now BTSupporter)
|
|
Just issued2 <- pure $ issueEntry now "e5" charge2
|
|
Just p2 <- withTransaction st $ \db -> do
|
|
p2_ <- rebindStorePayment db PaymentRebind {paymentId = "pay1", fromPurchaseId = p1, fromTipId = "e2", fromRows = [transferOut], purchaseKey = k2, masterKey = mk2, badgeType = BTSupporter} now
|
|
forM_ p2_ $ \p2 -> appendLedgerPlan db p2 Nothing [charge2] (Just (charge2, issued2, seededCredential mk2 (balanceStartTs issued2)))
|
|
pure p2_
|
|
withTransaction st (`getLedgerTip` p1) >>= (`shouldBe` Just (J.toJSON transferOut)) . fmap J.toJSON
|
|
withTransaction st (\db -> getLedgerEntries db p1 0) >>= (`shouldBe` Just (map J.toJSON (k1Rows <> [transferOut]))) . fmap (map J.toJSON)
|
|
withTransaction st (\db -> getLedgerEntries db p2 0) >>= (`shouldBe` Just (map J.toJSON [charge2, issued2])) . fmap (map J.toJSON)
|
|
subscriptionPayment st p1 `shouldReturn` Nothing
|
|
subscriptionPayment st p2 `shouldReturn` Just "pay1"
|
|
creditedPurchaseId st `shouldReturn` Just p2
|
|
reboundAt st "pay1" `shouldReturn` [Just now]
|
|
|
|
testPaymentRebindLostRace :: IO ()
|
|
testPaymentRebindLostRace = withServiceStore $ \st -> do
|
|
now <- truncateToSecond <$> getCurrentTime
|
|
(k2, mk2) <- newPurchaseKeys
|
|
(k3, mk3) <- newPurchaseKeys
|
|
(p1, k1Rows@[charge1, issued1]) <- chargedStorePurchase st now
|
|
let rebindTo (k, mk) fromTipId tip = PaymentRebind {paymentId = "pay1", fromPurchaseId = p1, fromTipId, fromRows = [debitEntry now "x" (SDTransferOut k) tip], purchaseKey = k, masterKey = mk, badgeType = BTSupporter}
|
|
k1Entries = withTransaction st (\db -> getLedgerEntries db p1 0) <&> fmap (map J.toJSON)
|
|
withTransaction st (\db -> rebindStorePayment db (rebindTo (k3, mk3) "e1" charge1) now) `shouldReturn` Nothing
|
|
k1Entries `shouldReturn` Just (map J.toJSON k1Rows)
|
|
creditedPurchaseId st `shouldReturn` Just p1
|
|
reboundAt st "pay1" `shouldReturn` [Nothing]
|
|
let transferOut = debitEntry now "x" (SDTransferOut k2) issued1
|
|
Just _ <- withTransaction st $ \db -> rebindStorePayment db (rebindTo (k2, mk2) "e2" issued1) now
|
|
withTransaction st (\db -> rebindStorePayment db (rebindTo (k3, mk3) "x" transferOut) (addUTCTime 60 now)) `shouldReturn` Nothing
|
|
k1Entries `shouldReturn` Just (map J.toJSON (k1Rows <> [transferOut]))
|
|
reboundAt st "pay1" `shouldReturn` [Just now]
|
|
isNothing <$> withTransaction st (`getPurchaseByKey` k3) `shouldReturn` True
|
|
|
|
testMovedFromExpiry :: IO ()
|
|
testMovedFromExpiry = withServiceStore $ \st -> do
|
|
now <- truncateToSecond <$> getCurrentTime
|
|
[(k0, mk0), (k1, mk1), (k2, mk2)] <- replicateM 3 newPurchaseKeys
|
|
let day n = addUTCTime (n * 86400) now
|
|
granted uuid = grantEntry now uuid BTSupporter 1 SCCode (emptyEntry now BTSupporter)
|
|
movedFromExpiry = withTransaction st (`getMovedFromExpiry` "pay1")
|
|
move fromPurchaseId fromTipId (k, mk) tipId =
|
|
withTransaction st $ \db -> do
|
|
Just purchaseId <- rebindStorePayment db PaymentRebind {paymentId = "pay1", fromPurchaseId, fromTipId, fromRows = [debitEntry now (fromTipId <> "-out") (SDTransferOut k) (granted fromTipId)], purchaseKey = k, masterKey = mk, badgeType = BTSupporter} now
|
|
appendLedgerPlan db purchaseId Nothing [granted tipId] Nothing
|
|
pure purchaseId
|
|
Just p0 <- withTransaction st $ \db ->
|
|
createStorePurchase db NewStorePurchase {paymentId = "pay1", provider = PPApple, providerRef = "2000000812345671", paid = Nothing, purchaseKey = k0, masterKey = mk0, badgeType = BTSupporter, subscriptionState = Just SSRenewing, providerToken = Nothing} now
|
|
withTransaction st $ \db -> appendLedgerPlan db p0 Nothing [granted "g0"] Nothing
|
|
seedIssuance st p0 "i0a" mk0 now (day 10)
|
|
seedIssuance st p0 "i0b" mk0 now (day 20)
|
|
movedFromExpiry `shouldReturn` Nothing
|
|
p1 <- move p0 "g0" (k1, mk1) "g1"
|
|
seedIssuance st p1 "i1b" mk1 now (day 40)
|
|
seedIssuance st p1 "i1a" mk1 now (day 30)
|
|
movedFromExpiry `shouldReturn` Just (day 20)
|
|
p2 <- move p1 "g1" (k2, mk2) "g2"
|
|
seedIssuance st p2 "i2a" mk2 now (day 50)
|
|
seedIssuance st p2 "i2b" mk2 now (day 60)
|
|
movedFromExpiry `shouldReturn` Just (day 40)
|
|
|
|
-- A purchase holding payment pay1 (provider ref 2000000812345671), funded by charge ch1, with its month issued as e2.
|
|
chargedStorePurchase :: DBStore -> UTCTime -> IO (Int64, [StatementEntry])
|
|
chargedStorePurchase st now = do
|
|
(purchaseKey, masterKey) <- newPurchaseKeys
|
|
Just purchaseId <- withTransaction st $ \db ->
|
|
createStorePurchase db NewStorePurchase {paymentId = "pay1", provider = PPApple, providerRef = "2000000812345671", paid = Nothing, purchaseKey, masterKey, badgeType = BTSupporter, subscriptionState = Just SSRenewing, providerToken = Nothing} now
|
|
withTransaction st $ \db ->
|
|
insertSubscriptionCharge db "pay1" "ch1" StoreCharge {chargeRef = "2000000812345672", planId = "SUBSCR_BADGE_SUPPORTER_MONTH_01", periodStart = now, periodEnd = addMonths 1 now, chargePaid = Nothing, revoked = False, offer = False} now
|
|
let charge = grantEntry now "e1" BTSupporter 1 (SCCharge "ch1") (emptyEntry now BTSupporter)
|
|
Just issued <- pure $ issueEntry now "e2" charge
|
|
withTransaction st $ \db -> appendLedgerPlan db purchaseId Nothing [charge] (Just (charge, issued, seededCredential masterKey (balanceStartTs issued)))
|
|
pure (purchaseId, [charge, issued])
|
|
|
|
reboundAt :: DBStore -> Text -> IO [Maybe UTCTime]
|
|
reboundAt st paymentId =
|
|
withConnection st $ \db -> map fromOnly <$> DB.query db "SELECT rebound_at FROM sx_badge_service_payments WHERE payment_id = ?" (Only paymentId)
|
|
|
|
subscriptionPayment :: DBStore -> Int64 -> IO (Maybe Text)
|
|
subscriptionPayment st purchaseId =
|
|
fmap (\PurchaseSubscription {paymentId} -> paymentId) <$> withTransaction st (`getPurchaseSubscription` purchaseId)
|
|
|
|
creditedPurchaseId :: DBStore -> IO (Maybe Int64)
|
|
creditedPurchaseId st =
|
|
withTransaction st (\db -> getStorePaymentCredit db PPApple "2000000812345671") <&> \case
|
|
Credited CreditedPurchase {badgePurchaseId} -> Just badgePurchaseId
|
|
_ -> Nothing
|
|
|
|
testManagedGroupRoundTripsAndBootstrapsOnce :: IO ()
|
|
testManagedGroupRoundTripsAndBootstrapsOnce = withServiceStore $ \st -> do
|
|
now <- truncateToSecond <$> getCurrentTime
|
|
beforeInsert <- withTransaction st getManagedGroup
|
|
beforeInsert `shouldBe` Nothing
|
|
withTransaction st $ \db -> insertManagedGroup db 42 "https://link" now
|
|
afterInsert <- withTransaction st getManagedGroup
|
|
afterInsert `shouldBe` Just ManagedGroup {mgGroupId = 42, mgGroupLink = "https://link", mgOwnerBootstrapped = False}
|
|
show afterInsert `shouldNotSatisfy` ("https://link" `isInfixOf`)
|
|
firstMark <- withTransaction st (`markOwnerBootstrapped` 42)
|
|
secondMark <- withTransaction st (`markOwnerBootstrapped` 42)
|
|
(firstMark, secondMark) `shouldBe` (True, False)
|
|
|
|
testManagedGroupIsSingleRow :: IO ()
|
|
testManagedGroupIsSingleRow = withServiceStore $ \st -> do
|
|
now <- truncateToSecond <$> getCurrentTime
|
|
withTransaction st $ \db -> insertManagedGroup db 42 "https://link" now
|
|
withTransaction st $ \db -> insertManagedGroup db 43 "https://other" now
|
|
withTransaction st $ \db -> insertManagedGroup db 42 "https://again" now
|
|
managedGroupRows st `shouldReturn` [(42, "https://link")]
|
|
withTransaction st (`markOwnerBootstrapped` 43) `shouldReturn` False
|
|
(fmap mgOwnerBootstrapped <$> withTransaction st getManagedGroup) `shouldReturn` Just False
|
|
withTransaction st (`markOwnerBootstrapped` 42) `shouldReturn` True
|
|
(fmap mgOwnerBootstrapped <$> withTransaction st getManagedGroup) `shouldReturn` Just True
|
|
|
|
managedGroupRows :: DBStore -> IO [(Int64, Text)]
|
|
managedGroupRows st =
|
|
withConnection st $ \db -> DB.query_ db "SELECT group_id, group_link FROM sx_badge_service_group ORDER BY group_id"
|
|
|
|
insertCode :: DBStore -> ByteString -> BadgeCodePaymentStatus -> Int -> UTCTime -> IO Int64
|
|
insertCode st codeHash paymentStatus redeemLimit now =
|
|
withTransaction st $ \db -> insertBadgeCode db codeHash BTSupporter 1 paymentStatus redeemLimit now
|
|
|
|
claimUse :: DBStore -> Int64 -> UTCTime -> (C.PublicKeyEd25519, BadgeMasterKey) -> IO (Maybe Int64)
|
|
claimUse st badgeCodeId now (purchaseKey, masterKey) =
|
|
withTransaction st $ \db ->
|
|
createCodePurchase db NewCodePurchase {badgeCodeId, purchaseKey, masterKey, badgeType = BTSupporter} now
|
|
|
|
-- The signature is dummy bytes, since only the JSON round-trip is under test; 80 is the length its decoder accepts.
|
|
seededCredential :: BadgeMasterKey -> UTCTime -> BadgeCredential
|
|
seededCredential masterKey expiry =
|
|
BadgeCredential {badgeKeyIdx = 1, masterKey, signature = BBSSignature (BS.replicate 80 7), badgeInfo = BadgeInfo {badgeType = BTSupporter, badgeExpiry = expiry, badgeExtra = ""}}
|
|
|
|
seedIssuance :: DBStore -> Int64 -> Text -> BadgeMasterKey -> UTCTime -> UTCTime -> IO ()
|
|
seedIssuance st purchaseId issuanceId masterKey at periodEnd =
|
|
withConnection st $ \db ->
|
|
DB.execute
|
|
db
|
|
"INSERT INTO sx_badge_service_badge_issuances (issuance_id, badge_purchase_id, badge_type, period_start, period_end, expiry, credential, created_at) VALUES (?,?,?,?,?,?,?,?)"
|
|
(issuanceId, purchaseId, "supporter" :: Text, at, periodEnd, periodEnd, DB.Binary (LB.toStrict (J.encode (seededCredential masterKey periodEnd))), at)
|
|
|
|
testKeyPurchaseLookup :: IO ()
|
|
testKeyPurchaseLookup = withServiceStore $ \st -> do
|
|
now <- getCurrentTime
|
|
let codeHash = digestFixture 41
|
|
badgeCodeId <- insertCode st codeHash CPSFree 2 now
|
|
keys@(k1, mk1) <- newPurchaseKeys
|
|
Just purchaseId <- claimUse st badgeCodeId now keys
|
|
withTransaction st (\db -> getCodePurchaseForKey db badgeCodeId k1) >>= \case
|
|
KeyRedeemedUnreadable -> pure ()
|
|
_ -> expectationFailure "expected a purchase with no issuance to be unreadable"
|
|
let firstPeriodEnd = someExpiry
|
|
renewedPeriodEnd = addUTCTime 86400 someExpiry
|
|
seedIssuance st purchaseId "iss-first" mk1 now firstPeriodEnd
|
|
seedIssuance st purchaseId "iss-renewed" mk1 now renewedPeriodEnd
|
|
(unusedKey, _) <- newPurchaseKeys
|
|
withTransaction st (\db -> getCodePurchaseForKey db badgeCodeId unusedKey) >>= \case
|
|
KeyUnredeemed -> pure ()
|
|
_ -> expectationFailure "expected no purchase for a key that never redeemed"
|
|
replayed <- withTransaction st (\db -> getCodePurchaseForKey db badgeCodeId k1)
|
|
case replayed of
|
|
KeyRedeemed KeyPurchase {badgePurchaseId, credential} -> do
|
|
badgePurchaseId `shouldBe` purchaseId
|
|
credential `shouldBe` seededCredential mk1 renewedPeriodEnd
|
|
_ -> expectationFailure "expected the redeemed key's purchase"
|
|
|
|
testSameKeyClaimsOnce :: IO ()
|
|
testSameKeyClaimsOnce = withServiceStore $ \st -> do
|
|
now <- getCurrentTime
|
|
let codeHash = digestFixture 46
|
|
badgeCodeId <- insertCode st codeHash CPSFree 3 now
|
|
keys <- newPurchaseKeys
|
|
claimUse st badgeCodeId now keys >>= (`shouldSatisfy` isJust)
|
|
-- The key is unique across purchases, so the second insert fails and its transaction returns the use.
|
|
claimUse st badgeCodeId now keys `shouldThrow` anyException
|
|
codeCounts st codeHash `shouldReturn` Just (3, 1)
|
|
|
|
testMultiUseConcurrentClaimsUpToLimit :: IO ()
|
|
testMultiUseConcurrentClaimsUpToLimit = withServiceStore $ \st -> do
|
|
now <- getCurrentTime
|
|
let codeHash = digestFixture 42
|
|
badgeCodeId <- insertCode st codeHash CPSFree 3 now
|
|
contenders <- replicateM 6 newPurchaseKeys
|
|
results <- Async.mapConcurrently (claimUse st badgeCodeId now) contenders
|
|
length (catMaybes results) `shouldBe` 3
|
|
codeCounts st codeHash `shouldReturn` Just (3, 3)
|
|
|
|
data StubCall
|
|
= StubCreate ServicePaymentMethod OrderDraft
|
|
| StubRead Text
|
|
| StubCancel Text
|
|
| StubListOpen
|
|
deriving (Eq, Show)
|
|
|
|
data StubState = StubState
|
|
{ ssCalls :: [StubCall],
|
|
ssCreateResult :: Either ProviderError ProviderInvoice,
|
|
ssInvoices :: Map.Map Text PaymentSignal,
|
|
ssCancelError :: Maybe ProviderError,
|
|
-- The cancel reaches the provider, but its answer is lost.
|
|
ssCancelLost :: Bool,
|
|
ssListError :: Maybe ProviderError,
|
|
ssReadError :: Maybe ProviderError,
|
|
ssSkipped :: [(Maybe Text, Text)],
|
|
ssVerifyResult :: Either WebhookError (Maybe Text),
|
|
ssVerifyThrows :: Bool,
|
|
ssWebhooks :: [([Header], ByteString)],
|
|
ssReadDelay :: Int
|
|
}
|
|
|
|
newStubState :: Either ProviderError ProviderInvoice -> StubState
|
|
newStubState ssCreateResult =
|
|
StubState
|
|
{ ssCalls = [],
|
|
ssCreateResult,
|
|
ssInvoices = Map.empty,
|
|
ssCancelError = Nothing,
|
|
ssCancelLost = False,
|
|
ssListError = Nothing,
|
|
ssReadError = Nothing,
|
|
ssSkipped = [],
|
|
ssVerifyResult = Right Nothing,
|
|
ssVerifyThrows = False,
|
|
ssWebhooks = [],
|
|
ssReadDelay = 0
|
|
}
|
|
|
|
record :: IORef StubState -> StubCall -> IO ()
|
|
record ref call = atomicModifyIORef' ref $ \s -> (s {ssCalls = ssCalls s ++ [call]}, ())
|
|
|
|
stubProvider :: IORef StubState -> Provider
|
|
stubProvider ref =
|
|
Provider
|
|
{ pProvider = PPCrypto,
|
|
pCreateInvoice = \method draft -> do
|
|
record ref (StubCreate method draft)
|
|
ssCreateResult <$> readIORef ref,
|
|
pReadInvoice = \providerRef -> do
|
|
record ref (StubRead providerRef)
|
|
stub <- readIORef ref
|
|
threadDelay (ssReadDelay stub)
|
|
pure $ maybe (Right (Map.lookup providerRef (ssInvoices stub))) Left (ssReadError stub),
|
|
pCancelInvoice = \providerRef -> do
|
|
record ref (StubCancel providerRef)
|
|
lost <- ssCancelLost <$> readIORef ref
|
|
if lost
|
|
then do
|
|
atomicModifyIORef' ref $ \s -> (s {ssInvoices = Map.insert providerRef (SigClosed (rcv 0 Nothing)) (ssInvoices s)}, ())
|
|
pure (Left (ProviderError "the response was lost"))
|
|
else maybe (Right ()) Left . ssCancelError <$> readIORef ref,
|
|
pListOpen = do
|
|
record ref StubListOpen
|
|
stub <- readIORef ref
|
|
pure $ case ssListError stub of
|
|
Just e -> Left e
|
|
Nothing -> Right ListPass {lpMoved = Map.toList (ssInvoices stub), lpSkipped = ssSkipped stub},
|
|
pVerifyWebhook = const (verifyRecording ref)
|
|
}
|
|
|
|
-- | 'pVerifyWebhook' is pure by design, so recording its arguments needs 'unsafePerformIO',
|
|
-- and the NOINLINE effect is safe because every assertion checks an exact list of calls, so a
|
|
-- lost or repeated recording fails the test rather than passing it.
|
|
verifyRecording :: IORef StubState -> [Header] -> ByteString -> Either WebhookError (Maybe Text)
|
|
verifyRecording ref hdrs body = unsafePerformIO $ do
|
|
atomicModifyIORef' ref $ \s -> (s {ssWebhooks = ssWebhooks s ++ [(hdrs, body)]}, ())
|
|
stub <- readIORef ref
|
|
if ssVerifyThrows stub
|
|
then E.throwIO (userError "the adapter threw while verifying")
|
|
else pure (ssVerifyResult stub)
|
|
{-# NOINLINE verifyRecording #-}
|
|
|
|
stubCalls :: IORef StubState -> IO [StubCall]
|
|
stubCalls ref = ssCalls <$> readIORef ref
|
|
|
|
stubWebhooks :: IORef StubState -> IO [([Header], ByteString)]
|
|
stubWebhooks ref = ssWebhooks <$> readIORef ref
|
|
|
|
setVerifyResult :: IORef StubState -> Either WebhookError (Maybe Text) -> IO ()
|
|
setVerifyResult ref r = atomicModifyIORef' ref $ \s -> (s {ssVerifyResult = r}, ())
|
|
|
|
setReadDelay :: IORef StubState -> Int -> IO ()
|
|
setReadDelay ref micros = atomicModifyIORef' ref $ \s -> (s {ssReadDelay = micros}, ())
|
|
|
|
setVerifyThrows :: IORef StubState -> Bool -> IO ()
|
|
setVerifyThrows ref throws = atomicModifyIORef' ref $ \s -> (s {ssVerifyThrows = throws}, ())
|
|
|
|
sampleDraft :: OrderDraft
|
|
sampleDraft = OrderDraft {odAmount = CurrencyAmount 500, odCurrency = "usd"}
|
|
|
|
sampleProviderInvoice :: ProviderInvoice
|
|
sampleProviderInvoice = ProviderInvoice {piProviderRef = "pref-1", piDestination = SPDCrypto CCBtc "bc1qexampleaddress" "0.00050000"}
|
|
|
|
testStubProviderRecordsCalls :: IO ()
|
|
testStubProviderRecordsCalls = do
|
|
ref <- newIORef (newStubState (Right sampleProviderInvoice))
|
|
let provider = stubProvider ref
|
|
created <- pCreateInvoice provider (SPMCrypto CCBtc) sampleDraft
|
|
created `shouldBe` Right sampleProviderInvoice
|
|
let pref = piProviderRef sampleProviderInvoice
|
|
pReadInvoice provider pref `shouldReturn` Right Nothing
|
|
let signal = SigFunded (rcv 500 (Just "0.00050000")) PaidInPart
|
|
atomicModifyIORef' ref $ \s -> (s {ssInvoices = Map.insert pref signal (ssInvoices s)}, ())
|
|
pReadInvoice provider pref `shouldReturn` Right (Just signal)
|
|
pListOpen provider `shouldReturn` Right ListPass {lpMoved = [(pref, signal)], lpSkipped = []}
|
|
calls <- stubCalls ref
|
|
calls `shouldBe` [StubCreate (SPMCrypto CCBtc) sampleDraft, StubRead pref, StubRead pref, StubListOpen]
|
|
|
|
testStubProviderCreateFailsOnDemand :: IO ()
|
|
testStubProviderCreateFailsOnDemand = do
|
|
let err = ProviderError "connection refused"
|
|
ref <- newIORef (newStubState (Left err))
|
|
let provider = stubProvider ref
|
|
pCreateInvoice provider (SPMCrypto CCBtc) sampleDraft `shouldReturn` Left err
|
|
stubCalls ref `shouldReturn` [StubCreate (SPMCrypto CCBtc) sampleDraft]
|
|
|
|
testStubProviderNotCalledWhenSkipped :: IO ()
|
|
testStubProviderNotCalledWhenSkipped = do
|
|
ref <- newIORef (newStubState (Right sampleProviderInvoice))
|
|
stubCalls ref `shouldReturn` []
|
|
|
|
-- | This ceiling is shorter than the 30s hold, so a test that waits when it should not fails
|
|
-- here instead of hanging.
|
|
exampleCeiling :: Int
|
|
exampleCeiling = 20 * 1000000
|
|
|
|
bounded :: HasCallStack => String -> IO a -> IO a
|
|
bounded label action =
|
|
timeout exampleCeiling action >>= maybe (failWith (label <> ": did not finish within 20s")) pure
|
|
|
|
clientTimeout :: Int
|
|
clientTimeout = 60 * 1000000
|
|
|
|
failWith :: HasCallStack => String -> IO a
|
|
failWith msg = expectationFailure msg >> error msg
|
|
|
|
outsideMarker :: LB.ByteString
|
|
outsideMarker = "SECRET-OUTSIDE-STATIC-DIR"
|
|
|
|
shellHtml :: LB.ByteString
|
|
shellHtml = "<!doctype html><title>SimpleX badges</title><meta id=\"stripe-publishable-key\" name=\"stripe-publishable-key\" content=\"\">"
|
|
|
|
assetJs :: LB.ByteString
|
|
assetJs = "export const build = \"d95503da54ee228f\";"
|
|
|
|
workerJs :: LB.ByteString
|
|
workerJs = "self.addEventListener(\"install\", () => {});"
|
|
|
|
buildHash :: FilePath
|
|
buildHash = "d95503da54ee228f"
|
|
|
|
notFoundBody :: LB.ByteString
|
|
notFoundBody = "{\"error\":\"not_found\"}"
|
|
|
|
prepareStaticDir :: FilePath -> IO FilePath
|
|
prepareStaticDir root = do
|
|
let staticDir = root </> "dist"
|
|
assetDir = staticDir </> "assets" </> buildHash
|
|
createDirectoryIfMissing True assetDir
|
|
LB.writeFile (root </> "secret.txt") outsideMarker
|
|
LB.writeFile (staticDir </> "index.html") shellHtml
|
|
LB.writeFile (staticDir </> "sw.js") workerJs
|
|
LB.writeFile (assetDir </> "main.js") assetJs
|
|
createFileLink (".." </> ".." </> "secret.txt") (staticDir </> "assets" </> "escape.txt")
|
|
pure staticDir
|
|
|
|
testServiceConfig :: FilePath -> Bool -> ServiceConfig
|
|
testServiceConfig staticDir trustForwarded =
|
|
ServiceConfig
|
|
{ listener = ListenerConfig {lHost = "127.0.0.1", lPort = 0, lStaticDir = staticDir, lServeWebapp = True, lWebappExportDir = Nothing, lTrustForwardedFor = trustForwarded},
|
|
btcpay = Nothing,
|
|
stripe = Nothing,
|
|
poll = PollConfig {pWaitingSeconds = 3, pIdleSeconds = 60},
|
|
appleStore = Nothing,
|
|
playStore = Nothing,
|
|
issuer = Nothing,
|
|
group = Nothing,
|
|
devAcceptUnverifiedStoreReceipts = False,
|
|
devCheckStoreDuringCoverage = False,
|
|
devCreditTestPurchases = False
|
|
}
|
|
|
|
testServeWebappOff :: IO ()
|
|
testServeWebappOff =
|
|
withServiceStore $ \st -> do
|
|
createDirectoryIfMissing True "tests/tmp"
|
|
withTempDirectory "tests/tmp" "badge-static" $ \root -> do
|
|
staticDir <- prepareStaticDir root
|
|
let base = testServiceConfig staticDir False
|
|
cfg = base {listener = (listener base) {lServeWebapp = False}}
|
|
withListener [] True holdMicros st cfg $ \_env client -> do
|
|
(statusOf <$> webGet client "/") >>= (`shouldBe` 404)
|
|
(statusOf <$> webGet client "/sw.js") >>= (`shouldBe` 404)
|
|
(statusOf <$> webGet client ("/assets/" <> buildHash <> "/main.js")) >>= (`shouldBe` 404)
|
|
created <- webRequest client "POST" "/api/invoice" []
|
|
statusOf created `shouldSatisfy` (\s -> s /= 404 && s /= 405)
|
|
|
|
testExportWebapp :: IO ()
|
|
testExportWebapp = do
|
|
createDirectoryIfMissing True "tests/tmp"
|
|
withTempDirectory "tests/tmp" "badge-export" $ \root -> do
|
|
staticDir <- prepareStaticDir root
|
|
let outDir = root </> "out"
|
|
lc = ListenerConfig {lHost = "127.0.0.1", lPort = 0, lStaticDir = staticDir, lServeWebapp = False, lWebappExportDir = Just outDir, lTrustForwardedFor = False}
|
|
stripeCfg = Just StripeConfig {sSecretKey = "rk_test_x", sPublishableKey = "pk_test_injected", sWebhookSecret = "whsec_x", sSessionMinutes = 60, sHost = "https://api.stripe.com"}
|
|
exportWebapp lc stripeCfg
|
|
idx <- LB.readFile (outDir </> "index.html")
|
|
LB.toStrict idx `shouldSatisfy` BC.isInfixOf "content=\"pk_test_injected\""
|
|
LB.readFile (outDir </> "sw.js") >>= (`shouldBe` workerJs)
|
|
LB.readFile (outDir </> "assets" </> buildHash </> "main.js") >>= (`shouldBe` assetJs)
|
|
|
|
type WebClient = (Manager, String)
|
|
|
|
withWebApp :: (WebEnv -> WebClient -> IO a) -> IO a
|
|
withWebApp = withWebAppWith False True holdMicros
|
|
|
|
withWebAppForwarded :: Bool -> (WebEnv -> WebClient -> IO a) -> IO a
|
|
withWebAppForwarded trustForwarded = withWebAppWith trustForwarded True holdMicros
|
|
|
|
withWebAppHolding :: Int -> (WebEnv -> WebClient -> IO a) -> IO a
|
|
withWebAppHolding hold = withWebAppWith False True hold
|
|
|
|
withWebAppExpectingThrow :: (WebEnv -> WebClient -> IO a) -> IO a
|
|
withWebAppExpectingThrow = withWebAppWith False False holdMicros
|
|
|
|
withWebAppWith :: Bool -> Bool -> Int -> (WebEnv -> WebClient -> IO a) -> IO a
|
|
withWebAppWith trustForwarded rethrow hold action =
|
|
withServiceStore $ \st -> do
|
|
createDirectoryIfMissing True "tests/tmp"
|
|
withTempDirectory "tests/tmp" "badge-static" $ \root -> do
|
|
staticDir <- prepareStaticDir root
|
|
withListener [] rethrow hold st (testServiceConfig staticDir trustForwarded) action
|
|
|
|
withListener :: [Provider] -> Bool -> Int -> DBStore -> ServiceConfig -> (WebEnv -> WebClient -> IO a) -> IO a
|
|
withListener providers rethrow hold st cfg action = do
|
|
let runner = if rethrow then Warp.testWithApplicationSettings else Warp.withApplicationSettings
|
|
waiters <- newWaiters
|
|
hints <- newReadHints
|
|
built <- newWebEnv st cfg waiters hints providers
|
|
let env = built {weHoldMicros = hold}
|
|
mgr <- newManager defaultManagerSettings
|
|
runner (webSettings (listener cfg)) (pure (webApp env)) $ \prt ->
|
|
action env (mgr, "http://127.0.0.1:" <> show prt)
|
|
|
|
webRequest :: WebClient -> ByteString -> String -> [Header] -> IO (Response LB.ByteString)
|
|
webRequest client verb target hdrs = webRequestBody client verb target hdrs ""
|
|
|
|
webRequestBody :: WebClient -> ByteString -> String -> [Header] -> LB.ByteString -> IO (Response LB.ByteString)
|
|
webRequestBody (mgr, base) verb target hdrs body = do
|
|
req <- parseRequest base
|
|
let (rawPath, rawQuery) = break (== '?') target
|
|
httpLbs
|
|
req
|
|
{ method = verb,
|
|
path = BC.pack rawPath,
|
|
queryString = BC.pack rawQuery,
|
|
requestHeaders = hdrs,
|
|
requestBody = RequestBodyLBS body,
|
|
responseTimeout = responseTimeoutMicro clientTimeout
|
|
}
|
|
mgr
|
|
|
|
webGet :: WebClient -> String -> IO (Response LB.ByteString)
|
|
webGet client target = webRequest client "GET" target []
|
|
|
|
statusOf :: Response LB.ByteString -> Int
|
|
statusOf = statusCode . responseStatus
|
|
|
|
headerOf :: Response LB.ByteString -> HeaderName -> Maybe ByteString
|
|
headerOf r name = lookup name (responseHeaders r)
|
|
|
|
jsonObject :: HasCallStack => Response LB.ByteString -> IO J.Object
|
|
jsonObject r = case J.decode (responseBody r) of
|
|
Just (J.Object o) -> pure o
|
|
_ -> failWith ("not a JSON object: " <> LB.unpack (responseBody r))
|
|
|
|
fieldOf :: J.Object -> Text -> Maybe J.Value
|
|
fieldOf o k = KM.lookup (K.fromText k) o
|
|
|
|
timedGet :: WebClient -> String -> IO (NominalDiffTime, Response LB.ByteString)
|
|
timedGet client target = do
|
|
started <- getCurrentTime
|
|
r <- webGet client target
|
|
elapsed <- (`diffUTCTime` started) <$> getCurrentTime
|
|
pure (elapsed, r)
|
|
|
|
seedOpenInvoice :: HasCallStack => WebEnv -> IO InvoiceId
|
|
seedOpenInvoice WebEnv {weStore} = do
|
|
seedBadgePrice weStore "price1"
|
|
createInvoiceRows weStore sampleInvoice `shouldReturn` Right ()
|
|
pure (niInvoiceId sampleInvoice)
|
|
|
|
wokenBy :: HasCallStack => WebClient -> InvoiceId -> IO () -> Text -> IO J.Object
|
|
wokenBy client iid trigger expected = do
|
|
started <- getCurrentTime
|
|
held <- async $ webGet client (invoicePath iid <> "?wait=open")
|
|
threadDelay holdParkDelay
|
|
parked <- Async.poll held
|
|
parked `shouldSatisfy` isNothing
|
|
trigger
|
|
r <- wait held
|
|
elapsed <- (`diffUTCTime` started) <$> getCurrentTime
|
|
statusOf r `shouldBe` 200
|
|
o <- jsonObject r
|
|
fieldOf o "status" `shouldBe` Just (J.String expected)
|
|
elapsed `shouldSatisfy` (< 1)
|
|
pure o
|
|
|
|
-- | This delay is long enough for the request to reach the hold and short enough to keep the
|
|
-- whole check within the one second a woken answer is allowed.
|
|
holdParkDelay :: Int
|
|
holdParkDelay = 100000
|
|
|
|
invoicePath :: InvoiceId -> String
|
|
invoicePath (InvoiceId iid) = "/api/invoice/" <> T.unpack iid
|
|
|
|
markPaidAndPublish :: WebEnv -> InvoiceId -> IO ()
|
|
markPaidAndPublish WebEnv {weStore, weWaiters} iid = do
|
|
markPaid weStore iid
|
|
atomically $ publish weWaiters iid ISPaid
|
|
|
|
expireRow :: DBStore -> InvoiceId -> IO ()
|
|
expireRow st (InvoiceId iid) = withConnection st $ \db ->
|
|
DB.execute db "UPDATE sx_badge_service_invoices SET status = 'expired' WHERE invoice_id = ?" (Only iid)
|
|
|
|
breakStore :: DBStore -> IO ()
|
|
breakStore st = withConnection st $ \db ->
|
|
DB.execute_ db "DROP TABLE sx_badge_service_badge_code_invoices"
|
|
|
|
readsPerMinute :: Int
|
|
readsPerMinute = lmPerMinute readLimit
|
|
|
|
testCachingFollowsTheResolvedPath :: IO ()
|
|
testCachingFollowsTheResolvedPath = bounded "cache by resolved path" $ withWebApp $ \_ client -> do
|
|
asset <- webGet client ("/assets/" <> buildHash <> "/main.js")
|
|
headerOf asset hCacheControl `shouldBe` Just "public, max-age=31536000, immutable"
|
|
shell <- webGet client "/"
|
|
headerOf shell hCacheControl `shouldBe` Just "no-cache"
|
|
escaped <- webGet client ("/assets/" <> buildHash <> "/%2e%2e/%2e%2e/index.html")
|
|
statusOf escaped `shouldBe` 200
|
|
responseBody escaped `shouldBe` shellHtml
|
|
headerOf escaped hCacheControl `shouldBe` Just "no-cache"
|
|
|
|
testShellCarriesPublishableKey :: IO ()
|
|
testShellCarriesPublishableKey = bounded "shell carries the publishable key" $
|
|
withServiceStore $ \st -> do
|
|
createDirectoryIfMissing True "tests/tmp"
|
|
withTempDirectory "tests/tmp" "badge-static" $ \root -> do
|
|
staticDir <- prepareStaticDir root
|
|
let cfg = (testServiceConfig staticDir True) {stripe = Just publishTestStripe}
|
|
withListener [] True holdMicros st cfg $ \_ client -> do
|
|
shell <- webGet client "/"
|
|
statusOf shell `shouldBe` 200
|
|
LB.toStrict (responseBody shell) `shouldSatisfy` BC.isInfixOf "content=\"pk_test_injected\""
|
|
|
|
publishTestStripe :: StripeConfig
|
|
publishTestStripe =
|
|
StripeConfig
|
|
{ sSecretKey = "rk_test_x",
|
|
sPublishableKey = "pk_test_injected",
|
|
sWebhookSecret = "whsec_x",
|
|
sSessionMinutes = 60,
|
|
sHost = "https://api.stripe.com"
|
|
}
|
|
|
|
testServesTheBuild :: IO ()
|
|
testServesTheBuild = bounded "serves the build" $ withWebApp $ \_ client -> do
|
|
shell <- webGet client "/"
|
|
statusOf shell `shouldBe` 200
|
|
responseBody shell `shouldBe` shellHtml
|
|
headerOf shell hContentType `shouldBe` Just "text/html; charset=utf-8"
|
|
asset <- webGet client ("/assets/" <> buildHash <> "/main.js")
|
|
statusOf asset `shouldBe` 200
|
|
responseBody asset `shouldBe` assetJs
|
|
headerOf asset hContentType `shouldBe` Just "text/javascript; charset=utf-8"
|
|
worker <- webGet client "/sw.js"
|
|
statusOf worker `shouldBe` 200
|
|
responseBody worker `shouldBe` workerJs
|
|
headerOf worker hContentType `shouldBe` Just "text/javascript; charset=utf-8"
|
|
headerOf worker hCacheControl `shouldBe` Just "no-cache"
|
|
missing <- webGet client ("/assets/" <> buildHash <> "/absent.js")
|
|
statusOf missing `shouldBe` 404
|
|
|
|
builtSiteDir :: FilePath
|
|
builtSiteDir = "apps" </> "simplex-badge-service" </> "web" </> "dist"
|
|
|
|
testServesBuiltWebApp :: IO ()
|
|
testServesBuiltWebApp = bounded "built web app" $ withServiceStore $ \st -> do
|
|
built <- doesFileExist (builtSiteDir </> "index.html")
|
|
if not built
|
|
then pendingWith ("no web build at " <> builtSiteDir <> ": run `npm run build` in apps/simplex-badge-service/web")
|
|
else withListener [] True holdMicros st (testServiceConfig builtSiteDir False) $ \_ client -> do
|
|
shell <- webGet client "/"
|
|
statusOf shell `shouldBe` 200
|
|
LB.map toLower (LB.take 9 (responseBody shell)) `shouldBe` "<!doctype"
|
|
hashes <- listDirectory (builtSiteDir </> "assets")
|
|
hashes `shouldSatisfy` not . null
|
|
assets <- concat <$> mapM (\h -> map (h </>) <$> listDirectory (builtSiteDir </> "assets" </> h)) hashes
|
|
assets `shouldSatisfy` not . null
|
|
served <- mapM (\a -> (a,) . statusOf <$> webGet client ("/assets/" <> a)) assets
|
|
served `shouldSatisfy` all ((== 200) . snd)
|
|
worker <- webGet client "/sw.js"
|
|
statusOf worker `shouldBe` 200
|
|
responseBody worker `shouldSatisfy` not . LB.null
|
|
|
|
traversalSpellings :: [String]
|
|
traversalSpellings =
|
|
[ "/assets/../secret.txt",
|
|
"/assets/%2e%2e/secret.txt",
|
|
"/assets/%2e%2e%2fsecret.txt",
|
|
"/assets/..%2fsecret.txt",
|
|
"/assets/./../secret.txt",
|
|
"/assets//../secret.txt",
|
|
"/assets/" <> buildHash <> "/../../../secret.txt",
|
|
"/assets/%2e%2e%2f%2e%2e%2fsecret.txt",
|
|
"/assets/%2fetc%2fpasswd",
|
|
"/assets/%00/../secret.txt",
|
|
"/assets/escape.txt",
|
|
"/%2e%2e%2fsecret.txt"
|
|
]
|
|
|
|
testTraversalRefused :: IO ()
|
|
testTraversalRefused = bounded "traversal" $ withWebApp $ \_ client -> do
|
|
control <- webGet client ("/assets/" <> buildHash <> "/main.js")
|
|
statusOf control `shouldBe` 200
|
|
mapM_
|
|
( \target -> do
|
|
r <- webGet client target
|
|
(target, statusOf r) `shouldBe` (target, 404)
|
|
(target, responseBody r) `shouldBe` (target, notFoundBody)
|
|
)
|
|
traversalSpellings
|
|
|
|
testInvoiceView :: IO ()
|
|
testInvoiceView = bounded "invoice view" $ withWebApp $ \env client -> do
|
|
iid <- seedOpenInvoice env
|
|
r <- webGet client (invoicePath iid)
|
|
statusOf r `shouldBe` 200
|
|
headerOf r hContentType `shouldBe` Just "application/json"
|
|
o <- jsonObject r
|
|
sort (map K.toText (KM.keys o))
|
|
`shouldBe` sort ["status", "badgeType", "months", "amount", "currency", "expiresAt", "address", "cryptoAmount", "cryptoCurrency"]
|
|
fieldOf o "status" `shouldBe` Just (J.String "open")
|
|
fieldOf o "badgeType" `shouldBe` Just (J.String "supporter")
|
|
fieldOf o "months" `shouldBe` Just (J.Number 1)
|
|
fieldOf o "amount" `shouldBe` Just (J.Number 500)
|
|
fieldOf o "currency" `shouldBe` Just (J.String "usd")
|
|
fieldOf o "address" `shouldBe` Just (J.String "bc1qexampleaddress")
|
|
fieldOf o "cryptoAmount" `shouldBe` Just (J.String "0.00050000")
|
|
fieldOf o "cryptoCurrency" `shouldBe` Just (J.String "btc")
|
|
case fieldOf o "expiresAt" of
|
|
Just (J.String t) -> T.unpack t `shouldStartWith` "2030-01-01T00:00:00"
|
|
other -> expectationFailure ("expiresAt is " <> show other)
|
|
settle (weStore env) iid (SigSettled (rcv 500 (Just "0.00050000")) settleAt) detectedAt `shouldReturn` Right ISPaid
|
|
settled <- webGet client (invoicePath iid)
|
|
po <- jsonObject settled
|
|
fieldOf po "status" `shouldBe` Just (J.String "paid")
|
|
fieldOf po "settledAt" `shouldBe` Just (J.toJSON settleAt)
|
|
fieldOf po "amountPaid" `shouldBe` Just (J.Number 500)
|
|
fieldOf po "cryptoAmountPaid" `shouldBe` Just (J.String "0.00050000")
|
|
fieldOf po "clientSecret" `shouldBe` Nothing
|
|
|
|
testUnknownInvoiceIsOpaque :: IO ()
|
|
testUnknownInvoiceIsOpaque = bounded "unknown id" $ withWebApp $ \env client -> do
|
|
iid <- seedOpenInvoice env
|
|
guessed <- webGet client "/api/invoice/no-such-invoice"
|
|
statusOf guessed `shouldBe` 404
|
|
responseBody guessed `shouldBe` notFoundBody
|
|
nearMiss <- webGet client (invoicePath iid <> "x")
|
|
statusOf nearMiss `shouldBe` 404
|
|
responseBody nearMiss `shouldBe` responseBody guessed
|
|
|
|
testApiIsNeverCached :: IO ()
|
|
testApiIsNeverCached = bounded "no-store" $ withWebApp $ \env client -> do
|
|
iid <- seedOpenInvoice env
|
|
ok <- webGet client (invoicePath iid)
|
|
statusOf ok `shouldBe` 200
|
|
headerOf ok hCacheControl `shouldBe` Just "no-store"
|
|
missing <- webGet client "/api/invoice/no-such-invoice"
|
|
statusOf missing `shouldBe` 404
|
|
headerOf missing hCacheControl `shouldBe` Just "no-store"
|
|
refused <- exhaustReadLimit client "/api/invoice/no-such-invoice" []
|
|
statusOf refused `shouldBe` 429
|
|
headerOf refused hCacheControl `shouldBe` Just "no-store"
|
|
|
|
exhaustReadLimit :: HasCallStack => WebClient -> String -> [Header] -> IO (Response LB.ByteString)
|
|
exhaustReadLimit client target hdrs = go (readsPerMinute + 5)
|
|
where
|
|
go :: Int -> IO (Response LB.ByteString)
|
|
go 0 = failWith ("no read of " <> target <> " was refused within 65 requests")
|
|
go n = do
|
|
r <- webRequest client "GET" target hdrs
|
|
if statusOf r == 429 then pure r else go (n - 1)
|
|
|
|
testWrongMethodIs405 :: IO ()
|
|
testWrongMethodIs405 = bounded "wrong method" $ withWebApp $ \env client -> do
|
|
iid <- seedOpenInvoice env
|
|
postShell <- webRequest client "POST" "/" []
|
|
statusOf postShell `shouldBe` 405
|
|
headerOf postShell "Allow" `shouldBe` Just "GET"
|
|
postWorker <- webRequest client "POST" "/sw.js" []
|
|
statusOf postWorker `shouldBe` 405
|
|
deleteInvoice <- webRequest client "DELETE" (invoicePath iid) []
|
|
statusOf deleteInvoice `shouldBe` 405
|
|
headerOf deleteInvoice hCacheControl `shouldBe` Just "no-store"
|
|
getCreate <- webRequest client "GET" "/api/invoice" []
|
|
statusOf getCreate `shouldBe` 405
|
|
headerOf getCreate "Allow" `shouldBe` Just "POST"
|
|
|
|
testUnroutedPathIs404 :: IO ()
|
|
testUnroutedPathIs404 = bounded "unrouted" $ withWebApp $ \_ client -> do
|
|
nowhere <- webGet client "/nowhere"
|
|
statusOf nowhere `shouldBe` 404
|
|
responseBody nowhere `shouldBe` notFoundBody
|
|
webhook <- webRequest client "POST" "/webhooks/btcpay" []
|
|
statusOf webhook `shouldBe` 400
|
|
responseBody webhook `shouldBe` ""
|
|
wrongMethod <- webGet client "/webhooks/btcpay"
|
|
statusOf wrongMethod `shouldBe` 405
|
|
headerOf wrongMethod "Allow" `shouldBe` Just "POST"
|
|
|
|
testWaitAnswersAtOnce :: IO ()
|
|
testWaitAnswersAtOnce = bounded "wait answers at once" $ withWebApp $ \env client -> do
|
|
iid <- seedOpenInvoice env
|
|
(staleElapsed, stale) <- timedGet client (invoicePath iid <> "?wait=expired")
|
|
statusOf stale `shouldBe` 200
|
|
staleObject <- jsonObject stale
|
|
fieldOf staleObject "status" `shouldBe` Just (J.String "open")
|
|
staleElapsed `shouldSatisfy` (< 1)
|
|
(junkElapsed, junk) <- timedGet client (invoicePath iid <> "?wait=not-a-status")
|
|
junkObject <- jsonObject junk
|
|
fieldOf junkObject "status" `shouldBe` Just (J.String "open")
|
|
junkElapsed `shouldSatisfy` (< 1)
|
|
markPaid (weStore env) iid
|
|
(terminalElapsed, terminalR) <- timedGet client (invoicePath iid <> "?wait=paid")
|
|
terminalObject <- jsonObject terminalR
|
|
fieldOf terminalObject "status" `shouldBe` Just (J.String "paid")
|
|
terminalElapsed `shouldSatisfy` (< 1)
|
|
|
|
testHoldAnswersAPaymentThePageHasNotSeen :: IO ()
|
|
testHoldAnswersAPaymentThePageHasNotSeen = bounded "hold sees the payment" $ withWebApp $ \env client -> do
|
|
iid <- seedOpenInvoice env
|
|
settle (weStore env) iid (SigFunded (rcv 200 (Just "0.00020000")) PaidInPart) settleAt `shouldReturn` Right ISOpen
|
|
(staleElapsed, stale) <- timedGet client (invoicePath iid <> "?wait=open&seenPaid=")
|
|
statusOf stale `shouldBe` 200
|
|
staleElapsed `shouldSatisfy` (< 1)
|
|
staleObject <- jsonObject stale
|
|
fieldOf staleObject "cryptoAmountPaid" `shouldBe` Just (J.String "0.00020000")
|
|
held <- async $ webGet client (invoicePath iid <> "?wait=open&seenPaid=0.00020000")
|
|
threadDelay 100000
|
|
Async.poll held >>= (`shouldSatisfy` isNothing)
|
|
markPaidAndPublish env iid
|
|
statusOf <$> wait held `shouldReturn` 200
|
|
|
|
testHoldAnswersAVerdictWithNoFigure :: IO ()
|
|
testHoldAnswersAVerdictWithNoFigure = bounded "hold sees the verdict" $ withWebApp $ \env client -> do
|
|
iid <- seedOpenInvoice env
|
|
settle (weStore env) iid (SigFunded (rcv 0 Nothing) PaidInFull) settleAt `shouldReturn` Right ISOpen
|
|
(elapsed, r) <- timedGet client (invoicePath iid <> "?wait=open&seenPaid=&seenFull=0")
|
|
statusOf r `shouldBe` 200
|
|
elapsed `shouldSatisfy` (< 1)
|
|
o <- jsonObject r
|
|
fieldOf o "paidInFull" `shouldBe` Just (J.Bool True)
|
|
fieldOf o "cryptoAmountPaid" `shouldBe` Nothing
|
|
held <- async $ webGet client (invoicePath iid <> "?wait=open&seenPaid=&seenFull=1")
|
|
threadDelay 100000
|
|
Async.poll held >>= (`shouldSatisfy` isNothing)
|
|
markPaidAndPublish env iid
|
|
statusOf <$> wait held `shouldReturn` 200
|
|
|
|
testHoldIsWokenNotPolled :: IO ()
|
|
testHoldIsWokenNotPolled = bounded "hold is woken" $ withWebApp $ \env client -> do
|
|
iid <- seedOpenInvoice env
|
|
_ <- wokenBy client iid (markPaidAndPublish env iid) "paid"
|
|
pure ()
|
|
|
|
testReadRateLimit :: IO ()
|
|
testReadRateLimit = bounded "read rate limit" $ withWebApp $ \_ client -> do
|
|
let target = "/api/invoice/no-such-invoice"
|
|
allowed <- mapM (\_ -> statusOf <$> webGet client target) [1 .. readsPerMinute]
|
|
allowed `shouldSatisfy` all (== 404)
|
|
refused <- webGet client target
|
|
statusOf refused `shouldBe` 429
|
|
responseBody refused `shouldBe` "{\"error\":\"rate_limited\"}"
|
|
case headerOf refused "Retry-After" >>= (readMaybe . BC.unpack) of
|
|
Just seconds -> seconds `shouldSatisfy` \s -> s >= (1 :: Int) && s <= 60
|
|
Nothing -> expectationFailure ("Retry-After is " <> show (headerOf refused "Retry-After"))
|
|
|
|
testForwardedForOnlyWhenTrusted :: IO ()
|
|
testForwardedForOnlyWhenTrusted = bounded "forwarded-for" $ do
|
|
let target = "/api/invoice/no-such-invoice"
|
|
forgedBy i = ("X-Forwarded-For", BC.pack ("203.0.113." <> show (i :: Int)) <> ", 10.0.0.1")
|
|
proxiedFor i = ("X-Forwarded-For", BC.pack ("10.0.0." <> show (i :: Int)))
|
|
withWebApp $ \_ client -> do
|
|
forged <- mapM (\i -> statusOf <$> webRequest client "GET" target [forgedBy i]) [1 .. readsPerMinute]
|
|
forged `shouldSatisfy` all (== 404)
|
|
refused <- webRequest client "GET" target [forgedBy (readsPerMinute + 1)]
|
|
statusOf refused `shouldBe` 429
|
|
withWebAppForwarded True $ \_ client -> do
|
|
forged <- mapM (\i -> statusOf <$> webRequest client "GET" target [forgedBy i]) [1 .. readsPerMinute]
|
|
forged `shouldSatisfy` all (== 404)
|
|
refused <- webRequest client "GET" target [forgedBy (readsPerMinute + 1)]
|
|
statusOf refused `shouldBe` 429
|
|
withWebAppForwarded True $ \_ client -> do
|
|
first' <- mapM (\_ -> statusOf <$> webRequest client "GET" target [proxiedFor 1]) [1 .. readsPerMinute]
|
|
first' `shouldSatisfy` all (== 404)
|
|
statusOf <$> webRequest client "GET" target [proxiedFor 1] `shouldReturn` 429
|
|
statusOf <$> webRequest client "GET" target [proxiedFor 2] `shouldReturn` 404
|
|
|
|
testForwardedForMustBeAnAddress :: IO ()
|
|
testForwardedForMustBeAnAddress = bounded "forwarded-for is an address" $ withWebAppForwarded True $ \_ client -> do
|
|
let target = "/api/invoice/no-such-invoice"
|
|
forged i = ("X-Forwarded-For", BC.pack ("not-an-address-" <> show (i :: Int)))
|
|
minted <- mapM (\i -> statusOf <$> webRequest client "GET" target [forged i]) [1 .. readsPerMinute]
|
|
minted `shouldSatisfy` all (== 404)
|
|
refused <- webRequest client "GET" target [forged (readsPerMinute + 1)]
|
|
statusOf refused `shouldBe` 429
|
|
mapM_
|
|
( \v -> do
|
|
r <- webRequest client "GET" target [("X-Forwarded-For", v)]
|
|
(v, statusOf r) `shouldBe` (v, 429)
|
|
)
|
|
["", "not-an-address", "010.0.0.1", "1.2.3.4.5", "256.1.1.1", "1.2.3", "::1%eth0", "1:2:3:4:5:6:7", "[2001:db8::1]", "1.2.3.4:5678", "gggg::1", "12345::1"]
|
|
mapM_
|
|
( \v -> do
|
|
r <- webRequest client "GET" target [("X-Forwarded-For", v)]
|
|
(v, statusOf r) `shouldBe` (v, 404)
|
|
)
|
|
["192.0.2.7", "2001:db8::1", "::1", "::", "::ffff:192.0.2.1", "1:2:3:4:5:6:7:8"]
|
|
|
|
testBucketsStayBounded :: IO ()
|
|
testBucketsStayBounded = bounded "bucket cap" $ withWebApp $ \env _ -> do
|
|
let clients = map (\i -> T.pack ("198.51." <> show (i `div` 256) <> "." <> show (i `mod` 256))) [1 .. maxBuckets * 2 + 100]
|
|
mapM_ (takeToken env readLimit) clients
|
|
held <- Map.size <$> readTVarIO (weBuckets env)
|
|
held `shouldSatisfy` \n -> n > 0 && n <= maxBuckets
|
|
answers <- mapM (\_ -> takeToken env readLimit "203.0.113.9") [1 .. readsPerMinute + 1]
|
|
length (filter isJust answers) `shouldBe` 1
|
|
|
|
let fill i = do
|
|
n <- Map.size <$> readTVarIO (weBuckets env)
|
|
when (n < maxBuckets) $ do
|
|
_ <- takeToken env readLimit (T.pack ("192.0." <> show (i `div` 256) <> "." <> show (i `mod` 256)))
|
|
fill (i + 1)
|
|
fill (1 :: Int)
|
|
atTheCap <- Map.size <$> readTVarIO (weBuckets env)
|
|
atTheCap `shouldBe` maxBuckets
|
|
refusedAgain <- takeToken env readLimit "203.0.113.9"
|
|
refusedAgain `shouldSatisfy` isJust
|
|
afterARefusal <- Map.size <$> readTVarIO (weBuckets env)
|
|
afterARefusal `shouldSatisfy` (<= atTheCap `div` 2 + 1)
|
|
|
|
testHoldReportsTheRowNotTheWake :: IO ()
|
|
testHoldReportsTheRowNotTheWake = bounded "hold reports the row" $ withWebApp $ \env client -> do
|
|
iid <- seedOpenInvoice env
|
|
held <- async $ webGet client (invoicePath iid <> "?wait=open")
|
|
threadDelay 100000
|
|
markPaid (weStore env) iid
|
|
atomically $ publish (weWaiters env) iid ISExpired
|
|
r <- wait held
|
|
statusOf r `shouldBe` 200
|
|
o <- jsonObject r
|
|
fieldOf o "status" `shouldBe` Just (J.String "paid")
|
|
|
|
testHold :: Int
|
|
testHold = 2000000
|
|
|
|
awaitWaitingCount :: WebEnv -> Int -> IO ()
|
|
awaitWaitingCount env n = do
|
|
parked <- waitingCount (weWaiters env)
|
|
when (parked /= n) $ threadDelay 10000 >> awaitWaitingCount env n
|
|
|
|
testHoldTimeoutReportsAnUnpublishedChange :: IO ()
|
|
testHoldTimeoutReportsAnUnpublishedChange = bounded "hold timeout" $ withWebAppHolding testHold $ \env client -> do
|
|
iid <- seedOpenInvoice env
|
|
started <- getCurrentTime
|
|
held <- async $ webGet client (invoicePath iid <> "?wait=open")
|
|
awaitWaitingCount env 1
|
|
threadDelay 50000
|
|
expireRow (weStore env) iid
|
|
r <- wait held
|
|
elapsed <- (`diffUTCTime` started) <$> getCurrentTime
|
|
statusOf r `shouldBe` 200
|
|
o <- jsonObject r
|
|
fieldOf o "status" `shouldBe` Just (J.String "expired")
|
|
elapsed `shouldSatisfy` (>= 1.95)
|
|
|
|
testHandlerExceptionIsContained :: IO ()
|
|
testHandlerExceptionIsContained = bounded "handler exception" $ withWebAppExpectingThrow $ \env client -> do
|
|
iid <- seedOpenInvoice env
|
|
breakStore (weStore env)
|
|
r <- webGet client (invoicePath iid)
|
|
statusOf r `shouldBe` 500
|
|
responseBody r `shouldBe` "{\"error\":\"internal\"}"
|
|
headerOf r hCacheControl `shouldBe` Just "no-store"
|
|
shell <- webGet client "/"
|
|
statusOf shell `shouldBe` 200
|
|
responseBody shell `shouldBe` shellHtml
|
|
|
|
createsPerMinute :: Int
|
|
createsPerMinute = 5
|
|
|
|
testExpiryMinutes :: Int
|
|
testExpiryMinutes = 45
|
|
|
|
testBTCPayConfig :: BTCPayConfig
|
|
testBTCPayConfig =
|
|
BTCPayConfig
|
|
{ bHost = "https://btcpay.example",
|
|
bApiKey = "api-key",
|
|
bStoreId = "store-id",
|
|
bWebhookSecret = "webhook-secret",
|
|
bExpiryMinutes = testExpiryMinutes,
|
|
bSpeedPolicy = MediumSpeed,
|
|
bPaymentTolerance = 0.5
|
|
}
|
|
|
|
supporterPriceId, legendPriceId, disabledPriceId :: Text
|
|
supporterPriceId = "price-supporter"
|
|
legendPriceId = "price-legend"
|
|
disabledPriceId = "price-retired"
|
|
|
|
anyPriceOfferId, legendOnlyOfferId, disabledOfferId :: Text
|
|
anyPriceOfferId = "offer-3m"
|
|
legendOnlyOfferId = "offer-3m-legend"
|
|
disabledOfferId = "offer-retired"
|
|
|
|
seedCheckoutCatalog :: DBStore -> IO ()
|
|
seedCheckoutCatalog st = do
|
|
insertPrice st supporterPriceId "supporter" 500 "active"
|
|
insertPrice st legendPriceId "legend" 2000 "active"
|
|
insertPrice st disabledPriceId "supporter" 500 "disabled"
|
|
insertOffer st anyPriceOfferId Nothing 3 10 "active"
|
|
insertOffer st legendOnlyOfferId (Just legendPriceId) 3 10 "active"
|
|
insertOffer st disabledOfferId Nothing 3 10 "disabled"
|
|
|
|
codeDigest :: Text -> ByteString
|
|
codeDigest = C.sha256Hash . encodeUtf8
|
|
|
|
codeHashText :: Text -> Text
|
|
codeHashText = T.filter (/= '=') . safeDecodeUtf8 . B64U.encode . codeDigest
|
|
|
|
sampleCode :: Text
|
|
sampleCode = "YDC8AYGQTMPUYZ92TUXP"
|
|
|
|
createBody :: Text -> Maybe Text -> Text -> Text -> LB.ByteString
|
|
createBody priceId offerId method codeHash =
|
|
J.encode . J.object $
|
|
["priceId" .= priceId, "method" .= method, "codeHash" .= codeHash]
|
|
<> maybe [] (\o -> ["offerId" .= o]) offerId
|
|
|
|
postCreateAs :: WebClient -> Int -> LB.ByteString -> IO (Response LB.ByteString)
|
|
postCreateAs client i body =
|
|
webRequestBody
|
|
client
|
|
"POST"
|
|
"/api/invoice"
|
|
[(hContentType, "application/json"), ("X-Forwarded-For", BC.pack ("203.0.113." <> show i))]
|
|
body
|
|
|
|
withCheckout :: (IORef StubState -> WebEnv -> WebClient -> IO a) -> IO a
|
|
withCheckout = withCheckoutProvider stubProvider
|
|
|
|
withCheckoutProvider :: (IORef StubState -> Provider) -> (IORef StubState -> WebEnv -> WebClient -> IO a) -> IO a
|
|
withCheckoutProvider mkProvider action =
|
|
withServiceStore $ \st -> do
|
|
createDirectoryIfMissing True "tests/tmp"
|
|
withTempDirectory "tests/tmp" "badge-checkout" $ \root -> do
|
|
staticDir <- prepareStaticDir root
|
|
seedCheckoutCatalog st
|
|
ref <- newIORef (newStubState (Right sampleProviderInvoice))
|
|
let cfg = (testServiceConfig staticDir True) {btcpay = Just testBTCPayConfig}
|
|
withListener [mkProvider ref] True holdMicros st cfg (action ref)
|
|
|
|
invoiceCount :: DBStore -> IO Int
|
|
invoiceCount st = withConnection st $ \db -> do
|
|
rows <- DB.query_ db "SELECT COUNT(*) FROM sx_badge_service_invoices" :: IO [Only Int]
|
|
pure $ case rows of
|
|
(Only n : _) -> n
|
|
[] -> 0
|
|
|
|
plantCodeHash :: DBStore -> Text -> IO ()
|
|
plantCodeHash st code = withConnection st $ \db ->
|
|
DB.execute
|
|
db
|
|
"INSERT INTO sx_badge_service_badge_codes (code_hash, badge_type, months, code_payment_status, created_at) VALUES (?,?,?,?,?)"
|
|
(DB.Binary (codeDigest code), "supporter" :: Text, 1 :: Int, "unpaid" :: Text, "2026-08-31T00:00:00Z" :: Text)
|
|
|
|
stringField :: HasCallStack => J.Object -> Text -> IO Text
|
|
stringField o k = case fieldOf o k of
|
|
Just (J.String t) -> pure t
|
|
other -> failWith (T.unpack k <> " is " <> show other)
|
|
|
|
errorBody :: Text -> LB.ByteString
|
|
errorBody code = "{\"error\":\"" <> LB.pack (T.unpack code) <> "\"}"
|
|
|
|
testCreateInvoice :: IO ()
|
|
testCreateInvoice = bounded "create invoice" $ withCheckout $ \ref env client -> do
|
|
started <- getCurrentTime
|
|
r <- postCreateAs client 1 (createBody supporterPriceId Nothing "btc" (codeHashText sampleCode))
|
|
statusOf r `shouldBe` 200
|
|
headerOf r hContentType `shouldBe` Just "application/json"
|
|
headerOf r hCacheControl `shouldBe` Just "no-store"
|
|
o <- jsonObject r
|
|
sort (map K.toText (KM.keys o))
|
|
`shouldBe` sort ["invoiceId", "badgeType", "months", "amount", "currency", "expiresAt", "address", "cryptoAmount", "cryptoCurrency"]
|
|
fieldOf o "badgeType" `shouldBe` Just (J.String "supporter")
|
|
fieldOf o "months" `shouldBe` Just (J.Number 1)
|
|
fieldOf o "amount" `shouldBe` Just (J.Number 500)
|
|
fieldOf o "currency" `shouldBe` Just (J.String "usd")
|
|
fieldOf o "address" `shouldBe` Just (J.String "bc1qexampleaddress")
|
|
fieldOf o "cryptoAmount" `shouldBe` Just (J.String "0.00050000")
|
|
fieldOf o "cryptoCurrency" `shouldBe` Just (J.String "btc")
|
|
invId <- InvoiceId <$> stringField o "invoiceId"
|
|
Just row <- getInvoice (weStore env) invId
|
|
irStatus row `shouldBe` ISOpen
|
|
irProvider row `shouldBe` PPCrypto
|
|
irProviderRef row `shouldBe` piProviderRef sampleProviderInvoice
|
|
irBadgeType row `shouldBe` BTSupporter
|
|
irMonths row `shouldBe` 1
|
|
irPrice row `shouldBe` CurrencyAmount 500
|
|
irAmount row `shouldBe` CurrencyAmount 500
|
|
irDestination row `shouldBe` piDestination sampleProviderInvoice
|
|
codeRow <- settledCode (weStore env) invId
|
|
bcPaymentStatus codeRow `shouldBe` CPSUnpaid
|
|
fieldOf o "expiresAt" `shouldBe` Just (J.toJSON (irExpiresAt row))
|
|
diffUTCTime (irExpiresAt row) started `shouldSatisfy` \d -> d > 44 * 60 && d <= 46 * 60
|
|
calls <- stubCalls ref
|
|
case calls of
|
|
[StubCreate method draft] -> do
|
|
method `shouldBe` SPMCrypto CCBtc
|
|
odAmount draft `shouldBe` CurrencyAmount 500
|
|
odCurrency draft `shouldBe` "usd"
|
|
other -> expectationFailure ("provider calls: " <> show other)
|
|
|
|
testXmrReachesTheProviderAsXmr :: IO ()
|
|
testXmrReachesTheProviderAsXmr = bounded "xmr is xmr" $ withCheckout $ \ref _ client -> do
|
|
r <- postCreateAs client 1 (createBody supporterPriceId Nothing "xmr" (codeHashText sampleCode))
|
|
statusOf r `shouldBe` 200
|
|
stubCalls ref >>= \case
|
|
[StubCreate method _] -> method `shouldBe` SPMCrypto CCXmr
|
|
other -> expectationFailure ("provider calls: " <> show other)
|
|
|
|
testCreateCarriesNoCode :: IO ()
|
|
testCreateCarriesNoCode = bounded "no code in the response" $ withCheckout $ \_ env client -> do
|
|
let hashText = codeHashText sampleCode
|
|
r <- postCreateAs client 1 (createBody supporterPriceId Nothing "btc" hashText)
|
|
statusOf r `shouldBe` 200
|
|
let raw = LB.unpack (responseBody r)
|
|
raw `shouldNotContain` T.unpack sampleCode
|
|
raw `shouldNotContain` T.unpack hashText
|
|
raw `shouldNotContain` T.unpack supporterPriceId
|
|
raw `shouldContain` "invoiceId"
|
|
invoiceCount (weStore env) `shouldReturn` 1
|
|
|
|
testCreateDerivesFromCatalog :: IO ()
|
|
testCreateDerivesFromCatalog = bounded "derived from the catalog" $ withCheckout $ \_ env client -> do
|
|
let tampered =
|
|
J.encode $
|
|
J.object
|
|
[ "priceId" .= legendPriceId,
|
|
"offerId" .= anyPriceOfferId,
|
|
"method" .= ("btc" :: Text),
|
|
"codeHash" .= codeHashText sampleCode,
|
|
"badgeType" .= ("supporter" :: Text),
|
|
"months" .= (1 :: Int),
|
|
"amount" .= (500 :: Int)
|
|
]
|
|
r <- postCreateAs client 1 tampered
|
|
statusOf r `shouldBe` 200
|
|
o <- jsonObject r
|
|
fieldOf o "badgeType" `shouldBe` Just (J.String "legend")
|
|
fieldOf o "months" `shouldBe` Just (J.Number 3)
|
|
fieldOf o "amount" `shouldBe` Just (J.Number 5400)
|
|
invId <- InvoiceId <$> stringField o "invoiceId"
|
|
Just row <- getInvoice (weStore env) invId
|
|
irBadgeType row `shouldBe` BTLegend
|
|
irMonths row `shouldBe` 3
|
|
irPrice row `shouldBe` CurrencyAmount 6000
|
|
irAmount row `shouldBe` CurrencyAmount 5400
|
|
|
|
testCatalogRefusalCostsNothing :: IO ()
|
|
testCatalogRefusalCostsNothing = bounded "catalog refusals" $ withCheckout $ \ref env client -> do
|
|
let cases :: [(String, Text, Maybe Text)]
|
|
cases =
|
|
[ ("an unknown price", "price-that-never-existed", Nothing),
|
|
("a disabled price", disabledPriceId, Nothing),
|
|
("an unknown offer", supporterPriceId, Just "offer-that-never-existed"),
|
|
("a disabled offer", supporterPriceId, Just disabledOfferId),
|
|
("an offer belonging to another price", supporterPriceId, Just legendOnlyOfferId)
|
|
]
|
|
mapM_
|
|
( \(i, (label, priceId, offerId)) -> do
|
|
r <- postCreateAs client i (createBody priceId offerId "btc" (codeHashText sampleCode))
|
|
(label, statusOf r) `shouldBe` (label, 400)
|
|
(label, responseBody r) `shouldBe` (label, errorBody "catalog_changed")
|
|
)
|
|
(zip [30 ..] cases)
|
|
stubCalls ref `shouldReturn` []
|
|
invoiceCount (weStore env) `shouldReturn` 0
|
|
|
|
testCodeConflictCostsNothing :: IO ()
|
|
testCodeConflictCostsNothing = bounded "code conflict" $ withCheckout $ \ref env client -> do
|
|
first <- postCreateAs client 1 (createBody supporterPriceId Nothing "btc" (codeHashText sampleCode))
|
|
statusOf first `shouldBe` 200
|
|
sold <- stubCalls ref
|
|
length sold `shouldBe` 1
|
|
again <- postCreateAs client 2 (createBody supporterPriceId Nothing "btc" (codeHashText sampleCode))
|
|
statusOf again `shouldBe` 409
|
|
responseBody again `shouldBe` errorBody "code_conflict"
|
|
stubCalls ref `shouldReturn` sold
|
|
invoiceCount (weStore env) `shouldReturn` 1
|
|
|
|
testRacingCodeHashIsConflict :: IO ()
|
|
testRacingCodeHashIsConflict = bounded "racing code hash" $ do
|
|
planted <- newIORef (Nothing :: Maybe DBStore)
|
|
let racing ref =
|
|
let stub = stubProvider ref
|
|
in stub
|
|
{ pCreateInvoice = \method draft -> do
|
|
readIORef planted >>= mapM_ (`plantCodeHash` sampleCode)
|
|
pCreateInvoice stub method draft
|
|
}
|
|
withCheckoutProvider racing $ \ref env client -> do
|
|
atomicModifyIORef' planted (const (Just (weStore env), ()))
|
|
r <- postCreateAs client 1 (createBody supporterPriceId Nothing "btc" (codeHashText sampleCode))
|
|
statusOf r `shouldBe` 409
|
|
responseBody r `shouldBe` errorBody "code_conflict"
|
|
length <$> stubCalls ref `shouldReturn` 1
|
|
invoiceCount (weStore env) `shouldReturn` 0
|
|
|
|
testStoreLostAfterTheProviderCreated :: IO ()
|
|
testStoreLostAfterTheProviderCreated = bounded "orphan at the provider" $ do
|
|
broken <- newIORef (Nothing :: Maybe DBStore)
|
|
let losing ref =
|
|
let stub = stubProvider ref
|
|
in stub
|
|
{ pCreateInvoice = \method draft -> do
|
|
readIORef broken >>= mapM_ breakStore
|
|
pCreateInvoice stub method draft
|
|
}
|
|
withCheckoutProvider losing $ \ref env client -> do
|
|
atomicModifyIORef' broken (const (Just (weStore env), ()))
|
|
r <- postCreateAs client 1 (createBody supporterPriceId Nothing "btc" (codeHashText sampleCode))
|
|
statusOf r `shouldBe` 500
|
|
responseBody r `shouldBe` errorBody "internal"
|
|
headerOf r hCacheControl `shouldBe` Just "no-store"
|
|
length <$> stubCalls ref `shouldReturn` 1
|
|
invoiceCount (weStore env) `shouldReturn` 0
|
|
|
|
testBadRequestCostsNothing :: IO ()
|
|
testBadRequestCostsNothing = bounded "bad requests" $ withCheckout $ \ref env client -> do
|
|
let good = codeHashText sampleCode
|
|
bodies :: [(String, LB.ByteString)]
|
|
bodies =
|
|
[ ("not JSON at all", "priceId=price-supporter"),
|
|
("a JSON array", "[]"),
|
|
("no fields", "{}"),
|
|
("no method", J.encode (J.object ["priceId" .= supporterPriceId, "codeHash" .= good])),
|
|
("no codeHash", J.encode (J.object ["priceId" .= supporterPriceId, "method" .= ("btc" :: Text)])),
|
|
("no priceId", J.encode (J.object ["method" .= ("btc" :: Text), "codeHash" .= good])),
|
|
("an unknown method", createBody supporterPriceId Nothing "paypal" good),
|
|
("a mistyped method", J.encode (J.object ["priceId" .= supporterPriceId, "method" .= (7 :: Int), "codeHash" .= good])),
|
|
("a mistyped offerId", J.encode (J.object ["priceId" .= supporterPriceId, "offerId" .= (7 :: Int), "method" .= ("btc" :: Text), "codeHash" .= good])),
|
|
("an empty codeHash", createBody supporterPriceId Nothing "btc" ""),
|
|
("a hex codeHash", createBody supporterPriceId Nothing "btc" (T.replicate 64 "a")),
|
|
("a truncated codeHash", createBody supporterPriceId Nothing "btc" (T.dropEnd 1 good)),
|
|
("a padded codeHash", createBody supporterPriceId Nothing "btc" (good <> "=")),
|
|
("a codeHash outside base64url", createBody supporterPriceId Nothing "btc" (T.dropEnd 1 good <> "+")),
|
|
("a non-canonical codeHash", createBody supporterPriceId Nothing "btc" (T.dropEnd 1 good <> "B"))
|
|
]
|
|
mapM_
|
|
( \(i, (label, body)) -> do
|
|
r <- postCreateAs client i body
|
|
(label, statusOf r) `shouldBe` (label, 400)
|
|
(label, responseBody r) `shouldBe` (label, errorBody "bad_request")
|
|
)
|
|
(zip [10 ..] bodies)
|
|
stubCalls ref `shouldReturn` []
|
|
invoiceCount (weStore env) `shouldReturn` 0
|
|
|
|
testOversizedBodyCostsNothing :: IO ()
|
|
testOversizedBodyCostsNothing = bounded "oversized body" $ withCheckout $ \ref env client -> do
|
|
let padded =
|
|
J.encode $
|
|
J.object
|
|
[ "priceId" .= supporterPriceId,
|
|
"method" .= ("btc" :: Text),
|
|
"codeHash" .= codeHashText sampleCode,
|
|
"padding" .= T.replicate (64 * 1024) "x"
|
|
]
|
|
LB.length padded `shouldSatisfy` (> 64 * 1024)
|
|
r <- postCreateAs client 1 padded
|
|
statusOf r `shouldBe` 400
|
|
responseBody r `shouldBe` errorBody "bad_request"
|
|
stubCalls ref `shouldReturn` []
|
|
invoiceCount (weStore env) `shouldReturn` 0
|
|
small <- postCreateAs client 2 (J.encode (J.object ["priceId" .= supporterPriceId, "method" .= ("btc" :: Text), "codeHash" .= codeHashText sampleCode, "padding" .= T.replicate 16 "x"]))
|
|
statusOf small `shouldBe` 200
|
|
|
|
testCardUnconfigured503 :: IO ()
|
|
testCardUnconfigured503 = bounded "card is unavailable" $ withCheckout $ \ref env client -> do
|
|
r <- postCreateAs client 1 (createBody supporterPriceId Nothing "card" (codeHashText sampleCode))
|
|
statusOf r `shouldBe` 503
|
|
responseBody r `shouldBe` errorBody "provider_unavailable"
|
|
stubCalls ref `shouldReturn` []
|
|
invoiceCount (weStore env) `shouldReturn` 0
|
|
|
|
stripeWebhookPath :: String
|
|
stripeWebhookPath = "/webhooks/stripe"
|
|
|
|
postStripeWebhook :: WebClient -> [Header] -> LB.ByteString -> IO (Response LB.ByteString)
|
|
postStripeWebhook client hdrs = webRequestBody client "POST" stripeWebhookPath hdrs
|
|
|
|
signedStripeEvent :: FakeStripe -> Text -> Text -> IO ([Header], LB.ByteString)
|
|
signedStripeEvent fake eventType sid = do
|
|
t <- round . utcTimeToPOSIXSeconds <$> getCurrentTime :: IO Int
|
|
let body = stripeEvent eventType sid
|
|
pure (stripeSigHeader (sWebhookSecret (fsConfig fake)) t body, body)
|
|
|
|
withFakeStripePoller :: (FakeStripe -> PollerEnv -> WebEnv -> WebClient -> IO a) -> IO a
|
|
withFakeStripePoller action =
|
|
withFakeStripe $ \fake ->
|
|
withServiceStore $ \st -> do
|
|
createDirectoryIfMissing True "tests/tmp"
|
|
withTempDirectory "tests/tmp" "badge-stripe-fake" $ \root -> do
|
|
staticDir <- prepareStaticDir root
|
|
seedCheckoutCatalog st
|
|
provider <- stripeProvider (fsConfig fake)
|
|
let cfg = (testServiceConfig staticDir True) {stripe = Just (fsConfig fake)}
|
|
withListener [provider] True holdMicros st cfg $ \env client -> do
|
|
poller <- pollerFor env
|
|
action fake poller env client
|
|
|
|
testCardCreatesSession :: IO ()
|
|
testCardCreatesSession = bounded "card creates a session" $ withFakeStripePoller $ \_ _ env client -> do
|
|
r <- postCreateAs client 1 (createBody supporterPriceId Nothing "card" (codeHashText sampleCode))
|
|
statusOf r `shouldBe` 200
|
|
headerOf r hContentType `shouldBe` Just "application/json"
|
|
o <- jsonObject r
|
|
fieldOf o "clientSecret" `shouldSatisfy` isJust
|
|
fieldOf o "badgeType" `shouldBe` Just (J.String "supporter")
|
|
invId <- InvoiceId <$> stringField o "invoiceId"
|
|
Just row <- getInvoice (weStore env) invId
|
|
irProvider row `shouldBe` PPStripe
|
|
irStatus row `shouldBe` ISOpen
|
|
bcPaymentStatus <$> settledCode (weStore env) invId `shouldReturn` CPSUnpaid
|
|
|
|
testCardSweepCancelsTheIntent :: IO ()
|
|
testCardSweepCancelsTheIntent = bounded "card sweep cancels" $ withFakeStripePoller $ \fake poller env client -> do
|
|
r <- postCreateAs client 1 (createBody supporterPriceId Nothing "card" (codeHashText sampleCode))
|
|
statusOf r `shouldBe` 200
|
|
o <- jsonObject r
|
|
invId@(InvoiceId iid) <- InvoiceId <$> stringField o "invoiceId"
|
|
Just InvoiceRow {irProviderRef = pid} <- getInvoice (weStore env) invId
|
|
past <- addUTCTime (negate (expiryGrace + 60)) <$> getCurrentTime
|
|
withConnection (weStore env) $ \db ->
|
|
DB.execute db "UPDATE sx_badge_service_invoices SET expires_at = ? WHERE invoice_id = ?" (truncateToSecond past, iid)
|
|
runOnePass poller
|
|
fakeIntentStatus fake pid `shouldReturn` Just "canceled"
|
|
invoiceStatus (weStore env) invId `shouldReturn` ISExpired
|
|
|
|
-- | This value differs from the default 60 and the btcpay window 45, so a card expiry read from
|
|
-- the wrong key would show up as one of those instead.
|
|
cardSessionMinutes :: Int
|
|
cardSessionMinutes = 90
|
|
|
|
testCardExpiryFollowsSessionMinutes :: IO ()
|
|
testCardExpiryFollowsSessionMinutes = bounded "card expiry from session_minutes" $
|
|
withFakeStripe $ \fake ->
|
|
withServiceStore $ \st -> do
|
|
createDirectoryIfMissing True "tests/tmp"
|
|
withTempDirectory "tests/tmp" "badge-stripe-expiry" $ \root -> do
|
|
staticDir <- prepareStaticDir root
|
|
seedCheckoutCatalog st
|
|
let stripeCfg = (fsConfig fake) {sSessionMinutes = cardSessionMinutes}
|
|
cfg = (testServiceConfig staticDir True) {stripe = Just stripeCfg, btcpay = Just testBTCPayConfig}
|
|
provider <- stripeProvider stripeCfg
|
|
withListener [provider] True holdMicros st cfg $ \env client -> do
|
|
r <- postCreateAs client 1 (createBody supporterPriceId Nothing "card" (codeHashText sampleCode))
|
|
statusOf r `shouldBe` 200
|
|
o <- jsonObject r
|
|
invId <- InvoiceId <$> stringField o "invoiceId"
|
|
Just row <- getInvoice (weStore env) invId
|
|
fieldOf o "expiresAt" `shouldBe` Just (J.toJSON (irExpiresAt row))
|
|
diffUTCTime (irExpiresAt row) (irCreatedAt row) `shouldBe` fromIntegral (cardSessionMinutes * 60)
|
|
diffUTCTime (irExpiresAt row) (irCreatedAt row) `shouldNotBe` fromIntegral (testExpiryMinutes * 60)
|
|
|
|
testCardWebhookSettles :: IO ()
|
|
testCardWebhookSettles = bounded "card webhook settles" $ withFakeStripePoller $ \fake poller env client -> do
|
|
r <- postCreateAs client 1 (createBody supporterPriceId Nothing "card" (codeHashText sampleCode))
|
|
statusOf r `shouldBe` 200
|
|
o <- jsonObject r
|
|
iid <- InvoiceId <$> stringField o "invoiceId"
|
|
Just row <- getInvoice (weStore env) iid
|
|
let pid = irProviderRef row
|
|
setIntentState fake pid ["status" .= ("succeeded" :: Text)]
|
|
(hdrs, body) <- signedStripeEvent fake "payment_intent.succeeded" pid
|
|
delivered <- postStripeWebhook client hdrs body
|
|
statusOf delivered `shouldBe` 200
|
|
responseBody delivered `shouldBe` ""
|
|
invoiceStatus (weStore env) iid `shouldReturn` ISOpen
|
|
drainHints poller
|
|
invoiceStatus (weStore env) iid `shouldReturn` ISPaid
|
|
bcPaymentStatus <$> settledCode (weStore env) iid `shouldReturn` CPSPaid
|
|
ipStatus <$> paymentRow (weStore env) iid `shouldReturn` "settled"
|
|
|
|
testProviderFailureWritesNothing :: IO ()
|
|
testProviderFailureWritesNothing = bounded "provider failure" $ withCheckout $ \ref env client -> do
|
|
atomicModifyIORef' ref $ \s -> (s {ssCreateResult = Left (ProviderError "connection refused")}, ())
|
|
r <- postCreateAs client 1 (createBody supporterPriceId Nothing "btc" (codeHashText sampleCode))
|
|
statusOf r `shouldBe` 503
|
|
responseBody r `shouldBe` errorBody "provider_unavailable"
|
|
length <$> stubCalls ref `shouldReturn` 1
|
|
invoiceCount (weStore env) `shouldReturn` 0
|
|
codeHashExists (weStore env) (codeDigest sampleCode) `shouldReturn` False
|
|
|
|
-- | provider_ref is unique, so a test that creates several invoices must vary it as a real
|
|
-- provider would.
|
|
distinctProviderRefs :: IORef StubState -> Provider
|
|
distinctProviderRefs ref =
|
|
let stub = stubProvider ref
|
|
in stub
|
|
{ pCreateInvoice = \method draft -> do
|
|
created <- pCreateInvoice stub method draft
|
|
n <- length <$> stubCalls ref
|
|
pure (fmap (\inv -> inv {piProviderRef = piProviderRef inv <> "-" <> T.pack (show n)}) created)
|
|
}
|
|
|
|
testCreateRateLimit :: IO ()
|
|
testCreateRateLimit = bounded "create rate limit" $ withCheckoutProvider distinctProviderRefs $ \ref env client -> do
|
|
let attempt n = postCreateAs client 20 (createBody supporterPriceId Nothing "btc" (codeHashText (sampleCode <> T.pack (show (n :: Int)))))
|
|
allowed <- mapM (fmap statusOf . attempt) [1 .. createsPerMinute]
|
|
allowed `shouldSatisfy` all (== 200)
|
|
refused <- attempt (createsPerMinute + 1)
|
|
statusOf refused `shouldBe` 429
|
|
responseBody refused `shouldBe` errorBody "rate_limited"
|
|
headerOf refused hCacheControl `shouldBe` Just "no-store"
|
|
case headerOf refused "Retry-After" >>= (readMaybe . BC.unpack) of
|
|
Just seconds -> seconds `shouldSatisfy` \s -> s >= (1 :: Int) && s <= 60
|
|
Nothing -> expectationFailure ("Retry-After is " <> show (headerOf refused "Retry-After"))
|
|
length <$> stubCalls ref `shouldReturn` createsPerMinute
|
|
invoiceCount (weStore env) `shouldReturn` createsPerMinute
|
|
|
|
settleAt :: UTCTime
|
|
settleAt = UTCTime (fromGregorian 2026 9 2) (secondsToDiffTime (12 * 3600 + 34 * 60 + 56))
|
|
|
|
replayAt :: UTCTime
|
|
replayAt = addUTCTime 3600 settleAt
|
|
|
|
-- | The service always learns of settlement later than it happened, so this differs from
|
|
-- settleAt, and using one value for both would let a build that wrote the wrong one still pass.
|
|
detectedAt :: UTCTime
|
|
detectedAt = addUTCTime 300 settleAt
|
|
|
|
rcv :: Word32 -> Maybe Text -> Received
|
|
rcv amount crypto = Received {rcvAmount = CurrencyAmount amount, rcvCrypto = crypto, rcvDue = Nothing}
|
|
|
|
settle :: DBStore -> InvoiceId -> PaymentSignal -> UTCTime -> IO (Either Text InvoiceStatus)
|
|
settle st iid signal at = newWaiters >>= \waiters -> settleOrder st waiters iid signal at
|
|
|
|
seedOpen :: HasCallStack => DBStore -> IO InvoiceId
|
|
seedOpen st = do
|
|
seedBadgePrice st "price1"
|
|
createInvoiceRows st sampleInvoice `shouldReturn` Right ()
|
|
pure (niInvoiceId sampleInvoice)
|
|
|
|
invoiceStatus :: HasCallStack => DBStore -> InvoiceId -> IO InvoiceStatus
|
|
invoiceStatus st iid = getInvoice st iid >>= maybe (failWith "no invoice row") (pure . irStatus)
|
|
|
|
paymentRow :: HasCallStack => DBStore -> InvoiceId -> IO InvoicePayment
|
|
paymentRow st iid =
|
|
getInvoice st iid >>= \case
|
|
Just InvoiceRow {irPayment = Just p} -> pure p
|
|
_ -> failWith "no payment row"
|
|
|
|
data CodeRow = CodeRow {bcPaymentStatus :: BadgeCodePaymentStatus, bcExpiresAt :: Maybe UTCTime, bcRevokedAt :: Maybe UTCTime}
|
|
deriving (Eq, Show)
|
|
|
|
settledCode :: HasCallStack => DBStore -> InvoiceId -> IO CodeRow
|
|
settledCode st (InvoiceId iid) = withConnection st $ \db -> do
|
|
rows <-
|
|
DB.query
|
|
db
|
|
"SELECT c.code_payment_status, c.expires_at, c.revoked_at FROM sx_badge_service_badge_codes c JOIN sx_badge_service_badge_code_invoices ci ON ci.badge_code_id = c.badge_code_id WHERE ci.invoice_id = ?"
|
|
(Only iid)
|
|
case rows of
|
|
(status, expiresAt, revokedAt) : _ -> pure CodeRow {bcPaymentStatus = fromMaybe CPSUnpaid (textDecode status), bcExpiresAt = expiresAt, bcRevokedAt = revokedAt}
|
|
[] -> failWith "no badge_codes row"
|
|
|
|
paymentIdentity :: DBStore -> InvoiceId -> IO [(Text, Text, Maybe Text, Maybe Text)]
|
|
paymentIdentity st (InvoiceId iid) = withConnection st $ \db ->
|
|
DB.query db "SELECT payment_id, provider, provider_ref, currency FROM sx_badge_service_payments WHERE invoice_id = ?" (Only iid)
|
|
|
|
touchInvoice :: DBStore -> InvoiceId -> UTCTime -> IO ()
|
|
touchInvoice st (InvoiceId iid) at = withConnection st $ \db ->
|
|
DB.execute db "UPDATE sx_badge_service_invoices SET updated_at = ? WHERE invoice_id = ?" (at, iid)
|
|
|
|
-- | On SQLite the DBStore serialises access behind one connection, so a read taken through it
|
|
-- during a transaction would block rather than see uncommitted state; testPublishIsAfterCommit
|
|
-- needs this read to open its own connection instead.
|
|
independentStatus :: DBStore -> InvoiceId -> IO (Maybe Text)
|
|
#if defined(dbPostgres)
|
|
independentStatus st (InvoiceId iid) = withConnection st $ \db -> do
|
|
rows <- DB.query db "SELECT status FROM sx_badge_service_invoices WHERE invoice_id = ?" (Only iid)
|
|
pure $ case rows of
|
|
(Only s : _) -> Just s
|
|
[] -> Nothing
|
|
#else
|
|
independentStatus DBStore {dbFilePath} (InvoiceId iid) = E.bracket (SQL.open dbFilePath) SQL.close reader `E.catch` locked
|
|
where
|
|
reader c = do
|
|
rows <- SQL.query c "SELECT status FROM sx_badge_service_invoices WHERE invoice_id = ?" (Only iid)
|
|
pure $ case rows of
|
|
(Only s : _) -> Just s
|
|
[] -> Nothing
|
|
locked :: SQL.SQLError -> IO (Maybe Text)
|
|
locked _ = pure Nothing
|
|
#endif
|
|
|
|
-- | This trigger expires the invoice from inside the settling transaction, and it is a trigger
|
|
-- rather than a concurrent thread because the SQLite store puts every access behind one
|
|
-- connection and so cannot have a concurrent writer.
|
|
expireOnNextPayment :: DBStore -> IO ()
|
|
#if defined(dbPostgres)
|
|
expireOnNextPayment st = withConnection st $ \db -> do
|
|
DB.execute_
|
|
db
|
|
"CREATE FUNCTION sx_badge_service_test_expire() RETURNS trigger AS $$ BEGIN UPDATE sx_badge_service_invoices SET status = 'expired' WHERE invoice_id = NEW.invoice_id; RETURN NEW; END; $$ LANGUAGE plpgsql"
|
|
DB.execute_
|
|
db
|
|
"CREATE TRIGGER sx_badge_service_test_expire_trg AFTER INSERT ON sx_badge_service_payments FOR EACH ROW EXECUTE FUNCTION sx_badge_service_test_expire()"
|
|
#else
|
|
expireOnNextPayment st = withConnection st $ \db ->
|
|
DB.execute_
|
|
db
|
|
"CREATE TRIGGER sx_badge_service_test_expire AFTER INSERT ON sx_badge_service_payments BEGIN UPDATE sx_badge_service_invoices SET status = 'expired' WHERE invoice_id = NEW.invoice_id; END"
|
|
#endif
|
|
|
|
testSettlesAnOpenInvoice :: IO ()
|
|
testSettlesAnOpenInvoice = bounded "settles an open invoice" $ withServiceStore $ \st -> do
|
|
iid <- seedOpen st
|
|
settle st iid (SigSettled (rcv 500 (Just "0.00050000")) settleAt) detectedAt `shouldReturn` Right ISPaid
|
|
invoiceStatus st iid `shouldReturn` ISPaid
|
|
p <- paymentRow st iid
|
|
ipAmount p `shouldBe` Just (CurrencyAmount 500)
|
|
ipCryptoPaid p `shouldBe` Just "0.00050000"
|
|
ipStatus p `shouldBe` "settled"
|
|
ipUpdatedAt p `shouldBe` settleAt
|
|
ipUpdatedAt p `shouldNotBe` detectedAt
|
|
paymentIdentity st iid `shouldReturn` [("inv1", "crypto", Just (niProviderRef sampleInvoice), Just "usd")]
|
|
code <- settledCode st iid
|
|
bcPaymentStatus code `shouldBe` CPSPaid
|
|
bcExpiresAt code `shouldBe` Just (addUTCTime codeLifetime settleAt)
|
|
bcExpiresAt code `shouldNotBe` Just (addUTCTime codeLifetime detectedAt)
|
|
bcRevokedAt code `shouldBe` Nothing
|
|
|
|
testLateSettlementIsLegal :: IO ()
|
|
testLateSettlementIsLegal = bounded "late settlement" $ withServiceStore $ \st -> do
|
|
iid <- seedOpen st
|
|
expireRow st iid
|
|
invoiceStatus st iid `shouldReturn` ISExpired
|
|
settle st iid (SigSettled (rcv 500 Nothing) settleAt) detectedAt `shouldReturn` Right ISPaid
|
|
invoiceStatus st iid `shouldReturn` ISPaid
|
|
ipStatus <$> paymentRow st iid `shouldReturn` "settled"
|
|
bcPaymentStatus <$> settledCode st iid `shouldReturn` CPSPaid
|
|
|
|
testFundedRecordsWithoutMoving :: IO ()
|
|
testFundedRecordsWithoutMoving = bounded "funded records only" $ withServiceStore $ \st -> do
|
|
iid <- seedOpen st
|
|
settle st iid (SigFunded (rcv 200 (Just "0.00020000")) PaidInPart) settleAt `shouldReturn` Right ISOpen
|
|
invoiceStatus st iid `shouldReturn` ISOpen
|
|
p <- paymentRow st iid
|
|
ipAmount p `shouldBe` Just (CurrencyAmount 200)
|
|
ipStatus p `shouldBe` "pending"
|
|
code <- settledCode st iid
|
|
bcPaymentStatus code `shouldBe` CPSUnpaid
|
|
bcExpiresAt code `shouldBe` Nothing
|
|
expireRow st iid
|
|
settle st iid (SigFunded (rcv 300 (Just "0.00030000")) PaidInPart) replayAt `shouldReturn` Right ISExpired
|
|
invoiceStatus st iid `shouldReturn` ISExpired
|
|
ipAmount <$> paymentRow st iid `shouldReturn` Just (CurrencyAmount 300)
|
|
bcPaymentStatus <$> settledCode st iid `shouldReturn` CPSUnpaid
|
|
|
|
testClosedExpiresAnOpenInvoice :: IO ()
|
|
testClosedExpiresAnOpenInvoice = bounded "closed expires" $ withServiceStore $ \st -> do
|
|
iid <- seedOpen st
|
|
settle st iid (SigClosed (rcv 200 (Just "0.00020000"))) settleAt `shouldReturn` Right ISExpired
|
|
invoiceStatus st iid `shouldReturn` ISExpired
|
|
p <- paymentRow st iid
|
|
ipAmount p `shouldBe` Just (CurrencyAmount 200)
|
|
ipStatus p `shouldBe` "pending"
|
|
bcPaymentStatus <$> settledCode st iid `shouldReturn` CPSUnpaid
|
|
|
|
testClosedWithNothingWritesNoPayment :: IO ()
|
|
testClosedWithNothingWritesNoPayment = bounded "closed on nothing" $ withServiceStore $ \st -> do
|
|
iid <- seedOpen st
|
|
settle st iid (SigClosed (rcv 0 Nothing)) settleAt `shouldReturn` Right ISExpired
|
|
invoiceStatus st iid `shouldReturn` ISExpired
|
|
Just row <- getInvoice st iid
|
|
irPayment row `shouldBe` Nothing
|
|
bcPaymentStatus <$> settledCode st iid `shouldReturn` CPSUnpaid
|
|
|
|
testClosedReplayIsIdempotent :: IO ()
|
|
testClosedReplayIsIdempotent = bounded "closed replay" $ withServiceStore $ \st -> do
|
|
iid <- seedOpen st
|
|
settle st iid (SigClosed (rcv 200 (Just "0.00020000"))) settleAt `shouldReturn` Right ISExpired
|
|
settle st iid (SigClosed (rcv 200 (Just "0.00020000"))) replayAt `shouldReturn` Right ISExpired
|
|
invoiceStatus st iid `shouldReturn` ISExpired
|
|
p <- paymentRow st iid
|
|
ipAmount p `shouldBe` Just (CurrencyAmount 200)
|
|
ipCryptoPaid p `shouldBe` Just "0.00020000"
|
|
ipStatus p `shouldBe` "pending"
|
|
length <$> paymentIdentity st iid `shouldReturn` 1
|
|
|
|
testPaidRefusesEverySignal :: IO ()
|
|
testPaidRefusesEverySignal = bounded "paid refuses" $ withServiceStore $ \st -> do
|
|
iid <- seedOpen st
|
|
settle st iid (SigSettled (rcv 500 (Just "0.00050000")) settleAt) detectedAt `shouldReturn` Right ISPaid
|
|
settled <- paymentRow st iid
|
|
deadline <- bcExpiresAt <$> settledCode st iid
|
|
mapM_
|
|
( \signal -> do
|
|
settle st iid signal replayAt `shouldReturn` Right ISPaid
|
|
(signal, ) <$> paymentRow st iid `shouldReturn` (signal, settled)
|
|
)
|
|
[ SigSettled (rcv 900 (Just "0.00090000")) replayAt,
|
|
SigFunded (rcv 900 (Just "0.00090000")) PaidInPart,
|
|
SigClosed (rcv 900 (Just "0.00090000"))
|
|
]
|
|
invoiceStatus st iid `shouldReturn` ISPaid
|
|
bcExpiresAt <$> settledCode st iid `shouldReturn` deadline
|
|
|
|
testAmountIsMonotonic :: IO ()
|
|
testAmountIsMonotonic = bounded "monotonic amount" $ withServiceStore $ \st -> do
|
|
iid <- seedOpen st
|
|
settle st iid (SigFunded (rcv 40000 (Just "0.734")) PaidInPart) settleAt `shouldReturn` Right ISOpen
|
|
settle st iid (SigFunded (rcv 10000 (Just "0.180")) PaidInPart) replayAt `shouldReturn` Right ISOpen
|
|
p <- paymentRow st iid
|
|
ipAmount p `shouldBe` Just (CurrencyAmount 40000)
|
|
ipCryptoPaid p `shouldBe` Just "0.734"
|
|
settle st iid (SigFunded (rcv 40000 (Just "0.734")) PaidInPart) replayAt `shouldReturn` Right ISOpen
|
|
settle st iid (SigFunded (rcv 40000 (Just "0.734")) PaidInPart) replayAt `shouldReturn` Right ISOpen
|
|
ipAmount <$> paymentRow st iid `shouldReturn` Just (CurrencyAmount 40000)
|
|
settle st iid (SigFunded (rcv 50000 (Just "0.900")) PaidInPart) replayAt `shouldReturn` Right ISOpen
|
|
p' <- paymentRow st iid
|
|
ipAmount p' `shouldBe` Just (CurrencyAmount 50000)
|
|
ipCryptoPaid p' `shouldBe` Just "0.900"
|
|
|
|
testDeadlineIsFromTheFirstSettlement :: IO ()
|
|
testDeadlineIsFromTheFirstSettlement = bounded "deadline from the first settlement" $ withServiceStore $ \st -> do
|
|
iid <- seedOpen st
|
|
settle st iid (SigSettled (rcv 500 Nothing) settleAt) detectedAt `shouldReturn` Right ISPaid
|
|
let firstDeadline = addUTCTime codeLifetime settleAt
|
|
bcExpiresAt <$> settledCode st iid `shouldReturn` Just firstDeadline
|
|
withTransaction st $ \db -> markCodePaid db (niCodeHash sampleInvoice) (addUTCTime codeLifetime replayAt)
|
|
bcExpiresAt <$> settledCode st iid `shouldReturn` Just firstDeadline
|
|
bcPaymentStatus <$> settledCode st iid `shouldReturn` CPSPaid
|
|
|
|
testStatusGuardRefusesAStaleObservation :: IO ()
|
|
testStatusGuardRefusesAStaleObservation = bounded "stale observation" $ withServiceStore $ \st -> do
|
|
iid <- seedOpen st
|
|
markPaid st iid
|
|
stale <- withTransaction st $ \db -> updateInvoiceStatus db iid ISOpen ISExpired settleAt
|
|
stale `shouldBe` False
|
|
invoiceStatus st iid `shouldReturn` ISPaid
|
|
let second' = sampleInvoice {niInvoiceId = InvoiceId "inv-2", niProviderRef = "p-2", niCodeHash = digestFixture 15}
|
|
createInvoiceRows st second' `shouldReturn` Right ()
|
|
moved <- withTransaction st $ \db -> updateInvoiceStatus db (niInvoiceId second') ISOpen ISExpired settleAt
|
|
moved `shouldBe` True
|
|
invoiceStatus st (niInvoiceId second') `shouldReturn` ISExpired
|
|
|
|
testUnknownInvoiceSettlesNothing :: IO ()
|
|
testUnknownInvoiceSettlesNothing = bounded "unknown invoice" $ withServiceStore $ \st -> do
|
|
_ <- seedOpen st
|
|
r <- settle st (InvoiceId "no-such-invoice") (SigSettled (rcv 500 Nothing) settleAt) settleAt
|
|
r `shouldSatisfy` isLeft
|
|
paymentIdentity st (InvoiceId "no-such-invoice") `shouldReturn` []
|
|
|
|
testPublishIsAfterCommit :: IO ()
|
|
testPublishIsAfterCommit = bounded "publish after commit" $ withServiceStore $ \st -> do
|
|
iid <- seedOpen st
|
|
waiters <- newWaiters
|
|
seen <- newEmptyMVar
|
|
_ <- forkIO $ do
|
|
woken <- awaitStatus waiters iid ((\s -> (s, ("", False))) <$> invoiceStatus st iid) (ISOpen, ("", False)) waitCeiling
|
|
visible <- independentStatus st iid
|
|
putMVar seen (woken, visible)
|
|
threadDelay 100000
|
|
settleOrder st waiters iid (SigSettled (rcv 500 Nothing) settleAt) settleAt `shouldReturn` Right ISPaid
|
|
takeMVar seen `shouldReturn` (ISPaid, Just "paid")
|
|
|
|
waitCeiling :: Int
|
|
waitCeiling = 10 * 1000000
|
|
|
|
testSettlementWakesAHeldRequest :: IO ()
|
|
testSettlementWakesAHeldRequest = bounded "settlement wakes a hold" $ withWebApp $ \env client -> do
|
|
iid <- seedOpenInvoice env
|
|
let settled =
|
|
settleOrder (weStore env) (weWaiters env) iid (SigSettled (rcv 500 (Just "0.00050000")) settleAt) settleAt
|
|
`shouldReturn` Right ISPaid
|
|
o <- wokenBy client iid settled "paid"
|
|
fieldOf o "amountPaid" `shouldBe` Just (J.Number 500)
|
|
|
|
testFutureSettledInstantIsRefused :: IO ()
|
|
testFutureSettledInstantIsRefused = bounded "future settled instant" $ withWebApp $ \env client -> do
|
|
iid <- seedOpenInvoice env
|
|
let inMilliseconds = posixSecondsToUTCTime (1000 * utcTimeToPOSIXSeconds detectedAt)
|
|
settle (weStore env) iid (SigSettled (rcv 500 (Just "0.00050000")) inMilliseconds) detectedAt
|
|
`shouldReturn` Right ISPaid
|
|
code <- settledCode (weStore env) iid
|
|
bcPaymentStatus code `shouldBe` CPSPaid
|
|
bcExpiresAt code `shouldBe` Just (addUTCTime codeLifetime detectedAt)
|
|
o <- jsonObject =<< webGet client (invoicePath iid)
|
|
fieldOf o "settledAt" `shouldBe` Just (J.toJSON detectedAt)
|
|
|
|
testAbsurdSettledInstantIsRefused :: IO ()
|
|
testAbsurdSettledInstantIsRefused = bounded "absurd settled instant" $ withWebApp $ \env client -> do
|
|
iid <- seedOpenInvoice env
|
|
let epochZero = posixSecondsToUTCTime 0
|
|
settle (weStore env) iid (SigSettled (rcv 500 (Just "0.00050000")) epochZero) detectedAt
|
|
`shouldReturn` Right ISPaid
|
|
code <- settledCode (weStore env) iid
|
|
bcPaymentStatus code `shouldBe` CPSPaid
|
|
bcExpiresAt code `shouldSatisfy` maybe False (> detectedAt)
|
|
o <- jsonObject =<< webGet client (invoicePath iid)
|
|
fieldOf o "status" `shouldBe` Just (J.String "paid")
|
|
fieldOf o "settledAt" `shouldBe` Just (J.toJSON detectedAt)
|
|
|
|
testSettledAtIsThePaymentRow :: IO ()
|
|
testSettledAtIsThePaymentRow = bounded "settledAt" $ withWebApp $ \env client -> do
|
|
iid <- seedOpenInvoice env
|
|
settle (weStore env) iid (SigSettled (rcv 500 Nothing) settleAt) detectedAt `shouldReturn` Right ISPaid
|
|
o <- jsonObject =<< webGet client (invoicePath iid)
|
|
fieldOf o "status" `shouldBe` Just (J.String "paid")
|
|
fieldOf o "settledAt" `shouldBe` Just (J.toJSON settleAt)
|
|
fieldOf o "settledAt" `shouldNotBe` Just (J.toJSON someCreated)
|
|
fieldOf o "settledAt" `shouldNotBe` Just (J.toJSON detectedAt)
|
|
touchInvoice (weStore env) iid replayAt
|
|
o' <- jsonObject =<< webGet client (invoicePath iid)
|
|
fieldOf o' "settledAt" `shouldBe` Just (J.toJSON settleAt)
|
|
|
|
testLosingTheStatusGuardStillWakesTheHold :: IO ()
|
|
testLosingTheStatusGuardStillWakesTheHold = bounded "losing the guard" $ withWebAppHolding raceHold $ \env client -> do
|
|
iid <- seedOpenInvoice env
|
|
expireOnNextPayment (weStore env)
|
|
_ <- wokenBy client iid (settledIntoAnExpiredRow env iid) "expired"
|
|
pure ()
|
|
|
|
settledIntoAnExpiredRow :: HasCallStack => WebEnv -> InvoiceId -> IO ()
|
|
settledIntoAnExpiredRow env iid = do
|
|
settleOrder (weStore env) (weWaiters env) iid (SigSettled (rcv 500 (Just "0.00050000")) settleAt) settleAt
|
|
`shouldReturn` Right ISExpired
|
|
invoiceStatus (weStore env) iid `shouldReturn` ISExpired
|
|
code <- settledCode (weStore env) iid
|
|
bcPaymentStatus code `shouldBe` CPSUnpaid
|
|
bcExpiresAt code `shouldBe` Nothing
|
|
ipStatus <$> paymentRow (weStore env) iid `shouldReturn` "settled"
|
|
|
|
raceHold :: Int
|
|
raceHold = 3 * 1000000
|
|
|
|
testSettledPaymentIsNotDowngraded :: IO ()
|
|
testSettledPaymentIsNotDowngraded = bounded "settled is not downgraded" $ withServiceStore $ \st -> do
|
|
iid <- seedOpen st
|
|
row <- getInvoice st iid >>= maybe (failWith "no invoice row") pure
|
|
withTransaction st $ \db -> upsertPayment db row PSSettled (CurrencyAmount 500) (Just "0.00050000") Nothing False settleAt
|
|
withTransaction st $ \db -> upsertPayment db row PSPending (CurrencyAmount 200) (Just "0.00020000") Nothing False replayAt
|
|
p <- paymentRow st iid
|
|
ipStatus p `shouldBe` "settled"
|
|
ipUpdatedAt p `shouldBe` settleAt
|
|
ipAmount p `shouldBe` Just (CurrencyAmount 500)
|
|
ipCryptoPaid p `shouldBe` Just "0.00050000"
|
|
let second' = sampleInvoice {niInvoiceId = InvoiceId "inv-pending", niProviderRef = "p-pending", niCodeHash = digestFixture 16}
|
|
createInvoiceRows st second' `shouldReturn` Right ()
|
|
row' <- getInvoice st (niInvoiceId second') >>= maybe (failWith "no invoice row") pure
|
|
withTransaction st $ \db -> upsertPayment db row' PSPending (CurrencyAmount 100) Nothing Nothing False settleAt
|
|
withTransaction st $ \db -> upsertPayment db row' PSSettled (CurrencyAmount 500) (Just "0.00050000") Nothing False replayAt
|
|
p' <- paymentRow st (niInvoiceId second')
|
|
ipStatus p' `shouldBe` "settled"
|
|
ipUpdatedAt p' `shouldBe` replayAt
|
|
|
|
testCryptoAmountFillsInFromNull :: IO ()
|
|
testCryptoAmountFillsInFromNull = bounded "crypto fills in" $ withServiceStore $ \st -> do
|
|
iid <- seedOpen st
|
|
settle st iid (SigFunded (rcv 500 Nothing) PaidInPart) settleAt `shouldReturn` Right ISOpen
|
|
ipCryptoPaid <$> paymentRow st iid `shouldReturn` Nothing
|
|
settle st iid (SigSettled (rcv 500 (Just "0.00050000")) settleAt) detectedAt `shouldReturn` Right ISPaid
|
|
ipCryptoPaid <$> paymentRow st iid `shouldReturn` Just "0.00050000"
|
|
ipAmount <$> paymentRow st iid `shouldReturn` Just (CurrencyAmount 500)
|
|
|
|
pollerFor :: WebEnv -> IO PollerEnv
|
|
pollerFor WebEnv {weStore, weConfig, weWaiters, weHints, weProviders} =
|
|
newPollerEnv weStore weWaiters weHints weProviders (poll weConfig)
|
|
|
|
withStubPoller :: Int -> (IORef StubState -> PollerEnv -> WebEnv -> WebClient -> IO a) -> IO a
|
|
withStubPoller = withStubPollerOf stubProvider
|
|
|
|
withStubPollerOf :: (IORef StubState -> Provider) -> Int -> (IORef StubState -> PollerEnv -> WebEnv -> WebClient -> IO a) -> IO a
|
|
withStubPollerOf mkProvider hold action =
|
|
withServiceStore $ \st -> do
|
|
createDirectoryIfMissing True "tests/tmp"
|
|
withTempDirectory "tests/tmp" "badge-poller" $ \root -> do
|
|
staticDir <- prepareStaticDir root
|
|
ref <- newIORef (newStubState (Right sampleProviderInvoice))
|
|
let cfg = (testServiceConfig staticDir True) {btcpay = Just testBTCPayConfig}
|
|
withListener [mkProvider ref] True hold st cfg $ \env client -> do
|
|
poller <- pollerFor env
|
|
action ref poller env client
|
|
|
|
withFakePoller :: (FakeBTCPay -> PollerEnv -> WebEnv -> WebClient -> IO a) -> IO a
|
|
withFakePoller = withFakePollerHolding holdMicros
|
|
|
|
withFakePollerHolding :: Int -> (FakeBTCPay -> PollerEnv -> WebEnv -> WebClient -> IO a) -> IO a
|
|
withFakePollerHolding hold action =
|
|
withFakeBTCPay $ \fake ->
|
|
withServiceStore $ \st -> do
|
|
createDirectoryIfMissing True "tests/tmp"
|
|
withTempDirectory "tests/tmp" "badge-poller-fake" $ \root -> do
|
|
staticDir <- prepareStaticDir root
|
|
seedCheckoutCatalog st
|
|
provider <- btcpayProvider (fbConfig fake)
|
|
let cfg = (testServiceConfig staticDir True) {btcpay = Just (fbConfig fake)}
|
|
withListener [provider] True hold st cfg $ \env client -> do
|
|
poller <- pollerFor env
|
|
action fake poller env client
|
|
|
|
withFakeProvider :: (FakeBTCPay -> Provider -> IO a) -> IO a
|
|
withFakeProvider action = withFakeBTCPay $ \fake -> btcpayProvider (fbConfig fake) >>= action fake
|
|
|
|
setSignals :: IORef StubState -> [(Text, PaymentSignal)] -> IO ()
|
|
setSignals ref signals = atomicModifyIORef' ref $ \s -> (s {ssInvoices = Map.fromList signals}, ())
|
|
|
|
clearCalls :: IORef StubState -> IO ()
|
|
clearCalls ref = atomicModifyIORef' ref $ \s -> (s {ssCalls = []}, ())
|
|
|
|
setSkipped :: IORef StubState -> [(Maybe Text, Text)] -> IO ()
|
|
setSkipped ref reasons = atomicModifyIORef' ref $ \s -> (s {ssSkipped = reasons}, ())
|
|
|
|
failList :: IORef StubState -> Maybe ProviderError -> IO ()
|
|
failList ref e = atomicModifyIORef' ref $ \s -> (s {ssListError = e}, ())
|
|
|
|
failRead :: IORef StubState -> Maybe ProviderError -> IO ()
|
|
failRead ref e = atomicModifyIORef' ref $ \s -> (s {ssReadError = e}, ())
|
|
|
|
seedOpenRef :: HasCallStack => DBStore -> Int -> Text -> UTCTime -> IO InvoiceId
|
|
seedOpenRef = seedOpenRefOf PPCrypto
|
|
|
|
seedOpenRefOf :: HasCallStack => PaymentProvider -> DBStore -> Int -> Text -> UTCTime -> IO InvoiceId
|
|
seedOpenRefOf provider st i providerRef expiresAt = do
|
|
-- The row is created at the current time because the poller reads only invoices inside its
|
|
-- recent settle window and sweeps anything older.
|
|
createdAt <- truncateToSecond <$> getCurrentTime
|
|
let n = T.pack (show i)
|
|
iid = InvoiceId ("inv-poll-" <> n)
|
|
ni =
|
|
sampleInvoice
|
|
{ niInvoiceId = iid,
|
|
niProviderRef = providerRef,
|
|
niCodeHash = digestFixture (fromIntegral i + 20),
|
|
niExpiresAt = expiresAt,
|
|
niCreatedAt = createdAt,
|
|
niProvider = provider
|
|
}
|
|
createInvoiceRows st ni `shouldReturn` Right ()
|
|
pure iid
|
|
|
|
seedOtherProvider :: HasCallStack => DBStore -> Int -> Text -> IO InvoiceId
|
|
seedOtherProvider st i providerRef = do
|
|
createdAt <- truncateToSecond <$> getCurrentTime
|
|
let n = T.pack (show i)
|
|
iid = InvoiceId ("inv-poll-" <> n)
|
|
ni =
|
|
sampleInvoice
|
|
{ niInvoiceId = iid,
|
|
niProviderRef = providerRef,
|
|
niCodeHash = digestFixture (fromIntegral i + 40),
|
|
niProvider = PPStripe,
|
|
niCreatedAt = createdAt
|
|
}
|
|
createInvoiceRows st ni `shouldReturn` Right ()
|
|
pure iid
|
|
|
|
settledSignal :: PaymentSignal
|
|
settledSignal = SigSettled (rcv 500 (Just "0.00050000")) settleAt
|
|
|
|
testSettlesWithNoWebhookAtAll :: IO ()
|
|
testSettlesWithNoWebhookAtAll = bounded "no webhook at all" $ withFakePoller $ \fake poller env client -> do
|
|
r <- postCreateAs client 1 (createBody supporterPriceId Nothing "xmr" (codeHashText sampleCode))
|
|
statusOf r `shouldBe` 200
|
|
o <- jsonObject r
|
|
iid <- InvoiceId <$> stringField o "invoiceId"
|
|
invoiceStatus (weStore env) iid `shouldReturn` ISOpen
|
|
bcPaymentStatus <$> settledCode (weStore env) iid `shouldReturn` CPSUnpaid
|
|
Just row <- getInvoice (weStore env) iid
|
|
setInvoiceState fake (irProviderRef row) ["status" .= ("Settled" :: Text), "paymentMethodPaid" .= ("0.32095000" :: Text)]
|
|
runOnePass poller
|
|
invoiceStatus (weStore env) iid `shouldReturn` ISPaid
|
|
code <- settledCode (weStore env) iid
|
|
bcPaymentStatus code `shouldBe` CPSPaid
|
|
bcExpiresAt code `shouldSatisfy` isJust
|
|
p <- paymentRow (weStore env) iid
|
|
ipStatus p `shouldBe` "settled"
|
|
ipAmount p `shouldBe` Just (CurrencyAmount 5400)
|
|
ipCryptoPaid p `shouldBe` Just "0.32095000"
|
|
|
|
testPassReadsWhatItAwaits :: IO ()
|
|
testPassReadsWhatItAwaits = bounded "reads what it awaits" $ withStubPoller raceHold $ \ref poller env _ -> do
|
|
seedBadgePrice (weStore env) "price1"
|
|
a <- seedOpenRef (weStore env) 1 "p-1" someExpiry
|
|
b <- seedOpenRef (weStore env) 2 "p-2" someExpiry
|
|
c <- seedOpenRef (weStore env) 3 "p-3" someExpiry
|
|
setSignals ref [("p-1", settledSignal), ("p-2", settledSignal), ("p-3", settledSignal)]
|
|
runOnePass poller
|
|
stubCalls ref `shouldReturn` [StubRead "p-1", StubRead "p-2", StubRead "p-3", StubListOpen]
|
|
mapM (invoiceStatus (weStore env)) [a, b, c] `shouldReturn` [ISPaid, ISPaid, ISPaid]
|
|
|
|
testIdlePassAsksNothing :: IO ()
|
|
testIdlePassAsksNothing = bounded "idle pass" $ withStubPoller raceHold $ \ref poller env _ -> do
|
|
seedBadgePrice (weStore env) "price1"
|
|
iid <- seedOpenRef (weStore env) 1 "p-1" someExpiry
|
|
setSignals ref [("p-1", settledSignal)]
|
|
runOnePass poller
|
|
invoiceStatus (weStore env) iid `shouldReturn` ISPaid
|
|
clearCalls ref
|
|
runOnePass poller
|
|
stubCalls ref `shouldReturn` []
|
|
|
|
testManyOpenInvoicesList :: IO ()
|
|
testManyOpenInvoicesList = bounded "many open" $ withStubPoller raceHold $ \ref poller env _ -> do
|
|
seedBadgePrice (weStore env) "price1"
|
|
mapM_ (\i -> seedOpenRef (weStore env) i ("p-many-" <> tshow i) someExpiry) [1 .. readsPerPass + 1]
|
|
runOnePass poller
|
|
stubCalls ref `shouldReturn` [StubListOpen]
|
|
|
|
testNoProviderAccountsForNothing :: HasCallStack => IO ()
|
|
testNoProviderAccountsForNothing = bounded "no provider" $ withStubPoller raceHold $ \_ poller env _ -> do
|
|
now <- getCurrentTime
|
|
seedBadgePrice (weStore env) "price1"
|
|
let overdue i = seedOpenRef (weStore env) i ("p-none-" <> tshow i) (addUTCTime (negate (expiryGrace + 60)) now)
|
|
few <- mapM overdue [1 .. 3]
|
|
let blind = poller {peProviders = []}
|
|
runOnePass blind
|
|
mapM (invoiceStatus (weStore env)) few `shouldReturn` replicate 3 ISOpen
|
|
many <- mapM overdue [4 .. readsPerPass + 4]
|
|
runOnePass blind
|
|
mapM (invoiceStatus (weStore env)) (few <> many) `shouldReturn` replicate (length few + length many) ISOpen
|
|
|
|
testBulkListIsTheOnlyList :: HasCallStack => IO ()
|
|
testBulkListIsTheOnlyList = bounded "bulk lists once" $ withStubPoller raceHold $ \ref poller env _ -> do
|
|
seedBadgePrice (weStore env) "price1"
|
|
mapM_ (\i -> seedOpenRef (weStore env) i ("p-cadence-" <> tshow i) someExpiry) [1 .. readsPerPass + 1]
|
|
setSignals ref [("p-cadence-" <> tshow i, settledSignal) | i <- [1 .. readsPerPass]]
|
|
runOnePass poller
|
|
stubCalls ref `shouldReturn` [StubListOpen]
|
|
clearCalls ref
|
|
runOnePass poller
|
|
calls <- stubCalls ref
|
|
filter (== StubListOpen) calls `shouldBe` []
|
|
|
|
testMixedProvidersHoldTheSweep :: HasCallStack => IO ()
|
|
testMixedProvidersHoldTheSweep = bounded "mixed providers" $ withStubPoller raceHold $ \_ poller env _ -> do
|
|
now <- getCurrentTime
|
|
seedBadgePrice (weStore env) "price1"
|
|
mapM_ (\i -> seedOpenRef (weStore env) i ("p-mixed-" <> tshow i) someExpiry) [1 .. readsPerPass + 1]
|
|
createdAt <- truncateToSecond <$> getCurrentTime
|
|
let iid = InvoiceId "inv-poll-stripe"
|
|
stripeRow =
|
|
sampleInvoice
|
|
{ niInvoiceId = iid,
|
|
niProviderRef = "p-stripe-mixed",
|
|
niCodeHash = digestFixture 99,
|
|
niProvider = PPStripe,
|
|
niExpiresAt = addUTCTime (negate (expiryGrace + 60)) now,
|
|
niCreatedAt = createdAt
|
|
}
|
|
createInvoiceRows (weStore env) stripeRow `shouldReturn` Right ()
|
|
runOnePass poller
|
|
invoiceStatus (weStore env) iid `shouldReturn` ISOpen
|
|
|
|
testEverySignalSettles :: IO ()
|
|
testEverySignalSettles = bounded "every signal settles" $ withStubPoller raceHold $ \ref poller env _ -> do
|
|
seedBadgePrice (weStore env) "price1"
|
|
paid <- seedOpenRef (weStore env) 1 "p-settled" someExpiry
|
|
funded <- seedOpenRef (weStore env) 2 "p-funded" someExpiry
|
|
closed <- seedOpenRef (weStore env) 3 "p-closed" someExpiry
|
|
setSignals
|
|
ref
|
|
[ ("p-settled", settledSignal),
|
|
("p-funded", SigFunded (rcv 200 (Just "0.00020000")) PaidInPart),
|
|
("p-closed", SigClosed (rcv 100 (Just "0.00010000")))
|
|
]
|
|
runOnePass poller
|
|
invoiceStatus (weStore env) paid `shouldReturn` ISPaid
|
|
invoiceStatus (weStore env) funded `shouldReturn` ISOpen
|
|
ipAmount <$> paymentRow (weStore env) funded `shouldReturn` Just (CurrencyAmount 200)
|
|
invoiceStatus (weStore env) closed `shouldReturn` ISExpired
|
|
ipCryptoPaid <$> paymentRow (weStore env) closed `shouldReturn` Just "0.00010000"
|
|
bcPaymentStatus <$> settledCode (weStore env) paid `shouldReturn` CPSPaid
|
|
bcPaymentStatus <$> settledCode (weStore env) funded `shouldReturn` CPSUnpaid
|
|
bcPaymentStatus <$> settledCode (weStore env) closed `shouldReturn` CPSUnpaid
|
|
|
|
testForeignRefIsPassedOver :: IO ()
|
|
testForeignRefIsPassedOver = bounded "foreign ref" $ withStubPoller raceHold $ \ref poller env _ -> do
|
|
seedBadgePrice (weStore env) "price1"
|
|
ours <- seedOpenRef (weStore env) 1 "p-1" someExpiry
|
|
otherLane <- seedOtherProvider (weStore env) 2 "p-stripe"
|
|
setSignals ref [("p-1", settledSignal), ("someone-elses-invoice", settledSignal), ("p-stripe", settledSignal)]
|
|
runOnePass poller
|
|
invoiceStatus (weStore env) ours `shouldReturn` ISPaid
|
|
invoiceStatus (weStore env) otherLane `shouldReturn` ISOpen
|
|
invoiceCount (weStore env) `shouldReturn` 2
|
|
|
|
testProviderFailureLosesNothing :: IO ()
|
|
testProviderFailureLosesNothing = bounded "provider outage" $ withStubPoller raceHold $ \ref poller env _ -> do
|
|
seedBadgePrice (weStore env) "price1"
|
|
iid <- seedOpenRef (weStore env) 1 "p-1" someExpiry
|
|
setSignals ref [("p-1", settledSignal)]
|
|
failList ref (Just (ProviderError "connection refused"))
|
|
failRead ref (Just (ProviderError "connection refused"))
|
|
runOnePass poller
|
|
invoiceStatus (weStore env) iid `shouldReturn` ISOpen
|
|
Just row <- getInvoice (weStore env) iid
|
|
irPayment row `shouldBe` Nothing
|
|
bcPaymentStatus <$> settledCode (weStore env) iid `shouldReturn` CPSUnpaid
|
|
failList ref Nothing
|
|
failRead ref Nothing
|
|
runOnePass poller
|
|
invoiceStatus (weStore env) iid `shouldReturn` ISPaid
|
|
stubCalls ref `shouldReturn` [StubRead "p-1", StubListOpen, StubRead "p-1"]
|
|
|
|
testCadenceFollowsTheWaiters :: IO ()
|
|
testCadenceFollowsTheWaiters = bounded "cadence" $ withStubPoller raceHold $ \_ poller env client -> do
|
|
iid <- seedOpenInvoice env
|
|
let PollConfig {pWaitingSeconds, pIdleSeconds} = poll (weConfig env)
|
|
pWaitingSeconds `shouldNotBe` pIdleSeconds
|
|
waitingCount (weWaiters env) `shouldReturn` 0
|
|
passDelayNow poller `shouldReturn` (pIdleSeconds * 1000000)
|
|
held <- async $ webGet client (invoicePath iid <> "?wait=open")
|
|
awaitWaitingCount env 1
|
|
passDelayNow poller `shouldReturn` (pWaitingSeconds * 1000000)
|
|
waitingCount (weWaiters env) `shouldReturn` 1
|
|
markPaidAndPublish env iid
|
|
_ <- wait held
|
|
passDelayNow poller `shouldReturn` (pIdleSeconds * 1000000)
|
|
|
|
passDelayNow :: PollerEnv -> IO Int
|
|
passDelayNow PollerEnv {peWaiters, pePoll} = passDelay pePoll <$> waitingCount peWaiters
|
|
|
|
testHintsDoNotPostponeThePass :: IO ()
|
|
testHintsDoNotPostponeThePass = bounded "hints do not postpone the pass" $ withStubPoller raceHold $ \ref _ env _ -> do
|
|
seedBadgePrice (weStore env) "price1"
|
|
mapM_ (\i -> seedOpenRef (weStore env) i (burstRef i) someExpiry) burstRefs
|
|
built <- newPollerEnv (weStore env) (weWaiters env) (weHints env) (weProviders env) PollConfig {pWaitingSeconds = 1, pIdleSeconds = 1}
|
|
let poller = built {peStrayEvery = 0}
|
|
setSignals ref [(burstRef i, settledSignal) | i <- burstRefs]
|
|
runOnePass poller
|
|
clearCalls ref
|
|
setReadDelay ref slowHintRead
|
|
mapM_ (\i -> queueReadHint (weHints env) (burstRef i) `shouldReturn` True) burstRefs
|
|
Async.withAsync (runPoller poller) $ \_ -> do
|
|
calls <- awaitCalls ref (\cs -> length (filter (== StubListOpen) cs) >= 2)
|
|
length (filter isRead calls) `shouldSatisfy` (< length burstRefs)
|
|
where
|
|
isRead = \case
|
|
StubRead _ -> True
|
|
_ -> False
|
|
|
|
burstRefs :: [Int]
|
|
burstRefs = [1 .. 10]
|
|
|
|
burstRef :: Int -> Text
|
|
burstRef i = "p-burst-" <> T.pack (show i)
|
|
|
|
slowHintRead :: Int
|
|
slowHintRead = 300000
|
|
|
|
awaitCalls :: IORef StubState -> ([StubCall] -> Bool) -> IO [StubCall]
|
|
awaitCalls ref p = do
|
|
calls <- stubCalls ref
|
|
if p calls then pure calls else threadDelay 10000 >> awaitCalls ref p
|
|
|
|
testWaiterCutsTheIdleSleepShort :: IO ()
|
|
testWaiterCutsTheIdleSleepShort = bounded "waiter cuts the sleep" $ withStubPoller raceHold $ \_ _ env client -> do
|
|
iid <- seedOpenInvoice env
|
|
poller <- newPollerEnv (weStore env) (weWaiters env) (weHints env) (weProviders env) PollConfig {pWaitingSeconds = 1, pIdleSeconds = 10}
|
|
started <- getCurrentTime
|
|
slept <- async (passDue poller >>= atomically)
|
|
threadDelay 200000
|
|
Async.poll slept >>= (`shouldSatisfy` isNothing)
|
|
held <- async $ webGet client (invoicePath iid <> "?wait=open")
|
|
wait slept
|
|
elapsed <- (`diffUTCTime` started) <$> getCurrentTime
|
|
elapsed `shouldSatisfy` (< 5)
|
|
elapsed `shouldSatisfy` (>= 0.9)
|
|
markPaidAndPublish env iid
|
|
_ <- wait held
|
|
pure ()
|
|
|
|
testCadenceHasAFloor :: IO ()
|
|
testCadenceHasAFloor = do
|
|
let zeroed = PollConfig {pWaitingSeconds = 0, pIdleSeconds = 0}
|
|
negated = PollConfig {pWaitingSeconds = -5, pIdleSeconds = -60}
|
|
map (passDelay zeroed) [1, 0] `shouldBe` [1000000, 1000000]
|
|
map (passDelay negated) [1, 0] `shouldBe` [1000000, 1000000]
|
|
map (passDelay PollConfig {pWaitingSeconds = 3, pIdleSeconds = 60}) [1, 0] `shouldBe` [3000000, 60000000]
|
|
|
|
testPollerWakesAHeldRequest :: IO ()
|
|
testPollerWakesAHeldRequest = bounded "poller wakes a hold" $ withStubPoller raceHold $ \ref poller env client -> do
|
|
iid <- seedOpenInvoice env
|
|
setSignals ref [(niProviderRef sampleInvoice, settledSignal)]
|
|
_ <- wokenBy client iid (runOnePass poller) "paid"
|
|
pure ()
|
|
|
|
testSweepExpiresPastTheGrace :: IO ()
|
|
testSweepExpiresPastTheGrace = bounded "expiry sweep" $ withStubPoller raceHold $ \ref poller env _ -> do
|
|
now <- getCurrentTime
|
|
seedBadgePrice (weStore env) "price1"
|
|
overdue <- seedOpenRef (weStore env) 1 "p-overdue" (addUTCTime (negate (expiryGrace + 60)) now)
|
|
inGrace <- seedOpenRef (weStore env) 2 "p-ingrace" (addUTCTime (negate (expiryGrace - 60)) now)
|
|
ahead <- seedOpenRef (weStore env) 3 "p-ahead" (addUTCTime 3600 now)
|
|
runOnePass poller
|
|
invoiceStatus (weStore env) overdue `shouldReturn` ISExpired
|
|
invoiceStatus (weStore env) inGrace `shouldReturn` ISOpen
|
|
invoiceStatus (weStore env) ahead `shouldReturn` ISOpen
|
|
stubCalls ref `shouldReturn` [StubRead "p-overdue", StubRead "p-ingrace", StubRead "p-ahead", StubListOpen]
|
|
|
|
testSweepWritesStatusAlone :: IO ()
|
|
testSweepWritesStatusAlone = bounded "sweep writes status alone" $ withStubPoller raceHold $ \ref poller env _ -> do
|
|
now <- getCurrentTime
|
|
seedBadgePrice (weStore env) "price1"
|
|
iid <- seedOpenRef (weStore env) 1 "p-1" (addUTCTime (negate (expiryGrace + 60)) now)
|
|
runOnePass poller
|
|
invoiceStatus (weStore env) iid `shouldReturn` ISExpired
|
|
Just row <- getInvoice (weStore env) iid
|
|
irPayment row `shouldBe` Nothing
|
|
setSignals ref [("p-1", SigClosed (rcv 200 (Just "0.00020000")))]
|
|
runOnePass poller
|
|
invoiceStatus (weStore env) iid `shouldReturn` ISExpired
|
|
p <- paymentRow (weStore env) iid
|
|
ipAmount p `shouldBe` Just (CurrencyAmount 200)
|
|
ipCryptoPaid p `shouldBe` Just "0.00020000"
|
|
|
|
testSweepWakesAHeldRequest :: IO ()
|
|
testSweepWakesAHeldRequest = bounded "sweep wakes a hold" $ withStubPoller raceHold $ \_ poller env client -> do
|
|
now <- getCurrentTime
|
|
seedBadgePrice (weStore env) "price1"
|
|
iid <- seedOpenRef (weStore env) 1 "p-overdue" (addUTCTime (negate (expiryGrace + 60)) now)
|
|
_ <- wokenBy client iid (runOnePass poller) "expired"
|
|
pure ()
|
|
|
|
withPayableStubPoller :: Int -> (IORef StubState -> PollerEnv -> WebEnv -> WebClient -> IO a) -> IO a
|
|
withPayableStubPoller = withStubPollerOf (\ref -> (stubProvider ref) {pProvider = PPStripe})
|
|
|
|
-- | Creates an order older than 72 hours, which only the expiry sweep still looks at. A higher i is newer.
|
|
seedPastWindow :: HasCallStack => DBStore -> Int -> Text -> PaymentProvider -> IO InvoiceId
|
|
seedPastWindow st i providerRef provider = do
|
|
now <- truncateToSecond <$> getCurrentTime
|
|
let createdAt = addUTCTime (negate (settleWindow + 3600) + fromIntegral i) now
|
|
iid = InvoiceId ("inv-old-" <> T.pack (show i))
|
|
ni = sampleInvoice {niInvoiceId = iid, niProviderRef = providerRef, niProvider = provider, niCodeHash = digestFixture (fromIntegral i + 60), niCreatedAt = createdAt, niExpiresAt = addUTCTime 3600 createdAt}
|
|
createInvoiceRows st ni `shouldReturn` Right ()
|
|
pure iid
|
|
|
|
-- | Runs one pass to get the list call out of the way, so the next pass only does the expiry sweep.
|
|
passListing :: IORef StubState -> PollerEnv -> IO ()
|
|
passListing ref poller = runOnePass poller >> clearCalls ref
|
|
|
|
stderrCaptureLock :: MVar ()
|
|
stderrCaptureLock = unsafePerformIO $ newMVar ()
|
|
{-# NOINLINE stderrCaptureLock #-}
|
|
|
|
capturingStderr :: IO () -> IO Text
|
|
capturingStderr action = withMVar stderrCaptureLock $ \_ -> do
|
|
createDirectoryIfMissing True "tests/tmp"
|
|
withTempDirectory "tests/tmp" "badge-stderr" $ \dir -> do
|
|
let path = dir </> "stderr.log"
|
|
withFile path WriteMode $ \h -> do
|
|
fd <- handleToFd h
|
|
hFlush stderr
|
|
saved <- IODevice.dup FD.stderr
|
|
(IODevice.dup2 fd FD.stderr >> action) `E.finally` (hFlush stderr >> IODevice.dup2 saved FD.stderr >> IODevice.close saved)
|
|
T.readFile path
|
|
|
|
loggedError :: Text -> Text -> Bool
|
|
loggedError message = any (\l -> "[ERROR " `T.isInfixOf` l && message `T.isInfixOf` l) . T.lines
|
|
|
|
failCancels :: IORef StubState -> IO ()
|
|
failCancels ref = atomicModifyIORef' ref $ \s -> (s {ssCancelError = Just (ProviderError "refused")}, ())
|
|
|
|
testSweepCancelsBeforeExpiring :: IO ()
|
|
testSweepCancelsBeforeExpiring = bounded "sweep cancels" $ withPayableStubPoller raceHold $ \ref poller env _ -> do
|
|
now <- getCurrentTime
|
|
seedBadgePrice (weStore env) "price1"
|
|
overdue <- seedOpenRefOf PPStripe (weStore env) 1 "p-overdue" (addUTCTime (negate (expiryGrace + 60)) now)
|
|
ahead <- seedOpenRefOf PPStripe (weStore env) 2 "p-ahead" (addUTCTime 3600 now)
|
|
runOnePass poller
|
|
invoiceStatus (weStore env) overdue `shouldReturn` ISExpired
|
|
invoiceStatus (weStore env) ahead `shouldReturn` ISOpen
|
|
stubCalls ref `shouldReturn` [StubRead "p-overdue", StubRead "p-ahead", StubListOpen, StubCancel "p-overdue"]
|
|
|
|
testSweepKeepsOpenWhenCancelFails :: IO ()
|
|
testSweepKeepsOpenWhenCancelFails = bounded "sweep cancel fails" $ withPayableStubPoller raceHold $ \ref poller env _ -> do
|
|
now <- getCurrentTime
|
|
seedBadgePrice (weStore env) "price1"
|
|
iid <- seedOpenRefOf PPStripe (weStore env) 1 "p-overdue" (addUTCTime (negate (expiryGrace + 60)) now)
|
|
failCancels ref
|
|
runOnePass poller
|
|
invoiceStatus (weStore env) iid `shouldReturn` ISOpen
|
|
atomicModifyIORef' ref $ \s -> (s {ssCancelError = Nothing}, ())
|
|
runOnePass poller
|
|
invoiceStatus (weStore env) iid `shouldReturn` ISExpired
|
|
filter (== StubCancel "p-overdue") <$> stubCalls ref `shouldReturn` [StubCancel "p-overdue", StubCancel "p-overdue"]
|
|
|
|
testSweepSettlesWhatItCannotCancel :: IO ()
|
|
testSweepSettlesWhatItCannotCancel = bounded "sweep settles uncancelled" $ withPayableStubPoller raceHold $ \ref poller env _ -> do
|
|
passListing ref poller
|
|
seedBadgePrice (weStore env) "price1"
|
|
iid <- seedPastWindow (weStore env) 1 "p-old" PPStripe
|
|
failCancels ref
|
|
setSignals ref [("p-old", settledSignal)]
|
|
runOnePass poller
|
|
invoiceStatus (weStore env) iid `shouldReturn` ISPaid
|
|
stubCalls ref `shouldReturn` [StubCancel "p-old", StubRead "p-old"]
|
|
|
|
testSweepExpiresWhatAReadShowsCancelled :: IO ()
|
|
testSweepExpiresWhatAReadShowsCancelled = bounded "sweep reads a cancel" $ withPayableStubPoller raceHold $ \ref poller env _ -> do
|
|
now <- getCurrentTime
|
|
seedBadgePrice (weStore env) "price1"
|
|
iid <- seedOpenRefOf PPStripe (weStore env) 1 "p-overdue" (addUTCTime (negate (expiryGrace + 60)) now)
|
|
atomicModifyIORef' ref $ \s -> (s {ssCancelLost = True}, ())
|
|
runOnePass poller
|
|
invoiceStatus (weStore env) iid `shouldReturn` ISExpired
|
|
stubCalls ref `shouldReturn` [StubRead "p-overdue", StubListOpen, StubCancel "p-overdue", StubRead "p-overdue"]
|
|
|
|
testSweepGivesUpPastTheWindow :: IO ()
|
|
testSweepGivesUpPastTheWindow = bounded "sweep gives up" $ withPayableStubPoller raceHold $ \ref poller env _ -> do
|
|
passListing ref poller
|
|
seedBadgePrice (weStore env) "price1"
|
|
iid <- seedPastWindow (weStore env) 1 "p-old" PPStripe
|
|
failCancels ref
|
|
firstLog <- capturingStderr (runOnePass poller >> runOnePass poller)
|
|
invoiceStatus (weStore env) iid `shouldReturn` ISOpen
|
|
firstLog `shouldNotSatisfy` T.isInfixOf "expired here only"
|
|
failedAnHourAgo poller "p-old"
|
|
lastLog <- capturingStderr (runOnePass poller)
|
|
invoiceStatus (weStore env) iid `shouldReturn` ISExpired
|
|
loggedError "invoice p-old could not be cancelled at the provider, so it was expired here only" lastLog `shouldBe` True
|
|
let attempt = [StubCancel "p-old", StubRead "p-old"]
|
|
stubCalls ref `shouldReturn` concat (replicate 3 attempt)
|
|
runOnePass poller
|
|
stubCalls ref `shouldReturn` concat (replicate 3 attempt)
|
|
|
|
testSweepExpiresWithoutItsProvider :: IO ()
|
|
testSweepExpiresWithoutItsProvider = bounded "sweep without provider" $ withStubPoller raceHold $ \ref poller env _ -> do
|
|
passListing ref poller
|
|
seedBadgePrice (weStore env) "price1"
|
|
iid <- seedPastWindow (weStore env) 1 "p-old" PPStripe
|
|
runOnePass poller
|
|
invoiceStatus (weStore env) iid `shouldReturn` ISOpen
|
|
failedAnHourAgo poller "p-old"
|
|
logged <- capturingStderr (runOnePass poller)
|
|
invoiceStatus (weStore env) iid `shouldReturn` ISExpired
|
|
loggedError "no provider is configured for it" logged `shouldBe` True
|
|
stubCalls ref `shouldReturn` []
|
|
|
|
testSweepKeepsFailuresBeyondTheCap :: IO ()
|
|
testSweepKeepsFailuresBeyondTheCap = bounded "sweep keeps failures past the cap" $ withPayableStubPoller raceHold $ \ref poller env _ -> do
|
|
passListing ref poller
|
|
seedBadgePrice (weStore env) "price1"
|
|
let count = readsPerPass + 1
|
|
newest = "p-" <> T.pack (show count)
|
|
mapM_ (\i -> seedPastWindow (weStore env) i ("p-" <> T.pack (show i)) PPStripe) [1 .. count]
|
|
failCancels ref
|
|
failedAnHourAgo poller newest
|
|
runOnePass poller
|
|
stubCalls ref >>= (`shouldNotSatisfy` elem (StubCancel newest))
|
|
Map.member newest <$> readTVarIO (peCancelFailed poller) `shouldReturn` True
|
|
|
|
-- | Pretends the first cancel failure was an hour ago, so the test doesn't have to wait.
|
|
failedAnHourAgo :: PollerEnv -> Text -> IO ()
|
|
failedAnHourAgo PollerEnv {peCancelFailed} ref = do
|
|
now <- getCurrentTime
|
|
atomically $ modifyTVar' peCancelFailed (Map.insert ref (addUTCTime (negate cancelGiveUpDelay) now))
|
|
|
|
testSweepWarnsOncePerOrder :: IO ()
|
|
testSweepWarnsOncePerOrder = bounded "sweep warns once" $ withPayableStubPoller raceHold $ \ref poller env _ -> do
|
|
now <- getCurrentTime
|
|
seedBadgePrice (weStore env) "price1"
|
|
iid <- seedOpenRefOf PPStripe (weStore env) 1 "p-overdue" (addUTCTime (negate (expiryGrace + 60)) now)
|
|
failCancels ref
|
|
let warnings = Map.filterWithKey (\k _ -> "p-overdue" `T.isInfixOf` k) <$> readTVarIO (peSkipped poller)
|
|
runOnePass poller
|
|
first <- warnings
|
|
Map.size first `shouldBe` 1
|
|
runOnePass poller
|
|
warnings `shouldReturn` first
|
|
invoiceStatus (weStore env) iid `shouldReturn` ISOpen
|
|
|
|
testSweepCapsCancelsPerPass :: IO ()
|
|
testSweepCapsCancelsPerPass = bounded "sweep caps cancels" $ withPayableStubPoller raceHold $ \ref poller env _ -> do
|
|
now <- getCurrentTime
|
|
seedBadgePrice (weStore env) "price1"
|
|
let count = readsPerPass + 1
|
|
iids <- mapM (\i -> seedOpenRefOf PPStripe (weStore env) i ("p-" <> T.pack (show i)) (addUTCTime (negate (expiryGrace + 60)) now)) [1 .. count]
|
|
let cancels = length . filter isCancel <$> stubCalls ref
|
|
isCancel = \case
|
|
StubCancel _ -> True
|
|
_ -> False
|
|
expiredCount = length . filter (== ISExpired) <$> mapM (invoiceStatus (weStore env)) iids
|
|
runOnePass poller
|
|
cancels `shouldReturn` readsPerPass
|
|
expiredCount `shouldReturn` readsPerPass
|
|
runOnePass poller
|
|
cancels `shouldReturn` count
|
|
expiredCount `shouldReturn` count
|
|
|
|
testSkipWarningsAreRateLimited :: IO ()
|
|
testSkipWarningsAreRateLimited = bounded "skip warnings" $ withStubPoller raceHold $ \ref poller env _ -> do
|
|
let reason = "btcpay invoice SOMEONEELSESINVOICE: unknown status Frobnicated"
|
|
onwards t = addUTCTime t settleAt
|
|
dueToWarn poller settleAt reason `shouldReturn` True
|
|
dueToWarn poller (onwards 3) reason `shouldReturn` False
|
|
dueToWarn poller (onwards (skipWarnInterval - 1)) reason `shouldReturn` False
|
|
dueToWarn poller (onwards skipWarnInterval) reason `shouldReturn` True
|
|
dueToWarn poller (onwards skipWarnInterval) "btcpay invoice OTHER: unknown status Frobnicated" `shouldReturn` True
|
|
seedBadgePrice (weStore env) "price1"
|
|
iid <- seedOpenRef (weStore env) 1 "p-1" someExpiry
|
|
setSkipped ref [(Just "SOMEONEELSESINVOICE", reason)]
|
|
setSignals ref [("p-1", settledSignal)]
|
|
runOnePass poller
|
|
invoiceStatus (weStore env) iid `shouldReturn` ISPaid
|
|
|
|
testSkipNamingOurInvoiceIsRaised :: IO ()
|
|
testSkipNamingOurInvoiceIsRaised = bounded "skip ownership" $ withStubPoller raceHold $ \ref poller env _ -> do
|
|
seedBadgePrice (weStore env) "price1"
|
|
_ <- seedOpenRef (weStore env) 1 "p-ours" someExpiry
|
|
skipOwner poller PPCrypto (Just "p-ours") `shouldReturn` SkipOurs
|
|
skipOwner poller PPCrypto (Just "SOMEONEELSESINVOICE") `shouldReturn` SkipStranger
|
|
skipOwner poller PPCrypto Nothing `shouldReturn` SkipUnaccounted
|
|
_ <- seedOtherProvider (weStore env) 3 "p-stripe-skip"
|
|
skipOwner poller PPCrypto (Just "p-stripe-skip") `shouldReturn` SkipStranger
|
|
iid <- seedOpenRef (weStore env) 2 "p-2" someExpiry
|
|
setSkipped
|
|
ref
|
|
[ (Just "p-ours", "btcpay invoice p-ours: unknown status Frobnicated"),
|
|
(Just "SOMEONEELSESINVOICE", "btcpay invoice SOMEONEELSESINVOICE: unknown status Frobnicated")
|
|
]
|
|
setSignals ref [("p-2", settledSignal)]
|
|
runOnePass poller
|
|
invoiceStatus (weStore env) iid `shouldReturn` ISPaid
|
|
|
|
testSkipReasonsStayBounded :: IO ()
|
|
testSkipReasonsStayBounded = bounded "skip reasons bounded" $ withStubPoller raceHold $ \_ poller _ _ -> do
|
|
now <- getCurrentTime
|
|
forM_ [1 .. maxSkipReasons + 500] $ \i -> dueToWarn poller now ("btcpay invoice p-" <> tshow i <> ": unknown method")
|
|
runOnePass poller
|
|
held <- Map.size <$> readTVarIO (peSkipped poller)
|
|
held `shouldSatisfy` (<= maxSkipReasons)
|
|
|
|
testStrangerSkipsShareOneWarning :: IO ()
|
|
testStrangerSkipsShareOneWarning = bounded "stranger skips" $ withStubPoller raceHold $ \ref poller _ _ -> do
|
|
setSkipped ref [(Just ("stranger-" <> tshow i), "btcpay invoice stranger-" <> tshow i <> ": unknown method") | i <- [1 .. 3 :: Int]]
|
|
runOnePass poller
|
|
Map.size <$> readTVarIO (peSkipped poller) `shouldReturn` 1
|
|
|
|
-- | The failure text carries the whole request, whose window moves with the clock, so the two
|
|
-- messages differ only in startDate to prove the limiter key ignores it rather than warning
|
|
-- every pass.
|
|
testOutageWarnsOnceNotEveryPass :: IO ()
|
|
testOutageWarnsOnceNotEveryPass = bounded "outage warnings" $ withStubPoller raceHold $ \ref poller _ _ -> do
|
|
let warnKeys PollerEnv {peSkipped} = Map.size <$> readTVarIO peSkipped
|
|
failList ref (Just (ProviderError "list invoices failed: ... startDate=1000000 ..."))
|
|
runOnePass poller
|
|
warnKeys poller `shouldReturn` 1
|
|
failList ref (Just (ProviderError "list invoices failed: ... startDate=1000003 ..."))
|
|
runOnePass poller
|
|
warnKeys poller `shouldReturn` 1
|
|
|
|
testOneBadInvoiceDoesNotStopThePass :: IO ()
|
|
testOneBadInvoiceDoesNotStopThePass = bounded "one bad invoice" $ withStubPoller raceHold $ \ref poller env _ -> do
|
|
now <- getCurrentTime
|
|
seedBadgePrice (weStore env) "price1"
|
|
InvoiceId badId <- seedOpenRef (weStore env) 1 "p-bad" (addUTCTime 3600 now)
|
|
good <- seedOpenRef (weStore env) 2 "p-good" (addUTCTime 3600 now)
|
|
overdue <- seedOpenRef (weStore env) 3 "p-overdue" (addUTCTime (negate (expiryGrace + 60)) now)
|
|
-- Setting the provider to a value this build does not know makes reading the row throw rather
|
|
-- than answer.
|
|
withConnection (weStore env) $ \db ->
|
|
DB.execute db "UPDATE sx_badge_service_invoices SET provider = ? WHERE invoice_id = ?" ("nonsense" :: Text, badId)
|
|
|
|
setSignals ref [("p-bad", settledSignal), ("p-good", settledSignal)]
|
|
runOnePass poller
|
|
invoiceStatus (weStore env) good `shouldReturn` ISPaid
|
|
invoiceStatus (weStore env) overdue `shouldReturn` ISOpen
|
|
|
|
setSignals ref []
|
|
setSkipped ref [(Just "p-bad", "some reason the provider gave")]
|
|
runOnePass poller
|
|
invoiceStatus (weStore env) overdue `shouldReturn` ISOpen
|
|
|
|
testSweepWaitsForAPassThatSawEverything :: IO ()
|
|
testSweepWaitsForAPassThatSawEverything = bounded "sweep guards" $ withStubPoller raceHold $ \ref poller env _ -> do
|
|
now <- getCurrentTime
|
|
seedBadgePrice (weStore env) "price1"
|
|
overdue <- seedOpenRef (weStore env) 1 "p-overdue" (addUTCTime (-3600) now)
|
|
let stillOpen :: Text -> IO ()
|
|
stillOpen why = do
|
|
runOnePass poller
|
|
(why, ) <$> invoiceStatus (weStore env) overdue `shouldReturn` (why, ISOpen)
|
|
failRead ref (Just (ProviderError "connection refused"))
|
|
stillOpen "the reads never answered"
|
|
failRead ref Nothing
|
|
mapM_ (\i -> seedOpenRef (weStore env) i ("p-bulk-" <> tshow i) someExpiry) [2 .. readsPerPass + 2]
|
|
setSkipped ref [(Just "p-overdue", "btcpay invoice p-overdue: unknown status Frobnicated")]
|
|
stillOpen "it answered and left one of ours unread"
|
|
setSkipped ref [(Nothing, "btcpay: the list stopped at 50 pages")]
|
|
stillOpen "it stopped early without saying whose invoices it missed"
|
|
setSkipped ref []
|
|
runOnePass poller
|
|
invoiceStatus (weStore env) overdue `shouldReturn` ISExpired
|
|
|
|
testListPaginates :: IO ()
|
|
testListPaginates = bounded "paging" $ withFakeProvider $ \fake p -> do
|
|
refs <- replicateM (listPageSize + 1) (piProviderRef <$> createdAtFake p)
|
|
case reverse refs of
|
|
[] -> failWith "no invoices were created"
|
|
(onSecondPage : _) -> do
|
|
setInvoiceState fake onSecondPage ["status" .= ("Settled" :: Text), "paymentMethodPaid" .= ("0.00050000" :: Text)]
|
|
pListOpen p >>= \case
|
|
Left e -> failWith ("expected a list, got " <> show e)
|
|
Right ListPass {lpMoved} -> map fst lpMoved `shouldSatisfy` elem onSecondPage
|
|
gets <- apiRequests fake "GET" ["invoices"]
|
|
let pageOf FakeRequest {frQuery} = (join (lookup "take" frQuery), join (lookup "skip" frQuery))
|
|
size = BC.pack (show listPageSize)
|
|
map pageOf gets `shouldBe` [(Just size, Just "0"), (Just size, Just size)]
|
|
|
|
testPagingStopsAtTheCeiling :: IO ()
|
|
testPagingStopsAtTheCeiling = bounded "paging ceiling" $ withFakeProvider $ \fake p -> do
|
|
ignoreListPaging fake
|
|
replicateM_ listPageSize (void (createdAtFake p))
|
|
r <- pListOpen p
|
|
gets <- apiRequests fake "GET" ["invoices"]
|
|
length gets `shouldBe` maxListPages
|
|
case r of
|
|
Left e -> failWith ("expected a list, got " <> show e)
|
|
Right ListPass {lpSkipped} -> do
|
|
map snd lpSkipped `shouldSatisfy` any (T.isInfixOf "stopped at")
|
|
map snd lpSkipped `shouldSatisfy` any (T.isInfixOf (T.pack (show (maxListPages * listPageSize))))
|
|
map fst lpSkipped `shouldSatisfy` all isNothing
|
|
|
|
createdAtFake :: HasCallStack => Provider -> IO ProviderInvoice
|
|
createdAtFake p =
|
|
pCreateInvoice p (SPMCrypto CCBtc) sampleDraft >>= \case
|
|
Right inv -> pure inv
|
|
Left e -> failWith ("expected an invoice at the fake, got " <> show e)
|
|
|
|
webhookPath :: String
|
|
webhookPath = "/webhooks/btcpay"
|
|
|
|
hookRef :: Text
|
|
hookRef = "p-hooked"
|
|
|
|
hookedEvent :: LB.ByteString
|
|
hookedEvent = webhookEvent "InvoiceSettled" hookRef
|
|
|
|
someSig :: [Header]
|
|
someSig = webhookSigHeader "not-the-secret" hookedEvent
|
|
|
|
postWebhook :: WebClient -> [Header] -> LB.ByteString -> IO (Response LB.ByteString)
|
|
postWebhook client hdrs = webRequestBody client "POST" webhookPath hdrs
|
|
|
|
slowProviderRead :: Int
|
|
slowProviderRead = 1000000
|
|
|
|
testWebhookVerifiesARealSignature :: IO ()
|
|
testWebhookVerifiesARealSignature = bounded "real signature" $ withFakePoller $ \fake poller env client -> do
|
|
r <- postCreateAs client 1 (createBody supporterPriceId Nothing "xmr" (codeHashText sampleCode))
|
|
statusOf r `shouldBe` 200
|
|
o <- jsonObject r
|
|
iid <- InvoiceId <$> stringField o "invoiceId"
|
|
Just row <- getInvoice (weStore env) iid
|
|
let secret = bWebhookSecret (fbConfig fake)
|
|
body = webhookEvent "InvoiceSettled" (irProviderRef row)
|
|
delivered <- postWebhook client (webhookSigHeader secret body) body
|
|
statusOf delivered `shouldBe` 200
|
|
responseBody delivered `shouldBe` ""
|
|
tampered <- postWebhook client (webhookSigHeader secret body) (body <> " ")
|
|
statusOf tampered `shouldBe` 400
|
|
responseBody tampered `shouldBe` ""
|
|
unsigned <- postWebhook client [] body
|
|
statusOf unsigned `shouldBe` 400
|
|
invoiceStatus (weStore env) iid `shouldReturn` ISOpen
|
|
setInvoiceState fake (irProviderRef row) ["status" .= ("Settled" :: Text), "paymentMethodPaid" .= ("0.32095000" :: Text)]
|
|
drainHints poller
|
|
invoiceStatus (weStore env) iid `shouldReturn` ISPaid
|
|
bcPaymentStatus <$> settledCode (weStore env) iid `shouldReturn` CPSPaid
|
|
|
|
testWebhookPassesTheRawBytes :: IO ()
|
|
testWebhookPassesTheRawBytes = bounded "raw bytes" $ withStubPoller raceHold $ \ref _ env client -> do
|
|
seedBadgePrice (weStore env) "price1"
|
|
_ <- seedOpenRef (weStore env) 1 hookRef someExpiry
|
|
setVerifyResult ref (Right (Just hookRef))
|
|
let hdrs = webhookSigHeader "any-secret" hookedEvent
|
|
r <- postWebhook client hdrs hookedEvent
|
|
statusOf r `shouldBe` 200
|
|
stubWebhooks ref >>= \case
|
|
[(seenHdrs, seenBody)] -> do
|
|
seenBody `shouldBe` LB.toStrict hookedEvent
|
|
lookup "BTCPay-Sig" seenHdrs `shouldBe` lookup "BTCPay-Sig" hdrs
|
|
other -> failWith ("expected one verify call, got " <> show (length other))
|
|
case J.decode hookedEvent :: Maybe J.Value of
|
|
Nothing -> failWith "the event body is not JSON"
|
|
Just parsed -> J.encode parsed `shouldSatisfy` (/= hookedEvent)
|
|
|
|
testWebhookQueuesARead :: IO ()
|
|
testWebhookQueuesARead = bounded "webhook queues" $ withStubPoller raceHold $ \ref _ env client -> do
|
|
seedBadgePrice (weStore env) "price1"
|
|
iid <- seedOpenRef (weStore env) 1 hookRef someExpiry
|
|
setVerifyResult ref (Right (Just hookRef))
|
|
r <- postWebhook client someSig hookedEvent
|
|
statusOf r `shouldBe` 200
|
|
responseBody r `shouldBe` ""
|
|
headerOf r hCacheControl `shouldBe` Just "no-store"
|
|
stubCalls ref `shouldReturn` []
|
|
invoiceStatus (weStore env) iid `shouldReturn` ISOpen
|
|
Just row <- getInvoice (weStore env) iid
|
|
irPayment row `shouldBe` Nothing
|
|
|
|
testWebhookSettlesByThePollerPath :: IO ()
|
|
testWebhookSettlesByThePollerPath = bounded "one settlement lane" $ withStubPoller raceHold $ \ref poller env client -> do
|
|
seedBadgePrice (weStore env) "price1"
|
|
hinted <- seedOpenRef (weStore env) 1 hookRef someExpiry
|
|
listed <- seedOpenRef (weStore env) 2 "p-listed" someExpiry
|
|
setSignals ref [(hookRef, settledSignal), ("p-listed", settledSignal)]
|
|
setVerifyResult ref (Right (Just hookRef))
|
|
r <- postWebhook client someSig hookedEvent
|
|
statusOf r `shouldBe` 200
|
|
invoiceStatus (weStore env) hinted `shouldReturn` ISOpen
|
|
drainHints poller
|
|
stubCalls ref `shouldReturn` [StubRead hookRef]
|
|
invoiceStatus (weStore env) hinted `shouldReturn` ISPaid
|
|
bcPaymentStatus <$> settledCode (weStore env) hinted `shouldReturn` CPSPaid
|
|
ipStatus <$> paymentRow (weStore env) hinted `shouldReturn` "settled"
|
|
runOnePass poller
|
|
invoiceStatus (weStore env) listed `shouldReturn` ISPaid
|
|
bcPaymentStatus <$> settledCode (weStore env) listed `shouldReturn` CPSPaid
|
|
ipStatus <$> paymentRow (weStore env) listed `shouldReturn` "settled"
|
|
|
|
testWebhookDoesNotWaitOnTheProvider :: IO ()
|
|
testWebhookDoesNotWaitOnTheProvider = bounded "webhook does not wait" $ withStubPoller raceHold $ \ref _ env client -> do
|
|
seedBadgePrice (weStore env) "price1"
|
|
_ <- seedOpenRef (weStore env) 1 hookRef someExpiry
|
|
setSignals ref [(hookRef, settledSignal)]
|
|
setVerifyResult ref (Right (Just hookRef))
|
|
setReadDelay ref slowProviderRead
|
|
started <- getCurrentTime
|
|
r <- postWebhook client someSig hookedEvent
|
|
elapsed <- (`diffUTCTime` started) <$> getCurrentTime
|
|
statusOf r `shouldBe` 200
|
|
elapsed `shouldSatisfy` (< 0.5)
|
|
stubCalls ref `shouldReturn` []
|
|
|
|
testWebhookRefusesASignature :: IO ()
|
|
testWebhookRefusesASignature = bounded "webhook refuses" $ withStubPoller raceHold $ \ref poller env client -> do
|
|
seedBadgePrice (weStore env) "price1"
|
|
iid <- seedOpenRef (weStore env) 1 hookRef someExpiry
|
|
setSignals ref [(hookRef, settledSignal)]
|
|
setVerifyResult ref (Left (WebhookError "BTCPay-Sig does not verify"))
|
|
r <- postWebhook client someSig hookedEvent
|
|
statusOf r `shouldBe` 400
|
|
responseBody r `shouldBe` ""
|
|
drainHints poller
|
|
stubCalls ref `shouldReturn` []
|
|
invoiceStatus (weStore env) iid `shouldReturn` ISOpen
|
|
|
|
testWebhookIgnoresWhatItCannotActOn :: IO ()
|
|
testWebhookIgnoresWhatItCannotActOn = bounded "webhook ignores" $ withStubPoller raceHold $ \ref poller env client -> do
|
|
seedBadgePrice (weStore env) "price1"
|
|
ours <- seedOpenRef (weStore env) 1 hookRef someExpiry
|
|
otherLane <- seedOtherProvider (weStore env) 2 "p-stripe"
|
|
setSignals ref [(hookRef, settledSignal), ("p-stripe", settledSignal)]
|
|
setVerifyResult ref (Right Nothing)
|
|
unhandled <- postWebhook client someSig (webhookEvent "InvoiceReceivedPayment" hookRef)
|
|
statusOf unhandled `shouldBe` 200
|
|
responseBody unhandled `shouldBe` ""
|
|
setVerifyResult ref (Right (Just "p-no-such-invoice"))
|
|
unknown <- postWebhook client someSig (webhookEvent "InvoiceSettled" "p-no-such-invoice")
|
|
statusOf unknown `shouldBe` 200
|
|
responseBody unknown `shouldBe` ""
|
|
setVerifyResult ref (Right (Just "p-stripe"))
|
|
crossed <- postWebhook client someSig (webhookEvent "InvoiceSettled" "p-stripe")
|
|
statusOf crossed `shouldBe` 200
|
|
responseBody crossed `shouldBe` ""
|
|
drainHints poller
|
|
stubCalls ref `shouldReturn` []
|
|
invoiceStatus (weStore env) ours `shouldReturn` ISOpen
|
|
invoiceStatus (weStore env) otherLane `shouldReturn` ISOpen
|
|
|
|
testWebhookRefusesAnOversizedBody :: IO ()
|
|
testWebhookRefusesAnOversizedBody = bounded "webhook body cap" $ withStubPoller raceHold $ \ref _ _ client -> do
|
|
setVerifyResult ref (Left (WebhookError "BTCPay-Sig does not verify"))
|
|
atCap <- postWebhook client someSig (LB.replicate (fromIntegral maxWebhookBytes) 'x')
|
|
statusOf atCap `shouldBe` 400
|
|
length <$> stubWebhooks ref `shouldReturn` 1
|
|
over <- postWebhook client someSig (LB.replicate (fromIntegral maxWebhookBytes + 1) 'x')
|
|
statusOf over `shouldBe` 413
|
|
responseBody over `shouldBe` ""
|
|
length <$> stubWebhooks ref `shouldReturn` 1
|
|
|
|
testReadHintQueuedOnce :: IO ()
|
|
testReadHintQueuedOnce = bounded "hint queued once" $ withStubPoller raceHold $ \ref poller env _ -> do
|
|
seedBadgePrice (weStore env) "price1"
|
|
_ <- seedOpenRef (weStore env) 1 hookRef someExpiry
|
|
replicateM_ 5 (queueReadHint (weHints env) hookRef `shouldReturn` True)
|
|
drainHints poller
|
|
stubCalls ref `shouldReturn` [StubRead hookRef]
|
|
queueReadHint (weHints env) hookRef `shouldReturn` True
|
|
drainHints poller
|
|
stubCalls ref `shouldReturn` [StubRead hookRef, StubRead hookRef]
|
|
|
|
testWebhookDropsAHintWhenFull :: IO ()
|
|
testWebhookDropsAHintWhenFull = bounded "full hint queue" $ withStubPoller raceHold $ \ref poller env client -> do
|
|
seedBadgePrice (weStore env) "price1"
|
|
iid <- seedOpenRef (weStore env) 1 hookRef someExpiry
|
|
setSignals ref [(hookRef, settledSignal)]
|
|
let fillers = ["p-filler-" <> T.pack (show i) | i <- [1 .. hintQueueSize]]
|
|
mapM (queueReadHint (weHints env)) fillers `shouldReturn` map (const True) fillers
|
|
queueReadHint (weHints env) "p-one-more" `shouldReturn` False
|
|
setVerifyResult ref (Right (Just hookRef))
|
|
r <- postWebhook client someSig hookedEvent
|
|
statusOf r `shouldBe` 200
|
|
responseBody r `shouldBe` ""
|
|
drainHints poller
|
|
invoiceStatus (weStore env) iid `shouldReturn` ISOpen
|
|
runOnePass poller
|
|
invoiceStatus (weStore env) iid `shouldReturn` ISPaid
|
|
|
|
testWebhookNeverAnswers5xx :: IO ()
|
|
testWebhookNeverAnswers5xx = bounded "webhook never 5xx" $ withStubPoller raceHold $ \ref _ env client -> do
|
|
seedBadgePrice (weStore env) "price1"
|
|
_ <- seedOpenRef (weStore env) 1 hookRef someExpiry
|
|
setVerifyThrows ref True
|
|
threw <- postWebhook client someSig hookedEvent
|
|
statusOf threw `shouldBe` 200
|
|
responseBody threw `shouldBe` ""
|
|
setVerifyThrows ref False
|
|
setVerifyResult ref (Right (Just hookRef))
|
|
breakStore (weStore env)
|
|
r <- postWebhook client someSig hookedEvent
|
|
statusOf r `shouldBe` 200
|
|
responseBody r `shouldBe` ""
|
|
stubCalls ref `shouldReturn` []
|
|
|
|
paidInFull, paidInPart :: Text
|
|
paidInFull = "0.00050000"
|
|
paidInPart = "0.00020000"
|
|
|
|
fullyPaid, partlyPaid :: J.Value
|
|
fullyPaid = J.Number 5400
|
|
partlyPaid = J.Number 2160
|
|
|
|
buyBadge :: HasCallStack => WebEnv -> WebClient -> Int -> Text -> IO (InvoiceId, Text)
|
|
buyBadge env client i code = do
|
|
r <- postCreateAs client i (createBody supporterPriceId Nothing "btc" (codeHashText code))
|
|
statusOf r `shouldBe` 200
|
|
o <- jsonObject r
|
|
iid <- InvoiceId <$> stringField o "invoiceId"
|
|
getInvoice (weStore env) iid >>= \case
|
|
Just InvoiceRow {irProviderRef} -> pure (iid, irProviderRef)
|
|
Nothing -> failWith "the create answered 200 and wrote no invoice row"
|
|
|
|
atProvider :: FakeBTCPay -> Text -> Text -> Text -> Text -> IO ()
|
|
atProvider fake ref status additional paid =
|
|
atProviderDue fake ref status additional paid (if paid == paidInFull then "0.00000000" else dueAfterPart)
|
|
|
|
atProviderDue :: FakeBTCPay -> Text -> Text -> Text -> Text -> Text -> IO ()
|
|
atProviderDue fake ref status additional paid due =
|
|
setInvoiceState fake ref ["status" .= status, "additionalStatus" .= additional, "paymentMethodPaid" .= paid, "due" .= due]
|
|
|
|
dueAfterPart :: Text
|
|
dueAfterPart = "0.00030500"
|
|
|
|
viewInvoice :: HasCallStack => WebClient -> InvoiceId -> IO J.Object
|
|
viewInvoice client iid = do
|
|
r <- webGet client (invoicePath iid)
|
|
statusOf r `shouldBe` 200
|
|
headerOf r hCacheControl `shouldBe` Just "no-store"
|
|
jsonObject r
|
|
|
|
scenarioPaidPurchase :: IO ()
|
|
scenarioPaidPurchase = bounded "scenario: paid purchase" $ withFakePoller $ \fake poller env client -> do
|
|
(iid, ref) <- buyBadge env client 1 sampleCode
|
|
unpaid <- viewInvoice client iid
|
|
fieldOf unpaid "status" `shouldBe` Just (J.String "open")
|
|
fieldOf unpaid "amountPaid" `shouldBe` Nothing
|
|
fieldOf unpaid "cryptoAmountPaid" `shouldBe` Nothing
|
|
atProvider fake ref "Settled" "None" paidInFull
|
|
runOnePass poller
|
|
paid <- viewInvoice client iid
|
|
fieldOf paid "status" `shouldBe` Just (J.String "paid")
|
|
fieldOf paid "amountPaid" `shouldBe` Just fullyPaid
|
|
fieldOf paid "cryptoAmountPaid" `shouldBe` Just (J.String paidInFull)
|
|
fieldOf paid "settledAt" `shouldSatisfy` isJust
|
|
p <- paymentRow (weStore env) iid
|
|
ipStatus p `shouldBe` "settled"
|
|
code <- settledCode (weStore env) iid
|
|
bcPaymentStatus code `shouldBe` CPSPaid
|
|
bcExpiresAt code `shouldBe` Just (addUTCTime codeLifetime (ipUpdatedAt p))
|
|
|
|
scenarioHeldWaitWakes :: IO ()
|
|
scenarioHeldWaitWakes = bounded "scenario: held wait" $ withFakePollerHolding raceHold $ \fake poller env client -> do
|
|
(iid, ref) <- buyBadge env client 1 sampleCode
|
|
held <- async $ webGet client (invoicePath iid <> "?wait=open")
|
|
threadDelay 100000
|
|
Async.poll held >>= \parked -> parked `shouldSatisfy` isNothing
|
|
atProvider fake ref "Settled" "None" paidInFull
|
|
settling <- getCurrentTime
|
|
runOnePass poller
|
|
r <- wait held
|
|
elapsed <- (`diffUTCTime` settling) <$> getCurrentTime
|
|
statusOf r `shouldBe` 200
|
|
o <- jsonObject r
|
|
fieldOf o "status" `shouldBe` Just (J.String "paid")
|
|
fieldOf o "amountPaid" `shouldBe` Just fullyPaid
|
|
elapsed `shouldSatisfy` (< 1)
|
|
invoiceStatus (weStore env) iid `shouldReturn` ISPaid
|
|
|
|
scenarioPartPaymentIsReported :: IO ()
|
|
scenarioPartPaymentIsReported = bounded "scenario: part paid" $ withFakePoller $ \fake poller env client -> do
|
|
(iid, ref) <- buyBadge env client 1 sampleCode
|
|
atProvider fake ref "New" "PaidPartial" paidInPart
|
|
runOnePass poller
|
|
o <- viewInvoice client iid
|
|
fieldOf o "status" `shouldBe` Just (J.String "open")
|
|
fieldOf o "amountPaid" `shouldBe` Just partlyPaid
|
|
fieldOf o "cryptoAmountPaid" `shouldBe` Just (J.String paidInPart)
|
|
-- The due figure is the provider's own, which includes the network fee a partial payment adds,
|
|
-- so it is 0.00030500 rather than the 0.00030000 a subtraction would give.
|
|
fieldOf o "cryptoAmountDue" `shouldBe` Just (J.String dueAfterPart)
|
|
fieldOf o "settledAt" `shouldBe` Nothing
|
|
invoiceStatus (weStore env) iid `shouldReturn` ISOpen
|
|
ipStatus <$> paymentRow (weStore env) iid `shouldReturn` "pending"
|
|
code <- settledCode (weStore env) iid
|
|
bcPaymentStatus code `shouldBe` CPSUnpaid
|
|
bcExpiresAt code `shouldBe` Nothing
|
|
|
|
scenarioExpiryReportsWhatArrived :: IO ()
|
|
scenarioExpiryReportsWhatArrived = bounded "scenario: expired part paid" $ withFakePoller $ \fake poller env client -> do
|
|
(iid, ref) <- buyBadge env client 1 sampleCode
|
|
atProvider fake ref "Expired" "PaidPartial" paidInPart
|
|
runOnePass poller
|
|
o <- viewInvoice client iid
|
|
fieldOf o "status" `shouldBe` Just (J.String "expired")
|
|
fieldOf o "amountPaid" `shouldBe` Just partlyPaid
|
|
fieldOf o "cryptoAmountPaid" `shouldBe` Just (J.String paidInPart)
|
|
fieldOf o "settledAt" `shouldBe` Nothing
|
|
invoiceStatus (weStore env) iid `shouldReturn` ISExpired
|
|
ipStatus <$> paymentRow (weStore env) iid `shouldReturn` "pending"
|
|
code <- settledCode (weStore env) iid
|
|
bcPaymentStatus code `shouldBe` CPSUnpaid
|
|
bcExpiresAt code `shouldBe` Nothing
|
|
|
|
scenarioLateSettlement :: IO ()
|
|
scenarioLateSettlement = bounded "scenario: late settlement" $ withFakePoller $ \fake poller env client -> do
|
|
(iid, ref) <- buyBadge env client 1 sampleCode
|
|
atProvider fake ref "Expired" "PaidPartial" paidInPart
|
|
runOnePass poller
|
|
expired <- viewInvoice client iid
|
|
fieldOf expired "status" `shouldBe` Just (J.String "expired")
|
|
fieldOf expired "amountPaid" `shouldBe` Just partlyPaid
|
|
invoiceStatus (weStore env) iid `shouldReturn` ISExpired
|
|
bcPaymentStatus <$> settledCode (weStore env) iid `shouldReturn` CPSUnpaid
|
|
atProvider fake ref "Settled" "PaidLate" paidInFull
|
|
runOnePass poller
|
|
paid <- viewInvoice client iid
|
|
fieldOf paid "status" `shouldBe` Just (J.String "paid")
|
|
fieldOf paid "amountPaid" `shouldBe` Just fullyPaid
|
|
fieldOf paid "cryptoAmountPaid" `shouldBe` Just (J.String paidInFull)
|
|
fieldOf paid "settledAt" `shouldSatisfy` isJust
|
|
invoiceStatus (weStore env) iid `shouldReturn` ISPaid
|
|
p <- paymentRow (weStore env) iid
|
|
ipStatus p `shouldBe` "settled"
|
|
code <- settledCode (weStore env) iid
|
|
bcPaymentStatus code `shouldBe` CPSPaid
|
|
bcExpiresAt code `shouldBe` Just (addUTCTime codeLifetime (ipUpdatedAt p))
|
|
|
|
scenarioReplayChangesNothing :: IO ()
|
|
scenarioReplayChangesNothing = bounded "scenario: replay" $ withFakePoller $ \fake poller env client -> do
|
|
(iid, ref) <- buyBadge env client 1 sampleCode
|
|
atProvider fake ref "Settled" "None" paidInFull
|
|
runOnePass poller
|
|
settled <- viewInvoice client iid
|
|
fieldOf settled "status" `shouldBe` Just (J.String "paid")
|
|
firstPayment <- paymentRow (weStore env) iid
|
|
firstCode <- settledCode (weStore env) iid
|
|
length <$> paymentIdentity (weStore env) iid `shouldReturn` 1
|
|
runOnePass poller
|
|
length <$> apiRequests fake "GET" ["invoices"] `shouldReturn` 1
|
|
length <$> paymentIdentity (weStore env) iid `shouldReturn` 1
|
|
paymentRow (weStore env) iid `shouldReturn` firstPayment
|
|
settledCode (weStore env) iid `shouldReturn` firstCode
|
|
viewInvoice client iid `shouldReturn` settled
|
|
|
|
scenarioInvalidClosesAsExpired :: IO ()
|
|
scenarioInvalidClosesAsExpired = bounded "scenario: invoice invalid" $ withFakePoller $ \fake poller env client -> do
|
|
(iid, ref) <- buyBadge env client 1 sampleCode
|
|
atProvider fake ref "Invalid" "None" paidInPart
|
|
let body = webhookEvent "InvoiceInvalid" ref
|
|
delivered <- postWebhook client (webhookSigHeader (bWebhookSecret (fbConfig fake)) body) body
|
|
statusOf delivered `shouldBe` 200
|
|
responseBody delivered `shouldBe` ""
|
|
invoiceStatus (weStore env) iid `shouldReturn` ISOpen
|
|
drainHints poller
|
|
o <- viewInvoice client iid
|
|
fieldOf o "status" `shouldBe` Just (J.String "expired")
|
|
fieldOf o "amountPaid" `shouldBe` Just partlyPaid
|
|
fieldOf o "cryptoAmountPaid" `shouldBe` Just (J.String paidInPart)
|
|
invoiceStatus (weStore env) iid `shouldReturn` ISExpired
|
|
bcPaymentStatus <$> settledCode (weStore env) iid `shouldReturn` CPSUnpaid
|
|
detailReads <- apiRequests fake "GET" ["invoices", ref]
|
|
length detailReads `shouldBe` 1
|
|
|
|
scenarioCodeConflictCreatesNothing :: IO ()
|
|
scenarioCodeConflictCreatesNothing = bounded "scenario: code conflict" $ withFakePoller $ \fake poller env client -> do
|
|
(iid, ref) <- buyBadge env client 1 sampleCode
|
|
fakeInvoiceIds fake `shouldReturn` [ref]
|
|
again <- postCreateAs client 2 (createBody supporterPriceId Nothing "btc" (codeHashText sampleCode))
|
|
statusOf again `shouldBe` 409
|
|
responseBody again `shouldBe` errorBody "code_conflict"
|
|
fakeInvoiceIds fake `shouldReturn` [ref]
|
|
invoiceCount (weStore env) `shouldReturn` 1
|
|
(_, otherRef) <- buyBadge env client 3 (sampleCode <> "2")
|
|
otherRef `shouldSatisfy` (/= ref)
|
|
fakeInvoiceIds fake `shouldReturn` sort [ref, otherRef]
|
|
invoiceCount (weStore env) `shouldReturn` 2
|
|
atProvider fake ref "Settled" "None" paidInFull
|
|
runOnePass poller
|
|
paid <- viewInvoice client iid
|
|
fieldOf paid "status" `shouldBe` Just (J.String "paid")
|
|
bcPaymentStatus <$> settledCode (weStore env) iid `shouldReturn` CPSPaid
|
|
|
|
scenarioNoWebhookAnywhere :: IO ()
|
|
scenarioNoWebhookAnywhere = bounded "scenario: no webhook" $ withFakePoller $ \fake poller env client -> do
|
|
(iid, ref) <- buyBadge env client 1 sampleCode
|
|
atProvider fake ref "Settled" "None" paidInFull
|
|
drainHints poller
|
|
invoiceStatus (weStore env) iid `shouldReturn` ISOpen
|
|
runOnePass poller
|
|
paid <- viewInvoice client iid
|
|
fieldOf paid "status" `shouldBe` Just (J.String "paid")
|
|
bcPaymentStatus <$> settledCode (weStore env) iid `shouldReturn` CPSPaid
|
|
byId <- apiRequests fake "GET" ["invoices", ref]
|
|
byId `shouldSatisfy` (not . null)
|
|
|
|
cancelPath :: InvoiceId -> String
|
|
cancelPath iid = invoicePath iid <> "/cancel"
|
|
|
|
webPost :: WebClient -> String -> IO (Response LB.ByteString)
|
|
webPost client target = webRequest client "POST" target []
|
|
|
|
withCancel :: (IORef StubState -> WebEnv -> WebClient -> IO a) -> IO a
|
|
withCancel action = withCheckout $ \ref env client -> do
|
|
_ <- seedOpenInvoice env
|
|
action ref env client
|
|
|
|
testCancelClosesTheInvoiceAtBothEnds :: IO ()
|
|
testCancelClosesTheInvoiceAtBothEnds = bounded "cancel" $ withCancel $ \ref _ client -> do
|
|
let iid = niInvoiceId sampleInvoice
|
|
r <- webPost client (cancelPath iid)
|
|
statusOf r `shouldBe` 200
|
|
o <- jsonObject r
|
|
fieldOf o "status" `shouldBe` Just (J.String "expired")
|
|
stubCalls ref `shouldReturn` [StubCancel (niProviderRef sampleInvoice)]
|
|
reread <- webGet client (invoicePath iid)
|
|
ao <- jsonObject reread
|
|
fieldOf ao "status" `shouldBe` Just (J.String "expired")
|
|
|
|
testCancelWakesAHeldRequest :: IO ()
|
|
testCancelWakesAHeldRequest = bounded "cancel wakes a hold" $ withCancel $ \_ _ client -> do
|
|
let iid = niInvoiceId sampleInvoice
|
|
_ <- wokenBy client iid (void (webPost client (cancelPath iid))) "expired"
|
|
pure ()
|
|
|
|
testCancelIsRefusedOnceItIsNotOpen :: IO ()
|
|
testCancelIsRefusedOnceItIsNotOpen = bounded "cancel not open" $ withCancel $ \ref env client -> do
|
|
let iid = niInvoiceId sampleInvoice
|
|
markPaid (weStore env) iid
|
|
r <- webPost client (cancelPath iid)
|
|
statusOf r `shouldBe` 409
|
|
responseBody r `shouldBe` errorBody "not_open"
|
|
stubCalls ref `shouldReturn` []
|
|
reread <- webGet client (invoicePath iid)
|
|
ao <- jsonObject reread
|
|
fieldOf ao "status" `shouldBe` Just (J.String "paid")
|
|
|
|
testCancelLeavesTheInvoiceOpenWhenTheProviderFails :: IO ()
|
|
testCancelLeavesTheInvoiceOpenWhenTheProviderFails = bounded "cancel provider down" $ withCancel $ \ref _ client -> do
|
|
let iid = niInvoiceId sampleInvoice
|
|
atomicModifyIORef' ref $ \s -> (s {ssCancelError = Just (ProviderError "boom")}, ())
|
|
r <- webPost client (cancelPath iid)
|
|
statusOf r `shouldBe` 503
|
|
reread <- webGet client (invoicePath iid)
|
|
ao <- jsonObject reread
|
|
fieldOf ao "status" `shouldBe` Just (J.String "open")
|
|
|
|
testCancelIsOpaqueForAnUnknownInvoice :: IO ()
|
|
testCancelIsOpaqueForAnUnknownInvoice = bounded "cancel unknown" $ withCancel $ \ref _ client -> do
|
|
r <- webPost client "/api/invoice/no-such-invoice/cancel"
|
|
statusOf r `shouldBe` 404
|
|
responseBody r `shouldBe` notFoundBody
|
|
stubCalls ref `shouldReturn` []
|
|
|
|
testCancelRefusesOtherMethods :: IO ()
|
|
testCancelRefusesOtherMethods = bounded "cancel verb" $ withCancel $ \_ _ client -> do
|
|
r <- webGet client (cancelPath (niInvoiceId sampleInvoice))
|
|
statusOf r `shouldBe` 405
|
|
headerOf r "Allow" `shouldBe` Just "POST"
|
|
|
|
testExpireOverdueSparesAFundedInvoice :: IO ()
|
|
testExpireOverdueSparesAFundedInvoice = withServiceStore $ \st -> do
|
|
seedBadgePrice st "price1"
|
|
now <- getCurrentTime
|
|
let pastExpiry = addUTCTime (-3600) now
|
|
funded = sampleInvoice {niExpiresAt = pastExpiry}
|
|
empty' = sampleInvoice {niInvoiceId = InvoiceId "inv-empty", niProviderRef = "p-empty", niCodeHash = digestFixture 15, niExpiresAt = pastExpiry}
|
|
createInvoiceRows st funded `shouldReturn` Right ()
|
|
createInvoiceRows st empty' `shouldReturn` Right ()
|
|
settle st (niInvoiceId funded) (SigFunded (rcv 500 (Just "0.00050000")) PaidInPart) now `shouldReturn` Right ISOpen
|
|
moved <- expireAllOverdue st now
|
|
moved `shouldBe` [niInvoiceId empty']
|
|
Just fundedRow <- getInvoice st (niInvoiceId funded)
|
|
irStatus fundedRow `shouldBe` ISOpen
|
|
settle st (niInvoiceId funded) (SigSettled (rcv 500 (Just "0.00050000")) now) now `shouldReturn` Right ISPaid
|
|
|
|
testCancelExpiresAFundedInvoice :: IO ()
|
|
testCancelExpiresAFundedInvoice = withServiceStore $ \st -> do
|
|
seedBadgePrice st "price1"
|
|
now <- getCurrentTime
|
|
let iid = niInvoiceId sampleInvoice
|
|
createInvoiceRows st sampleInvoice `shouldReturn` Right ()
|
|
settle st iid (SigFunded (rcv 500 (Just "0.00050000")) PaidInPart) now `shouldReturn` Right ISOpen
|
|
cancelOpenInvoice st iid now `shouldReturn` True
|
|
Just row <- getInvoice st iid
|
|
irStatus row `shouldBe` ISExpired
|
|
(ipCryptoPaid <$> irPayment row) `shouldBe` Just (Just "0.00050000")
|
|
|
|
testCancelIsRefusedOnceItIsFunded :: IO ()
|
|
testCancelIsRefusedOnceItIsFunded = bounded "cancel funded" $ withCancel $ \ref env client -> do
|
|
let iid = niInvoiceId sampleInvoice
|
|
settle (weStore env) iid (SigFunded (rcv 500 (Just "0.00050000")) PaidInPart) someCreated `shouldReturn` Right ISOpen
|
|
r <- webPost client (cancelPath iid)
|
|
statusOf r `shouldBe` 409
|
|
responseBody r `shouldBe` errorBody "funded"
|
|
stubCalls ref `shouldReturn` []
|
|
reread <- webGet client (invoicePath iid)
|
|
ao <- jsonObject reread
|
|
fieldOf ao "status" `shouldBe` Just (J.String "open")
|
|
|
|
testViewNamesTheConfirmationsSettlementNeeds :: IO ()
|
|
testViewNamesTheConfirmationsSettlementNeeds = bounded "required confirmations" $ withCancel $ \_ _ client -> do
|
|
r <- webGet client (invoicePath (niInvoiceId sampleInvoice))
|
|
statusOf r `shouldBe` 200
|
|
o <- jsonObject r
|
|
-- MediumSpeed is BTCPay's one-confirmation policy, so settlement needs one confirmation.
|
|
fieldOf o "requiredConfirmations" `shouldBe` Just (J.Number 1)
|
|
|
|
testViewOmitsConfirmationsWithoutBTCPay :: IO ()
|
|
testViewOmitsConfirmationsWithoutBTCPay = bounded "no confirmations" $ withWebApp $ \env client -> do
|
|
iid <- seedOpenInvoice env
|
|
r <- webGet client (invoicePath iid)
|
|
o <- jsonObject r
|
|
fieldOf o "requiredConfirmations" `shouldBe` Nothing
|
|
|
|
testHeldWaitWakesOnAPaymentThatDoesNotSettle :: IO ()
|
|
testHeldWaitWakesOnAPaymentThatDoesNotSettle = bounded "funded wakes a hold" $ withCheckout $ \_ env client -> do
|
|
iid <- seedOpenInvoice env
|
|
held <- async $ webGet client (invoicePath iid <> "?wait=open")
|
|
awaitWaitingCount env 1
|
|
waitingCount (weWaiters env) `shouldReturn` 1
|
|
settleOrder (weStore env) (weWaiters env) iid (SigFunded (rcv 500 (Just "0.00050000")) PaidInPart) someCreated
|
|
`shouldReturn` Right ISOpen
|
|
r <- wait held
|
|
statusOf r `shouldBe` 200
|
|
o <- jsonObject r
|
|
fieldOf o "status" `shouldBe` Just (J.String "open")
|
|
fieldOf o "cryptoAmountPaid" `shouldBe` Just (J.String "0.00050000")
|
|
|
|
testARepeatedSignalDoesNotWakeAHold :: IO ()
|
|
testARepeatedSignalDoesNotWakeAHold = bounded "repeat signal" $ withWebApp $ \env client -> do
|
|
iid <- seedOpenInvoice env
|
|
let funded = SigFunded (rcv 500 (Just "0.00050000")) PaidInPart
|
|
settleOrder (weStore env) (weWaiters env) iid funded settleAt `shouldReturn` Right ISOpen
|
|
held <- async $ webGet client (invoicePath iid <> "?wait=open&seenPaid=0.00050000&seenFull=0")
|
|
threadDelay holdParkDelay
|
|
Async.poll held >>= (`shouldSatisfy` isNothing)
|
|
|
|
settleOrder (weStore env) (weWaiters env) iid funded settleAt `shouldReturn` Right ISOpen
|
|
threadDelay holdParkDelay
|
|
stillParked <- Async.poll held
|
|
stillParked `shouldSatisfy` isNothing
|
|
|
|
settleOrder (weStore env) (weWaiters env) iid (SigSettled (rcv 500 (Just "0.00050000")) settleAt) settleAt
|
|
`shouldReturn` Right ISPaid
|
|
r <- wait held
|
|
statusOf r `shouldBe` 200
|
|
o <- jsonObject r
|
|
fieldOf o "status" `shouldBe` Just (J.String "paid")
|
|
|
|
testHeldWaitIsNotWokenByAPassThatWroteNothing :: IO ()
|
|
testHeldWaitIsNotWokenByAPassThatWroteNothing = bounded "no churn" $ withCheckout $ \_ env _ -> do
|
|
iid <- seedOpenInvoice env
|
|
markPaid (weStore env) iid
|
|
waitingBefore <- waitingCount (weWaiters env)
|
|
settleOrder (weStore env) (weWaiters env) iid (SigFunded (rcv 500 (Just "0.00050000")) PaidInPart) someCreated
|
|
`shouldReturn` Right ISPaid
|
|
waitingAfter <- waitingCount (weWaiters env)
|
|
waitingAfter `shouldBe` waitingBefore
|
|
|
|
testViewCarriesTheProvidersPaidVerdict :: IO ()
|
|
testViewCarriesTheProvidersPaidVerdict = bounded "paid in full" $ withCheckout $ \_ env client -> do
|
|
iid <- seedOpenInvoice env
|
|
settleOrder (weStore env) (weWaiters env) iid (SigFunded (rcv 400 (Just "0.00040000")) PaidInFull) someCreated
|
|
`shouldReturn` Right ISOpen
|
|
o <- jsonObject =<< webGet client (invoicePath iid)
|
|
fieldOf o "status" `shouldBe` Just (J.String "open")
|
|
fieldOf o "paidInFull" `shouldBe` Just (J.Bool True)
|
|
fieldOf o "amountPaid" `shouldBe` Just (J.Number 400)
|
|
|
|
testPaidVerdictIsNotWithdrawnByALaterRead :: IO ()
|
|
testPaidVerdictIsNotWithdrawnByALaterRead = bounded "verdict sticks" $ withCheckout $ \_ env client -> do
|
|
iid <- seedOpenInvoice env
|
|
settleOrder (weStore env) (weWaiters env) iid (SigFunded (rcv 500 (Just "0.00050000")) PaidInFull) someCreated
|
|
`shouldReturn` Right ISOpen
|
|
settleOrder (weStore env) (weWaiters env) iid (SigFunded (rcv 500 (Just "0.00050000")) PaidInPart) someCreated
|
|
`shouldReturn` Right ISOpen
|
|
o <- jsonObject =<< webGet client (invoicePath iid)
|
|
fieldOf o "paidInFull" `shouldBe` Just (J.Bool True)
|
|
|
|
testExpireOverdueSparesAZeroAmount :: IO ()
|
|
testExpireOverdueSparesAZeroAmount = withServiceStore $ \st -> do
|
|
seedBadgePrice st "price1"
|
|
now <- getCurrentTime
|
|
let pastExpiry = addUTCTime (-3600) now
|
|
dust = sampleInvoice {niExpiresAt = pastExpiry}
|
|
verdict = sampleInvoice {niInvoiceId = InvoiceId "inv-verdict", niProviderRef = "p-verdict", niCodeHash = digestFixture 16, niExpiresAt = pastExpiry}
|
|
createInvoiceRows st dust `shouldReturn` Right ()
|
|
createInvoiceRows st verdict `shouldReturn` Right ()
|
|
settle st (niInvoiceId dust) (SigFunded (rcv 0 (Just "0.00000001")) PaidInPart) now `shouldReturn` Right ISOpen
|
|
settle st (niInvoiceId verdict) (SigFunded (rcv 0 Nothing) PaidInFull) now `shouldReturn` Right ISOpen
|
|
expireAllOverdue st now `shouldReturn` []
|
|
mapM_ (\iid ->
|
|
getInvoice st iid >>= \case
|
|
Just InvoiceRow {irStatus, irPayment} -> do
|
|
irStatus `shouldBe` ISOpen
|
|
maybe False paymentHolds irPayment `shouldBe` True
|
|
Nothing -> failWith "the invoice went missing") [niInvoiceId dust, niInvoiceId verdict]
|