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>
1419 lines
82 KiB
Haskell
1419 lines
82 KiB
Haskell
{-# LANGUAGE DataKinds #-}
|
|
{-# LANGUAGE DisambiguateRecordFields #-}
|
|
{-# LANGUAGE DuplicateRecordFields #-}
|
|
{-# LANGUAGE GADTs #-}
|
|
{-# LANGUAGE LambdaCase #-}
|
|
{-# LANGUAGE NamedFieldPuns #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# OPTIONS_GHC -fno-warn-ambiguous-fields #-}
|
|
|
|
module BadgeTests (badgeTests) where
|
|
|
|
import BadgeService.Service (NotGranted (..), badgeErrorRetryAfter, grantableCharge, shownServiceRequest, survive)
|
|
import BadgeService.StoreReceipts (StoreCharge (..), StoreChecks (..), StoreReceipt (..), StoreRefusal (..), StoreVerifier (..), SubscriptionCheck (..), VerifiedStoreTransaction (..), toStoreReceipt)
|
|
import BadgeService.StoreReceipts.Mock (newMockStoreVerifier)
|
|
import Control.Concurrent (forkIO, killThread, threadDelay)
|
|
import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar)
|
|
import Control.Concurrent.STM (atomically)
|
|
import Control.Exception (SomeAsyncException, SomeException, catch, fromException, throwIO)
|
|
import Data.ByteString.Char8 (ByteString)
|
|
import qualified Data.ByteString.Base64.URL as B64U
|
|
import qualified Data.ByteString.Lazy as LB
|
|
import Data.Map.Strict (Map)
|
|
import qualified Data.Map.Strict as M
|
|
import qualified Data.Text as T
|
|
import Data.Text.Encoding (encodeUtf8)
|
|
import Data.Time.Calendar (fromGregorian)
|
|
import Data.Time.Calendar.WeekDate (toWeekDate)
|
|
import Data.Time.Clock (NominalDiffTime, UTCTime (..), addUTCTime, diffUTCTime, getCurrentTime, nominalDay)
|
|
import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
|
|
import qualified Data.Aeson as J
|
|
import qualified Data.Aeson.KeyMap as KM
|
|
import Data.Maybe (fromMaybe, isJust, isNothing, maybeToList)
|
|
import qualified Simplex.Messaging.Crypto as C
|
|
import Simplex.Chat.Badges
|
|
import Simplex.Chat.Badges.Code
|
|
import Simplex.Chat.Badges.Ledger
|
|
import Simplex.Chat.Badges.Service
|
|
import Simplex.Chat.Badges.Types (BadgeAlertKind (..), BadgeIssueError (..), BadgeIssueFailure (..), BadgeSubscription (..))
|
|
import qualified Simplex.Chat.Badges.Types as BT
|
|
import Simplex.Chat (defaultChatConfig)
|
|
import Simplex.Chat.Controller (BadgeRedeemError (..), ChatError (..), ChatErrorType (..), badgeRetryInterval, chatErrorAgent)
|
|
import Simplex.Chat.Library.Commands (badgeErrorRetry, badgeFailureTransient, badgeIssueFailure, badgeRenewal, badgeRetryAfter, badgeServiceErrorText, badgeStalledInterval, boundedSubscriptionState, derivedBadgeAlert, resumableCharge, resumeHoldEnded, storeTransactionRef)
|
|
import Simplex.Chat.PaymentService (AppleTransactionFacts (..), ServicePayment (..), appleTransactionFacts, appleTransactionRef)
|
|
import Simplex.Chat.PaymentService.Types (InvoiceId (..), PaymentProvider (..), StoreTransactionRef (..))
|
|
import qualified Simplex.Chat.Store.Badges as SB
|
|
import Simplex.Chat.Types (BoolDef (..))
|
|
import Simplex.Messaging.Agent.Protocol (AgentErrorType (..), AgentServiceError (..), SMPAgentError (..))
|
|
import Simplex.Messaging.Agent.RetryInterval (RetryInterval (..), nextRetryDelay)
|
|
import Simplex.Messaging.Crypto.BBS
|
|
import Simplex.Messaging.Encoding.String
|
|
import Simplex.Messaging.Protocol (BrokerErrorType (..), ErrorType (AUTH), NetworkError (..))
|
|
import Simplex.Messaging.Util (safeDecodeUtf8, tshow)
|
|
import Simplex.Messaging.Version.Internal (Version (..))
|
|
import Test.Hspec
|
|
|
|
badgeTests :: Spec
|
|
badgeTests = do
|
|
it "full workflow: request, issue, verify credential, generate and verify proof" testFullWorkflow
|
|
it "should reject badge with tampered type" testTamperedType
|
|
it "should reject badge with tampered expiry" testTamperedExpiry
|
|
it "should reject badge with wrong server key" testWrongKey
|
|
it "should report a key index missing from configured keys" testUnknownKeyIdx
|
|
it "should compute badge status correctly" testExpiryCheck
|
|
it "should accept unknown badge types" testUnknownBadgeType
|
|
it "credential serializes to a paste-able token and back" testCredentialSerialization
|
|
it "presentation headers encode and decode" testPresHeaderEncoding
|
|
it "presentation headers with binary bytes round-trip through JSON" testPresHeaderJSON
|
|
it "should reject a proof presented under another chat binding" testOtherChatBinding
|
|
it "should accept a profile proof only with the header of its chat" testProfileProofHeader
|
|
describe "redemption codes" $ do
|
|
it "a generated code reads back" testCodeRoundTrip
|
|
it "reads a code as typed - any case, separators, ambiguous characters" testCodeNormalisation
|
|
it "rejects a code whose check character does not match" testCodeCheckCharacter
|
|
it "hashes the canonical form, whatever was typed" testCodeHash
|
|
describe "ledger transitions" $ do
|
|
it "issues a twelve month code one month at a time, and no thirteenth" testTwelveMonths
|
|
it "lapses only the elapsed months after a gap, leaving paidThrough unchanged" testLapseAfterGap
|
|
it "keeps the balance non-negative and the start non-decreasing" testLedgerInvariants
|
|
it "credits an exhausted balance from the grant, not from the date it ran out" testGrantAfterExhausted
|
|
it "does not issue months topped up inside an issued period" testGrantInsideIssuedPeriod
|
|
it "clips month ends without losing the issued period start" testMonthEndClipping
|
|
it "counts the elapsed months of an absurd run in one step" testElapsedFarAnchor
|
|
it "expires at the end of the Monday after the period" testMondayExpiry
|
|
it "stores the wire tag of every entry type, and rebuilds each from its stored JSON" testEntryTypeColumns
|
|
describe "checking a statement" $ do
|
|
it "accepts a chain of entries, each against the one before it" testChecksChain
|
|
it "checks the second entry against the first, not against the tip" testChecksAgainstStatement
|
|
it "accepts an opening credit with no predecessor, and rejects anything else" testChecksOpening
|
|
it "rejects an opening credit naming a badge type the purchase is not for" testChecksOpeningBadgeType
|
|
it "accepts an opening credit restating the balance over a tip it does not follow" testChecksOpeningRestatement
|
|
it "rejects a lapse writing off months that had not elapsed" testChecksOverLapse
|
|
it "rejects a debit whose start or anchor moved" testChecksMovedStart
|
|
it "rejects a grant restarting a run the predecessor still funds" testChecksGrantRestart
|
|
it "rejects a credit of negative months" testChecksNegativeCredit
|
|
it "leaves an entry ahead of the clock unjudged, and rejects one behind the entry it follows" testChecksTimestamps
|
|
it "leaves an entry type it cannot derive unchecked, its months still checked" testChecksUnknownType
|
|
it "rejects an entry it cannot rebuild whose coverage or months contradict the ledger" testChecksUncheckedInvariants
|
|
it "accepts every row a store charge adds, on each path a subscription renews by" testChargeRowsVerify
|
|
it "re-runs an upgrade or a transfer debit, and rejects one that leaves months" testDebitRowsVerify
|
|
it "accepts every row a change of tier adds, and rejects a new tier granted over months still held" testTierChangeRowsVerify
|
|
describe "worker retry" $ do
|
|
it "repeats a failure that can clear on its own, and no other" testRetryClassification
|
|
it "backs off to the cap" testRetryBackoff
|
|
it "floors the wait a service asks for, and honours anything above it" testServiceRetryFloor
|
|
it "sends retryAfter with the transient service codes and no other" testServiceRetryAfter
|
|
describe "recording a failed renewal" $ do
|
|
it "records the agent error a request failed with, not the chat error around it" testIssueFailureClassification
|
|
it "waits for the credential to lapse on internal, as on a refusal the service marks transient" testServiceErrorTransience
|
|
it "stores every failure so that it reads back, whatever the service called its code" testIssueFailureEncoding
|
|
it "bounds and strips a code this version does not know" testServiceErrorCodeBounded
|
|
describe "service protocol JSON" $ do
|
|
it "redeemBadgeCode request matches the schema" testRedeemRequestJSON
|
|
it "purchaseBadge request matches the schema" testPurchaseRequestJSON
|
|
it "badgeCredential response matches the schema" testCredentialResponseJSON
|
|
it "badgeCredential carries a subscription's state, and reads one it does not know as unknown" testCredentialSubscriptionJSON
|
|
it "error response matches the schema" testErrorResponseJSON
|
|
it "statement entries round-trip, unknown entry types verbatim" testStatementJSON
|
|
describe "badge state" $ do
|
|
it "carries a subscription's plan and last seen state, renewing only when it was seen renewing, and bounds a state it does not know" testBadgeSubscriptionJSON
|
|
it "derives one alert for a subscription in order of urgency, dated paidThrough, leaves prepaid alerts as they were, and derives none for a purchase Restore moved away" testSubscriptionAlertDerivation
|
|
describe "store purchases" $ do
|
|
it "keys a purchase by the store's transaction id, not by the evidence signed over it" testStoreTransactionRef
|
|
it "claims an Apple subscription by its original transaction id, and any other transaction by its own" testAppleTransactionRef
|
|
it "reads an Apple transaction's id, purchase and expiry dates, revocation and type from its unverified payload" testAppleTransactionFacts
|
|
it "resumes a retired subscription only with an Apple charge whose paid period runs, dated less than a day ahead" testResumableCharge
|
|
it "refuses a store charge once its period has ended, as a sandbox's five-minute one does" testChargePeriodOver
|
|
it "shows a service request in the terminal as its type alone" testShownServiceRequest
|
|
it "refuses for good a Play product id that could name another purchase, before any verifier" testGoogleProductIdPath
|
|
it "does not send a Play token that could name another purchase, and leaves it retryable" testGoogleTokenPath
|
|
it "has the dev mock vouch for the transaction its claim names, as a production purchase" testMockVouchesForClaim
|
|
describe "badge service request loop" $ do
|
|
it "survives a request that throws, and still stops when cancelled" testSurviveRequestFailure
|
|
|
|
proofOf :: BadgeProof -> BBSProof
|
|
proofOf (BadgeProof _ _ p _) = p
|
|
|
|
nonDecreasing :: Ord a => [a] -> Bool
|
|
nonDecreasing xs = and $ zipWith (<=) xs (drop 1 xs)
|
|
|
|
testKeyIdx :: Int
|
|
testKeyIdx = 1
|
|
|
|
keysFor :: BBSPublicKey -> Map Int BBSPublicKey
|
|
keysFor = M.singleton testKeyIdx
|
|
|
|
testFullWorkflow :: IO ()
|
|
testFullWorkflow = do
|
|
Right (pk, sk) <- bbsKeyGen
|
|
drg <- C.newRandom
|
|
mk <- generateMasterKey drg
|
|
let req = BadgeRequest {masterKey = mk, badgeInfo = BadgeInfo {badgeType = BTSupporter, badgeExpiry = futureTime, badgeExtra = ""}}
|
|
Just vreq <- verifyPayment (BPRedeemCode "TEST") req
|
|
Right cred <- issueBadge testKeyIdx sk vreq
|
|
let BadgeCredential idx mk' _ _ = cred
|
|
idx `shouldBe` testKeyIdx
|
|
mk' `shouldBe` mk
|
|
verifyCredential pk cred >>= (`shouldBe` True)
|
|
Right badge <- generateBadgeProof pk cred (BBSPresHeader "nonce-1")
|
|
-- the proof inherits the credential's key index, so receivers find the right key
|
|
let BadgeProof {badgeKeyIdx} = badge
|
|
badgeKeyIdx `shouldBe` testKeyIdx
|
|
verifyBadge (keysFor pk) badge >>= (`shouldBe` Just True)
|
|
Right badge2 <- generateBadgeProof pk cred (BBSPresHeader "nonce-2")
|
|
verifyBadge (keysFor pk) badge2 >>= (`shouldBe` Just True)
|
|
proofOf badge `shouldNotBe` proofOf badge2
|
|
|
|
testTamperedType :: IO ()
|
|
testTamperedType = do
|
|
(pk, BadgeProof idx ph p info) <- issueBadgeProof BTSupporter futureTime
|
|
verifyBadge (keysFor pk) (BadgeProof idx ph p info {badgeType = BTLegend}) >>= (`shouldBe` Just False)
|
|
|
|
testTamperedExpiry :: IO ()
|
|
testTamperedExpiry = do
|
|
(pk, BadgeProof idx ph p info) <- issueBadgeProof BTSupporter futureTime
|
|
verifyBadge (keysFor pk) (BadgeProof idx ph p info {badgeExpiry = pastTime}) >>= (`shouldBe` Just False)
|
|
|
|
testWrongKey :: IO ()
|
|
testWrongKey = do
|
|
(_, badge) <- issueBadgeProof BTSupporter futureTime
|
|
Right (pk2, _) <- bbsKeyGen
|
|
verifyBadge (keysFor pk2) badge >>= (`shouldBe` Just False)
|
|
|
|
testUnknownKeyIdx :: IO ()
|
|
testUnknownKeyIdx = do
|
|
(pk, badge) <- issueBadgeProof BTSupporter futureTime
|
|
-- a key index not in the configured keys cannot be verified at all (Nothing)
|
|
verifyBadge (M.singleton (testKeyIdx + 1) pk) badge >>= (`shouldBe` Nothing)
|
|
|
|
testExpiryCheck :: IO ()
|
|
testExpiryCheck = do
|
|
now <- getCurrentTime
|
|
let info expiry = BadgeInfo {badgeType = BTSupporter, badgeExpiry = expiry, badgeExtra = ""}
|
|
futureInfo = info futureTime
|
|
expiredAgo d = info $ addUTCTime (- (d * nominalDay)) now
|
|
mkBadgeStatus now (Just True) futureInfo `shouldBe` BSActive
|
|
-- the badge stays active for a week after its expiry
|
|
mkBadgeStatus now (Just True) (expiredAgo 1) `shouldBe` BSActive
|
|
mkBadgeStatus now (Just True) (expiredAgo 6) `shouldBe` BSActive
|
|
-- then it is shown as expired for 31 days
|
|
mkBadgeStatus now (Just True) (expiredAgo 8) `shouldBe` BSExpired
|
|
mkBadgeStatus now (Just True) (expiredAgo 37) `shouldBe` BSExpired
|
|
mkBadgeStatus now (Just True) (expiredAgo 39) `shouldBe` BSExpiredOld
|
|
mkBadgeStatus now (Just True) (info pastTime) `shouldBe` BSExpiredOld
|
|
mkBadgeStatus now (Just False) futureInfo `shouldBe` BSFailed
|
|
mkBadgeStatus now Nothing futureInfo `shouldBe` BSUnknownKey
|
|
|
|
testUnknownBadgeType :: IO ()
|
|
testUnknownBadgeType = do
|
|
(pk, badge) <- issueBadgeProof (BTUnknown "future_type") futureTime
|
|
verifyBadge (keysFor pk) badge >>= (`shouldBe` Just True)
|
|
|
|
testCredentialSerialization :: IO ()
|
|
testCredentialSerialization = do
|
|
Right (pk, sk) <- bbsKeyGen
|
|
drg <- C.newRandom
|
|
mk <- generateMasterKey drg
|
|
let mkCred expiry = do
|
|
Right cred <- issueBadge testKeyIdx sk (VerifiedBadgeRequest BadgeRequest {masterKey = mk, badgeInfo = BadgeInfo {badgeType = BTSupporter, badgeExpiry = expiry, badgeExtra = ""}})
|
|
pure cred
|
|
dated <- mkCred futureTime
|
|
J.eitherDecode (J.encode dated) `shouldBe` Right dated
|
|
-- a decoded credential still verifies against the issuing key
|
|
case J.eitherDecode (J.encode dated) of
|
|
Right cred -> verifyCredential pk cred >>= (`shouldBe` True)
|
|
Left e -> expectationFailure e
|
|
|
|
-- Helpers
|
|
|
|
futureTime :: UTCTime
|
|
futureTime = posixSecondsToUTCTime 4102444800 -- 2099-12-31
|
|
|
|
pastTime :: UTCTime
|
|
pastTime = posixSecondsToUTCTime 1577836800 -- 2020-01-01
|
|
|
|
testPresHeaderEncoding :: IO ()
|
|
testPresHeaderEncoding =
|
|
mapM_
|
|
(\ph -> strDecode (strEncode ph) `shouldBe` Right ph)
|
|
[ PHTest "nonce",
|
|
PHChat aliceBinding,
|
|
PHFileInv {chatBinding = aliceBinding, fileSize = 139737},
|
|
PHFileDescr {chatBinding = aliceBinding, fileSize = 139737, descrHash = "descr-hash", fileExpires = Nothing},
|
|
PHFileDescr {chatBinding = aliceBinding, fileSize = 139737, descrHash = "descr-hash", fileExpires = Just futureTime},
|
|
PHRequest requestCode,
|
|
PHLink "link-key",
|
|
PHUnknown 'Z' "payload"
|
|
]
|
|
|
|
testPresHeaderJSON :: IO ()
|
|
testPresHeaderJSON =
|
|
mapM_
|
|
( \ph -> do
|
|
J.eitherDecode (J.encode ph) `shouldBe` Right ph
|
|
J.toJSON ph `shouldBe` J.toJSON (BBSPresHeader $ strEncode ph)
|
|
)
|
|
[ PHChat binaryBytes,
|
|
PHFileInv {chatBinding = binaryBytes, fileSize = 139737},
|
|
PHFileDescr {chatBinding = binaryBytes, fileSize = 139737, descrHash = binaryBytes, fileExpires = Just futureTime},
|
|
PHRequest binaryBytes,
|
|
PHLink binaryBytes,
|
|
PHUnknown 'Z' binaryBytes
|
|
]
|
|
where
|
|
binaryBytes = "\0\1\31\34\92\127\128\195\255"
|
|
|
|
testOtherChatBinding :: IO ()
|
|
testOtherChatBinding = do
|
|
let ph = PHFileInv {chatBinding = aliceBinding, fileSize = 139737}
|
|
otherPh = PHFileInv {chatBinding = bobBinding, fileSize = 139737}
|
|
(pk, BadgeProof idx _ p info) <- issueBadgeProofHeader BTSupporter futureTime ph
|
|
verifyBadge (keysFor pk) (BadgeProof idx (BBSPresHeader $ strEncode ph) p info) >>= (`shouldBe` Just True)
|
|
verifyBadge (keysFor pk) (BadgeProof idx (BBSPresHeader $ strEncode otherPh) p info) >>= (`shouldBe` Just False)
|
|
|
|
testProfileProofHeader :: IO ()
|
|
testProfileProofHeader = do
|
|
(pk, unbound) <- issueBadgeProof BTSupporter futureTime
|
|
(pk', bound) <- issueBadgeProofHeader BTSupporter futureTime (PHChat aliceBinding)
|
|
(pk'', requested) <- issueBadgeProofHeader BTSupporter futureTime (PHRequest requestCode)
|
|
acceptedProof Nothing unbound `shouldBe` True
|
|
acceptedProof (Just $ PHChat aliceBinding) unbound `shouldBe` True
|
|
acceptedProof (Just $ PHChat aliceBinding) bound `shouldBe` True
|
|
acceptedProof (Just $ PHChat bobBinding) bound `shouldBe` False
|
|
acceptedProof (Just $ PHRequest aliceBinding) bound `shouldBe` False
|
|
acceptedProof Nothing bound `shouldBe` False
|
|
acceptedProof (Just $ PHRequest requestCode) requested `shouldBe` True
|
|
acceptedProof (Just $ PHRequest "other-request-code") requested `shouldBe` False
|
|
acceptedProof (Just $ PHChat requestCode) requested `shouldBe` False
|
|
verifyBadge (keysFor pk) unbound >>= (`shouldBe` Just True)
|
|
verifyBadge (keysFor pk') bound >>= (`shouldBe` Just True)
|
|
verifyBadge (keysFor pk'') requested >>= (`shouldBe` Just True)
|
|
|
|
aliceBinding :: ByteString
|
|
aliceBinding = "Galice-member-id"
|
|
|
|
bobBinding :: ByteString
|
|
bobBinding = "Gbob-member-id"
|
|
|
|
requestCode :: ByteString
|
|
requestCode = "request-code"
|
|
|
|
issueBadgeProof :: BadgeType -> UTCTime -> IO (BBSPublicKey, BadgeProof)
|
|
issueBadgeProof bt expiry = issueBadgeProofHeader bt expiry (PHTest "test-nonce")
|
|
|
|
issueBadgeProofHeader :: BadgeType -> UTCTime -> ProofPresHeader -> IO (BBSPublicKey, BadgeProof)
|
|
issueBadgeProofHeader bt expiry ph = do
|
|
Right (pk, sk) <- bbsKeyGen
|
|
drg <- C.newRandom
|
|
mk <- generateMasterKey drg
|
|
let vreq = VerifiedBadgeRequest BadgeRequest {masterKey = mk, badgeInfo = BadgeInfo {badgeType = bt, badgeExpiry = expiry, badgeExtra = ""}}
|
|
Right cred <- issueBadge testKeyIdx sk vreq
|
|
Right badge <- badgeProof pk cred ph
|
|
pure (pk, badge)
|
|
|
|
-- Redemption codes
|
|
|
|
testCodeRoundTrip :: IO ()
|
|
testCodeRoundTrip = do
|
|
drg <- C.newRandom
|
|
code <- randomBadgeCode drg
|
|
let formatted = formatBadgeCode code
|
|
T.length formatted `shouldBe` 26 -- SB-XXXXX-XXXXX-XXXXX-XXXXX
|
|
T.take 3 formatted `shouldBe` "SB-"
|
|
T.length (badgeCodeText code) `shouldBe` 22 -- the canonical form drops the separators
|
|
parseBadgeCode formatted `shouldBe` Just code
|
|
parseBadgeCode (badgeCodeText code) `shouldBe` Just code
|
|
|
|
testCodeNormalisation :: IO ()
|
|
testCodeNormalisation = do
|
|
drg <- C.newRandom
|
|
code <- randomBadgeCode drg
|
|
parseBadgeCode (T.toLower $ badgeCodeText code) `shouldBe` Just code
|
|
parseBadgeCode (T.replace "-" " " $ formatBadgeCode code) `shouldBe` Just code
|
|
-- a fixed code, because a random one contains no 0 or 1 about a quarter of the time and the
|
|
-- folding would then be asserted against nothing
|
|
let folded = T.map ambiguous fixedCode
|
|
folded `shouldNotBe` fixedCode
|
|
parseBadgeCode folded `shouldBe` parseBadgeCode fixedCode
|
|
parseBadgeCode fixedCode `shouldNotBe` Nothing
|
|
where
|
|
fixedCode = "SB-0C0QS-XAQW1-N1VSA-R00Y3"
|
|
ambiguous = \case
|
|
'1' -> 'I'
|
|
'0' -> 'O'
|
|
c -> c
|
|
|
|
testCodeCheckCharacter :: IO ()
|
|
testCodeCheckCharacter = do
|
|
drg <- C.newRandom
|
|
code <- randomBadgeCode drg
|
|
let canonical = badgeCodeText code
|
|
-- every other value for the last character fails the check
|
|
wrong = T.init canonical <> T.singleton (if T.last canonical == 'Z' then 'Y' else 'Z')
|
|
parseBadgeCode wrong `shouldBe` Nothing
|
|
parseBadgeCode "" `shouldBe` Nothing
|
|
parseBadgeCode "SB-00000-00000-00000-0000" `shouldBe` Nothing
|
|
parseBadgeCode (T.drop 2 canonical) `shouldBe` Nothing
|
|
|
|
testCodeHash :: IO ()
|
|
testCodeHash = do
|
|
drg <- C.newRandom
|
|
code <- randomBadgeCode drg
|
|
Just typed <- pure $ parseBadgeCode $ T.toLower $ formatBadgeCode code
|
|
badgeCodeHash typed `shouldBe` badgeCodeHash code
|
|
|
|
-- Ledger transitions, against plans/2026-07-30-supporter-badges-v3-ux.md §3
|
|
|
|
at :: Integer -> Int -> Int -> UTCTime
|
|
at y m d = UTCTime (fromGregorian y m d) (11 * 3600)
|
|
|
|
newBalance :: UTCTime -> StatementEntry
|
|
newBalance t = emptyEntry t BTSupporter
|
|
|
|
-- these tests never write, so the id each operation stamps on its entry is never read
|
|
grant :: UTCTime -> Int -> StatementEntry -> StatementEntry
|
|
grant t n = grantEntry t "" BTSupporter n SCCode
|
|
|
|
lapse :: UTCTime -> StatementEntry -> Maybe StatementEntry
|
|
lapse t = lapseEntry t ""
|
|
|
|
issue :: UTCTime -> StatementEntry -> Maybe StatementEntry
|
|
issue t = issueEntry t ""
|
|
|
|
-- StatementEntry and BadgeInfo carry fields of the same names, so the selectors are ambiguous here
|
|
bMonths :: StatementEntry -> Int
|
|
bMonths StatementEntry {balanceMonths} = balanceMonths
|
|
|
|
bStart :: StatementEntry -> UTCTime
|
|
bStart StatementEntry {balanceStartTs} = balanceStartTs
|
|
|
|
-- the moment the service claims it wrote the row, which is what the check reads it against
|
|
stampedAt :: UTCTime -> StatementEntry -> StatementEntry
|
|
stampedAt t e = e {createdAt = t}
|
|
|
|
-- one service pass: lapse what elapsed, then issue if a month is due, as the service chains them.
|
|
-- The period an issue covers is the previous entry's balance start to its own, so a run of starts
|
|
-- is what the period assertions read.
|
|
pass :: UTCTime -> StatementEntry -> [StatementEntry]
|
|
pass t e0 = maybeToList lapsed <> maybeToList (issue t $ fromMaybe e0 lapsed)
|
|
where
|
|
lapsed = lapse t e0
|
|
|
|
finalBalance :: StatementEntry -> [StatementEntry] -> StatementEntry
|
|
finalBalance e0 rows = last (e0 : rows)
|
|
|
|
-- each pass issues exactly one month, so the entries returned are the months issued, in order
|
|
issueAll :: StatementEntry -> [StatementEntry]
|
|
issueAll e = case pass (bStart e) e of
|
|
[] -> []
|
|
rows -> let e' = finalBalance e rows in e' : issueAll e'
|
|
|
|
testTwelveMonths :: IO ()
|
|
testTwelveMonths = do
|
|
let start = at 2026 3 10
|
|
granted = grant start 12 (newBalance start)
|
|
-- each month is issued as soon as it falls due
|
|
issued = issueAll granted
|
|
spent = finalBalance granted issued
|
|
length issued `shouldBe` 12
|
|
bMonths spent `shouldBe` 0
|
|
-- no month was skipped or issued twice: consecutive starts, so the periods tile the whole year
|
|
map bStart (granted : issued) `shouldBe` map (\m -> addMonths m start) [0 .. 12]
|
|
bStart spent `shouldBe` at 2027 3 10
|
|
-- a thirteenth request issues nothing, whenever it is made
|
|
issue (bStart spent) spent `shouldSatisfy` isNothing
|
|
issue (at 2030 1 1) spent `shouldSatisfy` isNothing
|
|
lapse (at 2030 1 1) spent `shouldSatisfy` isNothing
|
|
|
|
-- 3 months bought 10 Mar, first issued the same day, no pass until 20 May: April lapses unissued
|
|
testLapseAfterGap :: IO ()
|
|
testLapseAfterGap = do
|
|
let start = at 2026 3 10
|
|
granted = grant start 3 (newBalance start)
|
|
rows1 = pass start granted
|
|
afterFirst = finalBalance granted rows1
|
|
rows2 = pass (at 2026 5 20) afterFirst
|
|
afterSecond = finalBalance afterFirst rows2
|
|
map bMonths rows1 `shouldBe` [2]
|
|
-- March is issued: from the granting entry's start to the issued entry's own
|
|
bStart granted `shouldBe` at 2026 3 10
|
|
map bStart rows1 `shouldBe` [at 2026 4 10]
|
|
-- one lapse row for April, then May is issued: two rows, not one and not three. The lapse row's
|
|
-- start is where May begins, so it is also the start of the period the issue that follows covers
|
|
map bMonths rows2 `shouldBe` [1, 0]
|
|
map bStart rows2 `shouldBe` [at 2026 5 10, at 2026 6 10]
|
|
-- a lapse moves months from unused to gone; it never changes what was paid for
|
|
map paidThrough (granted : rows1 <> rows2) `shouldBe` replicate 4 (at 2026 6 10)
|
|
bMonths afterSecond `shouldBe` 0
|
|
|
|
data LedgerStep = Grant UTCTime Int | Pass UTCTime
|
|
|
|
testLedgerInvariants :: IO ()
|
|
testLedgerInvariants = do
|
|
let start = at 2026 1 15
|
|
reopened = at 2027 9 9
|
|
-- the April grant lands exactly where coverage ended and continues the run, the 2027 one
|
|
-- lands past it and restarts, so both branches of grantEntry run under the invariants
|
|
steps =
|
|
[ Grant start 3,
|
|
Pass start,
|
|
Pass (at 2026 4 15),
|
|
Grant (at 2026 4 15) 2,
|
|
Pass (at 2026 5 1),
|
|
Pass reopened,
|
|
Grant reopened 1,
|
|
Pass reopened
|
|
]
|
|
step (e, rows) = \case
|
|
Grant t n -> let e' = grant t n e in (e', rows <> [e'])
|
|
Pass t -> let rs = pass t e in (finalBalance e rs, rows <> rs)
|
|
(_, allRows) = foldl step (newBalance start, []) steps
|
|
map bMonths allRows `shouldSatisfy` all (>= 0)
|
|
map bStart allRows `shouldSatisfy` nonDecreasing
|
|
|
|
testGrantAfterExhausted :: IO ()
|
|
testGrantAfterExhausted = do
|
|
-- the balance ran out on 10 Feb; the next code is redeemed on 1 Jun
|
|
let spent = newBalance (at 2026 2 10)
|
|
granted = grant (at 2026 6 1) 2 spent
|
|
bStart granted `shouldBe` at 2026 6 1
|
|
paidThrough granted `shouldBe` at 2026 8 1
|
|
-- the four unsupported months are not backfilled, so nothing lapses immediately
|
|
lapse (at 2026 6 1) granted `shouldSatisfy` isNothing
|
|
|
|
testGrantInsideIssuedPeriod :: IO ()
|
|
testGrantInsideIssuedPeriod = do
|
|
let start = at 2026 1 10
|
|
granted = grant start 1 (newBalance start)
|
|
issued = finalBalance granted $ pass start granted
|
|
-- topped up on 20 Jan, while the month issued on 10 Jan still runs
|
|
toppedUp = grant (at 2026 1 20) 3 issued
|
|
-- February is where the next period starts, the top-up having been spent on neither January nor a gap
|
|
bStart toppedUp `shouldBe` at 2026 2 10
|
|
paidThrough toppedUp `shouldBe` at 2026 5 10
|
|
-- the balance starts in the future, so no second credential is issued for January
|
|
issue (at 2026 1 20) toppedUp `shouldSatisfy` isNothing
|
|
fmap bStart (issue (at 2026 2 10) toppedUp) `shouldBe` Just (at 2026 3 10)
|
|
|
|
testMonthEndClipping :: IO ()
|
|
testMonthEndClipping = do
|
|
let start = at 2027 1 31
|
|
granted = grant start 3 (newBalance start)
|
|
issued = issueAll granted
|
|
-- February clips to the 28th, and March goes back to the 31st: clipping does not accumulate.
|
|
-- Each period runs from one start to the next, so these bounds are the three periods
|
|
map bStart (granted : issued) `shouldBe` [at 2027 1 31, at 2027 2 28, at 2027 3 31, at 2027 4 30]
|
|
-- the issued period start is the previous balance start, never periodEnd minus a month, which
|
|
-- clipping would answer as 28 Jan
|
|
addMonths (-1) (bStart (head issued)) `shouldNotBe` bStart granted
|
|
-- across a leap day
|
|
let leap = grant (at 2028 1 29) 2 (newBalance (at 2028 1 29))
|
|
map bStart (issueAll leap) `shouldBe` [at 2028 2 29, at 2028 3 29]
|
|
-- a month that ends on the leap day counts as elapsed the moment it ends, and not before
|
|
fmap bMonths (lapse (at 2028 2 29) leap) `shouldBe` Just 1
|
|
lapse (addUTCTime (-1) (at 2028 2 29)) leap `shouldSatisfy` isNothing
|
|
-- buying a month at a time keeps the day of month that buying three at once keeps
|
|
let jan = grant (at 2027 1 31) 1 (newBalance (at 2027 1 31))
|
|
case issue (at 2027 1 31) jan of
|
|
Just issuedJan -> do
|
|
let feb = grant (at 2027 2 20) 1 issuedJan
|
|
fmap bStart (issue (at 2027 2 28) feb) `shouldBe` Just (at 2027 3 31)
|
|
Nothing -> expectationFailure "January was not issued"
|
|
|
|
-- The anchor and the month count are the service's, and a run claiming to have started a thousand
|
|
-- years ago with maxBound months is answered the same way as any other.
|
|
testElapsedFarAnchor :: IO ()
|
|
testElapsedFarAnchor = do
|
|
let far = at 1000 1 10
|
|
now = at 2026 1 10
|
|
elapsed = (2026 - 1000) * 12
|
|
huge = (newBalance far) {balanceMonths = maxBound}
|
|
three = (newBalance far) {balanceMonths = 3}
|
|
fmap bMonths (lapse now huge) `shouldBe` Just (maxBound - elapsed)
|
|
fmap bStart (lapse now huge) `shouldBe` Just now
|
|
-- and never writes off more months than the balance holds, however long ago it started
|
|
fmap bMonths (lapse now three) `shouldBe` Just 0
|
|
fmap bStart (lapse now three) `shouldBe` Just (at 1000 4 10)
|
|
|
|
testMondayExpiry :: IO ()
|
|
testMondayExpiry = do
|
|
-- the end of Monday 13 Apr is Tuesday 14 Apr 00:00
|
|
endOfMondayAfter (at 2026 4 10) `shouldBe` UTCTime (fromGregorian 2026 4 14) 0
|
|
endOfMondayAfter (at 2026 6 10) `shouldBe` UTCTime (fromGregorian 2026 6 16) 0
|
|
-- a period ending on a Monday still runs to the end of the following Monday, never to zero days
|
|
endOfMondayAfter (at 2026 4 13) `shouldBe` UTCTime (fromGregorian 2026 4 21) 0
|
|
let periodEnds = map (\d -> at 2026 4 d) [1 .. 30]
|
|
expiries = map endOfMondayAfter periodEnds
|
|
-- every expiry is a Tuesday midnight more than a day after its period, and at most eight
|
|
expiries `shouldSatisfy` all (\(UTCTime d t) -> t == 0 && (\(_, _, wd) -> wd == 2) (toWeekDate d))
|
|
zipWith diffUTCTime expiries periodEnds `shouldSatisfy` all (\d -> d > nominalDay && d <= 8 * nominalDay)
|
|
|
|
verdicts :: UTCTime -> Maybe StatementEntry -> [StatementEntry] -> [Maybe Bool]
|
|
verdicts now tip = map snd . balanceChecked now BTSupporter tip
|
|
|
|
testChecksChain :: IO ()
|
|
testChecksChain = do
|
|
let opened = newBalance (at 2026 1 10)
|
|
oneMonth = grant (at 2026 1 10) 1 opened
|
|
Just spent <- pure $ issue (at 2026 1 10) oneMonth
|
|
let granted = grant (at 2026 3 10) 3 spent
|
|
rows1 = pass (at 2026 3 10) granted
|
|
afterFirst = finalBalance granted rows1
|
|
rows2 = pass (at 2026 5 20) afterFirst
|
|
statement = granted : rows1 <> rows2
|
|
-- grant, issue, lapse, issue - the first checked against the stored tip
|
|
verdicts (at 2026 5 20) (Just spent) statement `shouldBe` replicate 4 (Just True)
|
|
|
|
-- The client stores what it received, and the next row is what the service computed from the row it
|
|
-- sent - never from the tip, which that row has already superseded.
|
|
testChecksAgainstStatement :: IO ()
|
|
testChecksAgainstStatement = do
|
|
let start = at 2026 3 10
|
|
granted = grant start 3 (newBalance start)
|
|
Just firstRow <- pure $ issue start granted
|
|
Just secondRow <- pure $ issue (at 2026 4 10) firstRow
|
|
verdicts (at 2026 4 10) (Just granted) [firstRow, secondRow] `shouldBe` [Just True, Just True]
|
|
-- against the tip it followed, the second entry does not add up
|
|
verdicts (at 2026 4 10) (Just granted) [secondRow] `shouldBe` [Just False]
|
|
|
|
-- The seed is what redeemCode grants onto, so the row it authors is the one that verifies here.
|
|
testChecksOpening :: IO ()
|
|
testChecksOpening = do
|
|
let t = at 2026 3 10
|
|
opening = grant t 12 (newBalance t)
|
|
verdicts t Nothing [opening] `shouldBe` [Just True]
|
|
Just issued <- pure $ issue t opening
|
|
verdicts t Nothing [issued] `shouldBe` [Just False]
|
|
|
|
-- The seed takes the purchase's badge type, not the statement's, so an opening row cannot assert a
|
|
-- badge the purchase was never for - the one field on that path with something to check it against.
|
|
testChecksOpeningBadgeType :: IO ()
|
|
testChecksOpeningBadgeType = do
|
|
let t = at 2026 3 10
|
|
opening = grant t 12 (newBalance t)
|
|
verdicts t Nothing [opening] `shouldBe` [Just True]
|
|
verdicts t Nothing [opening {balanceBadgeType = BTLegend}] `shouldBe` [Just False]
|
|
|
|
-- An opening credit resets the ledger to the amount it states, so it is the one entry whose
|
|
-- balance owes nothing to the row before it - a new device, or history discarded into a balance
|
|
-- brought forward. It still cannot state a balance other than the months it credits.
|
|
testChecksOpeningRestatement :: IO ()
|
|
testChecksOpeningRestatement = do
|
|
let start = at 2026 3 10
|
|
granted = grant start 3 (newBalance start)
|
|
restated = granted {entryType = SECredit SCOpening, changeMonths = 3, balanceMonths = 3}
|
|
-- the tip funds two months from April; the opening restates three from March and still holds
|
|
Just spent <- pure $ issue start granted
|
|
verdicts start (Just spent) [restated] `shouldBe` [Just True]
|
|
verdicts start (Just spent) [restated {balanceMonths = 9}] `shouldBe` [Just False]
|
|
verdicts start (Just spent) [restated {balanceBadgeType = BTLegend}] `shouldBe` [Just False]
|
|
|
|
-- Over-lapsing empties the balance while paidThrough stays where it was: the badge stops renewing
|
|
-- and the ledger still reads as paid up. The row is self-consistent with the one before it, so only
|
|
-- re-running the lapse against its own timestamp catches it.
|
|
testChecksOverLapse :: IO ()
|
|
testChecksOverLapse = do
|
|
let start = at 2026 3 10
|
|
granted = grant start 3 (newBalance start)
|
|
Just issued <- pure $ issue start granted
|
|
Just lapsed <- pure $ lapse (at 2026 5 20) issued
|
|
Just overLapsed <- pure $ lapse (at 2026 8 20) issued
|
|
verdicts (at 2026 5 20) (Just issued) [lapsed] `shouldBe` [Just True]
|
|
verdicts (at 2026 5 20) (Just issued) [stampedAt (at 2026 5 20) overLapsed] `shouldBe` [Just False]
|
|
bMonths overLapsed `shouldBe` bMonths lapsed - 1
|
|
paidThrough overLapsed `shouldBe` paidThrough lapsed
|
|
-- and a lapse claiming a month before any had elapsed: lapseEntry declines it altogether
|
|
verdicts start (Just issued) [stampedAt start lapsed] `shouldBe` [Just False]
|
|
|
|
testChecksMovedStart :: IO ()
|
|
testChecksMovedStart = do
|
|
let start = at 2026 3 10
|
|
granted = grant start 3 (newBalance start)
|
|
Just issued <- pure $ issue start granted
|
|
verdicts start (Just granted) [issued] `shouldBe` [Just True]
|
|
verdicts start (Just granted) [issued {balanceStartTs = addMonths 1 (bStart issued)}] `shouldBe` [Just False]
|
|
verdicts start (Just granted) [issued {balanceAnchorTs = addMonths 1 start}] `shouldBe` [Just False]
|
|
|
|
testChecksGrantRestart :: IO ()
|
|
testChecksGrantRestart = do
|
|
let t = at 2026 2 10
|
|
opened = newBalance t
|
|
oneMonth = grant t 1 opened
|
|
funded = grant t 2 opened
|
|
Just spent <- pure $ issue t oneMonth
|
|
let restarted = grant (at 2026 6 1) 2 spent
|
|
verdicts (at 2026 6 1) (Just spent) [restarted] `shouldBe` [Just True]
|
|
-- the same entry after a predecessor with months left is a run moved to a later start
|
|
verdicts (at 2026 6 1) (Just funded) [restarted] `shouldBe` [Just False]
|
|
|
|
testChecksNegativeCredit :: IO ()
|
|
testChecksNegativeCredit = do
|
|
let t = at 2026 2 10
|
|
funded = grant t 2 (newBalance t)
|
|
negativeCredit = grant (at 2026 6 1) (-2) funded
|
|
verdicts (at 2026 6 1) (Just funded) [negativeCredit] `shouldBe` [Just False]
|
|
-- the sign is what rejects it: the row itself adds up, and the recompute would confirm it
|
|
bMonths negativeCredit `shouldBe` bMonths funded - 2
|
|
|
|
testChecksTimestamps :: IO ()
|
|
testChecksTimestamps = do
|
|
let start = at 2026 3 10
|
|
granted = grant start 3 (newBalance start)
|
|
Just issued <- pure $ issue start granted
|
|
-- the two clocks are not the same clock, so a row from just ahead of this one is not evidence
|
|
verdicts start (Just granted) [stampedAt (addUTCTime (30 * 60) start) issued] `shouldBe` [Just True]
|
|
-- further ahead than that, we cannot tell their clock from ours, so the row is left unjudged
|
|
verdicts start (Just granted) [stampedAt (addUTCTime (2 * 3600) start) issued] `shouldBe` [Nothing]
|
|
-- behind the row it follows is the service against itself, with no clock of ours in it
|
|
verdicts start (Just granted) [stampedAt (at 2026 3 1) issued] `shouldBe` [Just False]
|
|
|
|
-- Marking a row this version has no operation for as broken would report a newer service as
|
|
-- tampering, which is the opposite of the forward compatibility the rest of this code keeps.
|
|
testChecksUnknownType :: IO ()
|
|
testChecksUnknownType = do
|
|
let start = at 2026 3 10
|
|
granted = grant start 3 (newBalance start)
|
|
Just issued <- pure $ issue start granted
|
|
let unknown = issued {entryType = SEDebit SDUnknown {tag = "future", json = KM.empty}}
|
|
verdicts start (Just granted) [unknown] `shouldBe` [Nothing]
|
|
verdicts start (Just granted) [issued {entryType = SEDebit SDRefund}] `shouldBe` [Nothing]
|
|
-- nor may it switch tier over the months the balance holds
|
|
verdicts start (Just granted) [issued {entryType = SEDebit SDRefund, balanceBadgeType = BTLegend}] `shouldBe` [Just False]
|
|
verdicts start (Just granted) [unknown {balanceMonths = 5}] `shouldBe` [Just False]
|
|
verdicts start (Just granted) [stampedAt (at 2026 3 1) unknown] `shouldBe` [Just False]
|
|
-- an unknown credit takes the same path: fall through to grantEntry and its negative count,
|
|
-- which issued carries, would be rejected instead
|
|
let unknownCredit = issued {entryType = SECredit SCUnknown {tag = "future", json = KM.empty}}
|
|
verdicts start (Just granted) [unknownCredit] `shouldBe` [Nothing]
|
|
|
|
-- A tag with no operation behind it escapes the recompute, leaving only the months identity - which
|
|
-- holds while coverage moves back, or while the balance goes into debt.
|
|
testChecksUncheckedInvariants :: IO ()
|
|
testChecksUncheckedInvariants = do
|
|
let start = at 2026 3 10
|
|
granted = grant start 3 (newBalance start)
|
|
Just issued <- pure $ issue start granted
|
|
let shortened = issued {entryType = SEDebit SDRefund, changeMonths = 0, balanceStartTs = addMonths (-1) (bStart issued)}
|
|
owing = issued {entryType = SEDebit SDRefund, changeMonths = -3, balanceMonths = -1}
|
|
verdicts start (Just issued) [shortened] `shouldBe` [Just False]
|
|
paidThrough shortened `shouldBe` addMonths (-1) (paidThrough issued)
|
|
verdicts start (Just issued) [owing] `shouldBe` [Just False]
|
|
bMonths owing `shouldBe` bMonths issued - 3
|
|
|
|
-- the service's step for a charge it grants: the planner's rows, then the issue at now
|
|
charged :: C.PublicKeyEd25519 -> UTCTime -> UTCTime -> BadgeType -> Int -> StatementEntry -> [StatementEntry]
|
|
charged ownKey periodStart now badgeType months tip = rows <> maybeToList (issue now $ finalBalance tip rows)
|
|
where
|
|
rows = chargeEntries periodStart now badgeType months ownKey "ch1" ("", "", "", "") tip
|
|
|
|
rowKind :: StatementEntry -> T.Text
|
|
rowKind StatementEntry {entryType} = case entryType of
|
|
SECredit c -> creditTypeTag c
|
|
SEDebit d -> debitTypeTag d
|
|
|
|
rowAt :: StatementEntry -> UTCTime
|
|
rowAt StatementEntry {createdAt} = createdAt
|
|
|
|
bAnchor :: StatementEntry -> UTCTime
|
|
bAnchor StatementEntry {balanceAnchorTs} = balanceAnchorTs
|
|
|
|
-- the client checks a statement from the first row the service wrote, as a new purchase receives it
|
|
allVerify :: HasCallStack => [StatementEntry] -> Expectation
|
|
allVerify rows = verdicts (rowAt $ last rows) Nothing rows `shouldBe` map (const $ Just True) rows
|
|
|
|
-- A grant dated to the store's period start is checked by re-running it at that start, after rows
|
|
-- written earlier and before the lapses and issue written at the request: each path a subscription
|
|
-- renews by must keep both the dates in order and the recompute exact.
|
|
testChargeRowsVerify :: IO ()
|
|
testChargeRowsVerify = do
|
|
ownKey <- newPurchaseKey
|
|
let p0 = at 2026 3 10
|
|
days n = addUTCTime (n * nominalDay)
|
|
firstCharge = charged ownKey p0 (addUTCTime 600 p0) BTSupporter 1 (newBalance p0)
|
|
afterFirst = finalBalance (newBalance p0) firstCharge
|
|
-- a first charge, granted onto the seed the service starts a purchase from
|
|
map rowKind firstCharge `shouldBe` ["charge", "badge"]
|
|
allVerify firstCharge
|
|
-- monthly renewals, each charged at the store's period start and asked about some days after it
|
|
let renew (tip, rows) (k, late) =
|
|
let periodStart = addMonths k p0
|
|
new = charged ownKey periodStart (days late periodStart) BTSupporter 1 tip
|
|
in (finalBalance tip new, rows <> new)
|
|
(_, monthly) = foldl renew (afterFirst, firstCharge) [(1, 3), (2, 6), (3, 1)]
|
|
map rowKind monthly `shouldBe` concat (replicate 4 ["charge", "badge"])
|
|
allVerify monthly
|
|
-- a period start equal to the balance start continues the run on its anchor
|
|
let sameStart = charged ownKey (bStart afterFirst) (days 4 $ bStart afterFirst) BTSupporter 1 afterFirst
|
|
map rowKind sameStart `shouldBe` ["charge", "badge"]
|
|
map bAnchor (take 1 sameStart) `shouldBe` [p0]
|
|
allVerify (firstCharge <> sameStart)
|
|
-- and a store clock a minute either side of it still verifies, whichever branch the grant takes
|
|
mapM_
|
|
( \offset -> do
|
|
let rows = charged ownKey (addUTCTime offset $ bStart afterFirst) (days 4 $ bStart afterFirst) BTSupporter 1 afterFirst
|
|
map rowKind rows `shouldBe` ["charge", "badge"]
|
|
allVerify (firstCharge <> rows)
|
|
)
|
|
[-60, 60]
|
|
-- a renewal after billing retry: the store's new period starts when the charge recovered, and the
|
|
-- run restarts there, so coverage follows the store's new renewal date
|
|
let recoveredAt = days 9 (addMonths 1 p0)
|
|
recovered = charged ownKey recoveredAt (days 1 recoveredAt) BTSupporter 1 afterFirst
|
|
map rowKind recovered `shouldBe` ["charge", "badge"]
|
|
map bStart (take 1 recovered) `shouldBe` [recoveredAt]
|
|
map paidThrough (take 1 recovered) `shouldBe` [addMonths 1 recoveredAt]
|
|
allVerify (firstCharge <> recovered)
|
|
-- annual: the first month issued at purchase, then one at each month's start
|
|
let annualFirst = charged ownKey p0 p0 BTSupporter 12 (newBalance p0)
|
|
annualTip = finalBalance (newBalance p0) annualFirst
|
|
yearEnd = addMonths 12 p0
|
|
monthsIssued n = take n (issueAll annualTip)
|
|
-- the device was offline for the year's last month, which is still unissued at the renewal
|
|
tenMore = monthsIssued 10
|
|
monthLeft = finalBalance annualTip tenMore
|
|
renewedAnnual = charged ownKey yearEnd (days 3 yearEnd) BTSupporter 12 monthLeft
|
|
bMonths monthLeft `shouldBe` 1
|
|
map rowKind renewedAnnual `shouldBe` ["lapse", "charge", "badge"]
|
|
allVerify (annualFirst <> tenMore <> renewedAnnual)
|
|
-- the same, with the store's year starting an hour before the ledger's: that month has not run out
|
|
-- at the period start, so it is carried and lapses after the grant
|
|
let earlyAnnual = charged ownKey (addUTCTime (-3600) yearEnd) (days 3 yearEnd) BTSupporter 12 monthLeft
|
|
map rowKind earlyAnnual `shouldBe` ["charge", "lapse", "badge"]
|
|
allVerify (annualFirst <> tenMore <> earlyAnnual)
|
|
-- away from month nine until 45 days past the year end, while the renewal failed and recovered
|
|
-- inside the store's grace period, which keeps the original period start
|
|
let eightMore = monthsIssued 8
|
|
awayTip = finalBalance annualTip eightMore
|
|
graced = charged ownKey yearEnd (days 45 yearEnd) BTSupporter 12 awayTip
|
|
bMonths awayTip `shouldBe` 3
|
|
map rowKind graced `shouldBe` ["lapse", "charge", "lapse", "badge"]
|
|
allVerify (annualFirst <> eightMore <> graced)
|
|
|
|
newPurchaseKey :: IO C.PublicKeyEd25519
|
|
newPurchaseKey = fst <$> (C.newRandom >>= \g -> atomically (C.generateKeyPair g) :: IO (C.KeyPair 'C.Ed25519))
|
|
|
|
bTier :: StatementEntry -> BadgeType
|
|
bTier StatementEntry {balanceBadgeType} = balanceBadgeType
|
|
|
|
-- An upgrade or a transfer takes every month left and keeps the balance start and anchor, so coverage
|
|
-- ends where the issued months end; re-running it verifies the row, and catches one that left months behind.
|
|
testDebitRowsVerify :: IO ()
|
|
testDebitRowsVerify = do
|
|
k <- newPurchaseKey
|
|
let start = at 2026 3 10
|
|
t = at 2026 3 20
|
|
Just issued <- pure $ issue start $ grant start 12 (newBalance start)
|
|
let upgraded = debitEntry t "" (SDUpgrade k) issued
|
|
(bMonths upgraded, bStart upgraded, bAnchor upgraded) `shouldBe` (0, bStart issued, bAnchor issued)
|
|
verdicts t (Just issued) [upgraded] `shouldBe` [Just True]
|
|
verdicts t (Just issued) [debitEntry t "" (SDTransferOut k) issued] `shouldBe` [Just True]
|
|
-- a transfer is written even when nothing is left, as the mark that the purchase moved
|
|
verdicts t (Just upgraded) [debitEntry t "" (SDTransferOut k) upgraded] `shouldBe` [Just True]
|
|
verdicts t (Just issued) [upgraded {changeMonths = -10, balanceMonths = 1}] `shouldBe` [Just False]
|
|
|
|
-- A charge of another tier ends the old run with an upgrade debit of what it still held and starts
|
|
-- a new one: every row it writes must re-run on the client, on each path a tier changes by.
|
|
testTierChangeRowsVerify :: IO ()
|
|
testTierChangeRowsVerify = do
|
|
k <- newPurchaseKey
|
|
let p0 = at 2026 3 10
|
|
days n = addUTCTime (n * nominalDay)
|
|
p1 = addMonths 1 p0
|
|
-- a monthly Legend subscription downgraded to Supporter, which the store charges at renewal
|
|
let legendTip = finalBalance (emptyEntry p0 BTLegend) $ charged k p0 (addUTCTime 600 p0) BTLegend 1 (emptyEntry p0 BTLegend)
|
|
downgraded = charged k p1 (days 2 p1) BTSupporter 1 legendTip
|
|
map rowKind downgraded `shouldBe` ["charge", "badge"]
|
|
map bTier downgraded `shouldBe` [BTSupporter, BTSupporter]
|
|
map bAnchor (take 1 downgraded) `shouldBe` [p1]
|
|
verdicts (days 2 p1) (Just legendTip) downgraded `shouldBe` [Just True, Just True]
|
|
-- an annual Supporter subscription upgraded to annual Legend in its third month, every month so
|
|
-- far issued: the nine left are debited, and the new year starts at the upgrade
|
|
let annual = charged k p0 (addUTCTime 600 p0) BTSupporter 12 (newBalance p0)
|
|
afterFirst = finalBalance (newBalance p0) annual
|
|
secondMonth = pass p1 afterFirst
|
|
thirdMonth = pass (addMonths 2 p0) (finalBalance afterFirst secondMonth)
|
|
afterThird = finalBalance afterFirst (secondMonth <> thirdMonth)
|
|
u = days 10 (addMonths 2 p0)
|
|
upgraded = charged k u (addUTCTime 60 u) BTLegend 12 afterThird
|
|
map rowKind upgraded `shouldBe` ["upgrade", "charge", "badge"]
|
|
map bMonths upgraded `shouldBe` [0, 12, 11]
|
|
map (\e -> (bStart e, bAnchor e, bTier e)) (take 1 $ drop 1 upgraded) `shouldBe` [(u, u, BTLegend)]
|
|
case upgraded of
|
|
StatementEntry {entryType = SEDebit SDUpgrade {toPurchaseKey}} : _ -> toPurchaseKey `shouldBe` k
|
|
_ -> expectationFailure "no upgrade debit"
|
|
allVerify (annual <> secondMonth <> thirdMonth <> upgraded)
|
|
-- the same upgrade after two months nobody asked for: they lapse before the rest is debited
|
|
let late = days 10 (addMonths 3 p0)
|
|
lapsedUpgrade = charged k late (addUTCTime 60 late) BTLegend 12 afterFirst
|
|
map rowKind lapsedUpgrade `shouldBe` ["lapse", "upgrade", "charge", "badge"]
|
|
map bMonths lapsedUpgrade `shouldBe` [9, 0, 12, 11]
|
|
allVerify (annual <> lapsedUpgrade)
|
|
-- a period the store starts before a month the service issued since is dated at that issue, so
|
|
-- the rows still follow it
|
|
let issuedAt = days 3 p1
|
|
issuedLate = pass issuedAt afterFirst
|
|
clamped = charged k (days 1 p1) (addUTCTime 3600 issuedAt) BTLegend 12 (finalBalance afterFirst issuedLate)
|
|
map rowKind clamped `shouldBe` ["upgrade", "charge", "badge"]
|
|
map rowAt (take 2 clamped) `shouldBe` [issuedAt, issuedAt]
|
|
allVerify (annual <> issuedLate <> clamped)
|
|
-- a grant of another tier straight over the months still held would discard them
|
|
let overwritten = grantEntry u "" BTLegend 12 (SCCharge "ch1") afterThird
|
|
verdicts u (Just afterThird) [overwritten] `shouldBe` [Just False]
|
|
-- an upgrade found only at the renewal check, after every month of the old year was issued: the new run
|
|
-- starts at the last issue, and the next charge of the new tier, from a period that started earlier, follows it
|
|
let yearIssued = issueAll afterFirst
|
|
found = charged k u (addMonths 12 p0) BTLegend 12 (finalBalance afterFirst yearIssued)
|
|
legendIssued = issueAll (finalBalance afterFirst (yearIssued <> found))
|
|
legendYearTip = finalBalance afterFirst (yearIssued <> found <> legendIssued)
|
|
renewed = charged k (addMonths 12 u) (days 3 $ paidThrough legendYearTip) BTLegend 12 legendYearTip
|
|
map rowKind found `shouldBe` ["charge", "lapse", "badge"]
|
|
map rowKind renewed `shouldBe` ["charge", "badge"]
|
|
allVerify (annual <> yearIssued <> found <> legendIssued <> renewed)
|
|
|
|
-- A failed renewal is otherwise left until the next chat start or activate, which on a desktop
|
|
-- left running can be days - long enough for a funded badge to lapse.
|
|
testRetryClassification :: IO ()
|
|
testRetryClassification = do
|
|
let retryFor = badgeErrorRetry . chatErrorAgent
|
|
-- an unanswered request is the likeliest renewal failure, and it is the agent's own error
|
|
retryFor (AGENT (A_SERVICE ASETimeout)) `shouldBe` True
|
|
retryFor (BROKER "localhost" TIMEOUT) `shouldBe` True
|
|
retryFor (BROKER "localhost" (NETWORK NETimeoutError)) `shouldBe` True
|
|
-- terminal: the same request would fail the same way, and repeating it would spin
|
|
retryFor (AGENT (A_SERVICE ASEBadSignature)) `shouldBe` False
|
|
retryFor (AGENT (A_SERVICE (ASERejected "no"))) `shouldBe` False
|
|
badgeErrorRetry (ChatError (CECommandError "unexpected badge service response")) `shouldBe` False
|
|
|
|
-- A failure that never clears is repeated for as long as the balance funds a month, so the wait
|
|
-- has to grow: at a fixed interval an annual code would ask hundreds of times a day, all year.
|
|
testRetryBackoff :: IO ()
|
|
testRetryBackoff = do
|
|
let ri@RetryInterval {initialInterval, maxInterval} = badgeRetryInterval defaultChatConfig
|
|
advance (elapsed, delay) =
|
|
let elapsed' = elapsed + delay
|
|
in (elapsed', nextRetryDelay elapsed' delay ri)
|
|
delays = map snd $ take 40 $ iterate advance (0, initialInterval)
|
|
head delays `shouldBe` initialInterval
|
|
delays `shouldSatisfy` all (\d -> d >= initialInterval && d <= maxInterval)
|
|
delays `shouldSatisfy` nonDecreasing
|
|
-- it reaches the cap rather than creeping towards it, and stays there
|
|
last delays `shouldBe` maxInterval
|
|
|
|
-- A service answering retryAfter 0 would put the next attempt at now, and the worker would ask
|
|
-- again as fast as the round trip allows, for as long as the service kept answering that way.
|
|
testServiceRetryFloor :: IO ()
|
|
testServiceRetryFloor = do
|
|
let ri@RetryInterval {initialInterval, maxInterval} = badgeRetryInterval defaultChatConfig
|
|
floorWait = fromIntegral initialInterval / 1000000 :: NominalDiffTime
|
|
aboveCap = 2 * fromIntegral maxInterval / 1000000 :: NominalDiffTime
|
|
-- a code carrying no wait is terminal for this request, and waits what any stalled month waits
|
|
badgeRetryAfter ri Nothing `shouldBe` badgeStalledInterval
|
|
-- nothing the service names brings the wait below where a retry of its own would start
|
|
badgeRetryAfter ri (Just 0) `shouldBe` floorWait
|
|
badgeRetryAfter ri (Just 1) `shouldBe` floorWait
|
|
badgeRetryAfter ri (Just $ round floorWait) `shouldBe` floorWait
|
|
-- above that it is honoured as sent, and not capped: a service may know it is down for the day
|
|
badgeRetryAfter ri (Just 600) `shouldBe` 600
|
|
badgeRetryAfter ri (Just $ round aboveCap) `shouldBe` aboveCap
|
|
|
|
-- badges-rpc.md defines retryAfter as marking the transient codes, and every other code as
|
|
-- terminal for the command attempted. The client repeats a code that carries one on the service's
|
|
-- schedule, so the set is the protocol's and not a judgement to make per call site.
|
|
testServiceRetryAfter :: IO ()
|
|
testServiceRetryAfter = do
|
|
badgeErrorRetryAfter BSEPaymentPending `shouldBe` Just 300
|
|
badgeErrorRetryAfter BSEProviderUnavailable `shouldBe` Just 300
|
|
badgeErrorRetryAfter BSERateLimited `shouldBe` Just 60
|
|
-- internal is the one most likely to clear on its own, and is still terminal: repeating it on
|
|
-- the service's cadence presses a service already failing, and the client has its own floor
|
|
badgeErrorRetryAfter BSEInternal `shouldBe` Nothing
|
|
mapM_
|
|
(\code -> badgeErrorRetryAfter code `shouldBe` Nothing)
|
|
[BSEBadRequest, BSEUnsupportedVersion, BSEUnknownPurchaseKey, BSECodeInvalid, BSECodeUsed, BSECodeExpired, BSEProviderNotConfigured, BSETestPurchase, BSETransferLimited, BSEUnknown "future_code"]
|
|
|
|
-- The app shows the recorded failure in a sentence, so an agent error is stored as the agent
|
|
-- error and not as the chat error wrapping it, whether or not it can clear on its own.
|
|
testIssueFailureClassification :: IO ()
|
|
testIssueFailureClassification = do
|
|
let failureFor = badgeIssueFailure . chatErrorAgent
|
|
timeout = BROKER "localhost" TIMEOUT
|
|
auth = SMP "localhost" AUTH
|
|
failureFor (AGENT (A_SERVICE ASETimeout)) `shouldBe` BIFServiceTimeout
|
|
failureFor timeout `shouldBe` BIFNetwork {agentError = tshow timeout}
|
|
failureFor auth `shouldBe` BIFUnexpected {message = tshow auth}
|
|
badgeIssueFailure (ChatError (CECommandError "unexpected badge service response")) `shouldBe` BIFUnexpected {message = "unexpected badge service response"}
|
|
badgeIssueFailure (ChatError (CEBadgeRedeemError BREUnknownKeyIndex)) `shouldBe` BIFInvalidCredential
|
|
badgeIssueFailure (ChatError (CEBadgeRedeemError BRECredentialNotVerified)) `shouldBe` BIFInvalidCredential
|
|
|
|
-- A refusal the service marks transient is not worth a word before the credential lapses. Internal
|
|
-- comes without retryAfter so that a failing service is not pressed, not because the fault is
|
|
-- final, so it waits the same way; any other refusal is told at once.
|
|
testServiceErrorTransience :: IO ()
|
|
testServiceErrorTransience = do
|
|
badgeFailureTransient BIFServiceError {code = BSERateLimited, retryable = True} `shouldBe` True
|
|
badgeFailureTransient BIFServiceError {code = BSEInternal, retryable = False} `shouldBe` True
|
|
badgeFailureTransient BIFServiceError {code = BSEUnknownPurchaseKey, retryable = False} `shouldBe` False
|
|
badgeFailureTransient BIFServiceError {code = BSEUnknown "future_code", retryable = False} `shouldBe` False
|
|
badgeFailureTransient BIFServiceError {code = BSEUnknown "future_code", retryable = True} `shouldBe` True
|
|
|
|
-- The failure is stored as text and read back by getBadgePurchase, so every value this version
|
|
-- writes must read back as itself, and any other value must still read: a row it cannot parse
|
|
-- would otherwise fail every read of the purchase.
|
|
testIssueFailureEncoding :: IO ()
|
|
testIssueFailureEncoding = do
|
|
mapM_
|
|
(\f -> strDecode (strEncode f) `shouldBe` Right f)
|
|
[ BIFServiceError {code = BSEUnknownPurchaseKey, retryable = False},
|
|
BIFServiceError {code = BSERateLimited, retryable = True},
|
|
BIFServiceError {code = BSEUnknown "future_code", retryable = True},
|
|
BIFServiceError {code = BSEUnknown "code with spaces", retryable = False},
|
|
BIFServiceError {code = BSEUnknown "", retryable = False},
|
|
BIFServiceTimeout,
|
|
BIFNetwork {agentError = "BROKER \"smp://x\" NETWORK"},
|
|
BIFInvalidCredential,
|
|
BIFUnexpected {message = "unexpected badge service response"},
|
|
BIFUnexpected {message = "several words and : punctuation"}
|
|
]
|
|
-- the row the CLI prints, and what a reader of the database sees
|
|
strEncode BIFServiceError {code = BSECodeUsed, retryable = False} `shouldBe` "service_error final code_used"
|
|
strEncode BIFServiceError {code = BSERateLimited, retryable = True} `shouldBe` "service_error retry rate_limited"
|
|
strEncode BIFServiceTimeout `shouldBe` "service_timeout"
|
|
-- a row a later version wrote, or one edited by hand, still reads - as the text it holds
|
|
strDecode "future_failure with text" `shouldBe` Right BIFUnexpected {message = "future_failure with text"}
|
|
strDecode "service_timeout trailing" `shouldBe` Right BIFUnexpected {message = "service_timeout trailing"}
|
|
strDecode "service_error maybe code_used" `shouldBe` Right BIFUnexpected {message = "service_error maybe code_used"}
|
|
|
|
-- The text of a code this version does not know is chosen by the service, and the app shows it in
|
|
-- a sentence of its own - so it is bounded and stripped of anything but a code before it is stored.
|
|
testServiceErrorCodeBounded :: IO ()
|
|
testServiceErrorCodeBounded = do
|
|
badgeServiceErrorText BSECodeUsed `shouldBe` "code_used"
|
|
badgeServiceErrorText (BSEUnknown "future_code") `shouldBe` "future_code"
|
|
badgeServiceErrorText (BSEUnknown "two words") `shouldBe` "twowords"
|
|
badgeServiceErrorText (BSEUnknown (T.replicate 100 "a")) `shouldBe` T.replicate 32 "a"
|
|
badgeServiceErrorText (BSEUnknown "Visit evil.example.com!") `shouldBe` "isitevilexamplecom"
|
|
|
|
-- The client replicates entry_credit_type / entry_debit_type verbatim, so a stored tag that
|
|
-- disagreed with the wire tag would put a different row on each side.
|
|
testEntryTypeColumns :: IO ()
|
|
testEntryTypeColumns = do
|
|
k <- fst <$> (C.newRandom >>= \g -> atomically (C.generateKeyPair g) :: IO (C.KeyPair 'C.Ed25519))
|
|
let credits = [SCPayment Nothing, SCCode, SCCharge "ch1", SCSupport, SCTransferIn k, SCOpening]
|
|
debits = [SDRefund, SDUpgrade k, SDTransferOut k, SDSupport, SDBadge, SDLapse]
|
|
mapM_ (\c -> wireTag (J.toJSON (SECredit c)) "credit" `shouldBe` Just (creditTypeTag c)) credits
|
|
mapM_ (\d -> wireTag (J.toJSON (SEDebit d)) "debit" `shouldBe` Just (debitTypeTag d)) debits
|
|
-- the types this version writes survive a round trip through the columns, a payment credit
|
|
-- through the payment its row references, a charge credit through its charge, and a transfer
|
|
-- or an upgrade through the purchase it names
|
|
mapM_
|
|
(\t -> uncurry3 (entryTypeFromColumns noEntryReferences) (entryTypeColumns t) `shouldSatisfy` sameEntryType t)
|
|
[SECredit SCCode, SEDebit SDBadge, SEDebit SDLapse]
|
|
let storeCredit = SECredit (SCPayment Nothing)
|
|
invoiceCredit = SECredit (SCPayment (Just (InvoiceId "inv1")))
|
|
chargeCredit = SECredit (SCCharge "ch1")
|
|
transferInCredit = SECredit (SCTransferIn k)
|
|
upgradeDebit = SEDebit (SDUpgrade k)
|
|
transferOutDebit = SEDebit (SDTransferOut k)
|
|
fromKey = noEntryReferences {refFromPurchaseKey = Just k}
|
|
toKey = noEntryReferences {refToPurchaseKey = Just k}
|
|
uncurry3 (entryTypeFromColumns noEntryReferences {refPayment = Just Nothing}) (entryTypeColumns storeCredit) `shouldSatisfy` sameEntryType storeCredit
|
|
uncurry3 (entryTypeFromColumns noEntryReferences {refPayment = Just (Just (InvoiceId "inv1"))}) (entryTypeColumns invoiceCredit) `shouldSatisfy` sameEntryType invoiceCredit
|
|
uncurry3 (entryTypeFromColumns noEntryReferences {refChargeId = Just "ch1"}) (entryTypeColumns chargeCredit) `shouldSatisfy` sameEntryType chargeCredit
|
|
uncurry3 (entryTypeFromColumns fromKey) (entryTypeColumns transferInCredit) `shouldSatisfy` sameEntryType transferInCredit
|
|
mapM_ (\t -> uncurry3 (entryTypeFromColumns toKey) (entryTypeColumns t) `shouldSatisfy` sameEntryType t) [upgradeDebit, transferOutDebit]
|
|
-- a type that needs a reference column is not silently read back as something else, nor from
|
|
-- the other purchase column
|
|
mapM_
|
|
(\t -> uncurry3 (entryTypeFromColumns noEntryReferences) (entryTypeColumns t) `shouldSatisfy` isNothing)
|
|
[storeCredit, chargeCredit, transferInCredit, upgradeDebit, transferOutDebit]
|
|
uncurry3 (entryTypeFromColumns toKey) (entryTypeColumns transferInCredit) `shouldSatisfy` isNothing
|
|
mapM_ (\t -> uncurry3 (entryTypeFromColumns fromKey) (entryTypeColumns t) `shouldSatisfy` isNothing) [upgradeDebit, transferOutDebit]
|
|
-- which is why every type is stored as its own JSON as well, and read from that first: the
|
|
-- columns alone would answer a row naming an invoice or a purchase as no row at all
|
|
mapM_ roundTrips credits
|
|
mapM_ roundTrips debits
|
|
where
|
|
uncurry3 f (a, b, c) = f a b c
|
|
sameEntryType t = maybe False ((J.toJSON t ==) . J.toJSON)
|
|
wireTag v fld = case v of
|
|
J.Object o | Just (J.Object inner) <- KM.lookup fld o, Just (J.String t) <- KM.lookup "type" inner -> Just t
|
|
_ -> Nothing
|
|
|
|
-- Service protocol JSON, against docs/protocol/badges-rpc.schema.json
|
|
|
|
testRedeemRequestJSON :: IO ()
|
|
testRedeemRequestJSON = do
|
|
drg <- C.newRandom
|
|
mk <- generateMasterKey drg
|
|
(k, _) <- atomically $ C.generateKeyPair drg :: IO (C.KeyPair 'C.Ed25519)
|
|
code <- randomBadgeCode drg
|
|
let req = BadgeServiceRequest {version = Version 1, purchaseKey = Just k, request = BSCRedeemBadgeCode {masterKey = mk, code = badgeCodeText code}}
|
|
J.toJSON req
|
|
`shouldBe` J.object
|
|
[ "version" J..= (1 :: Int),
|
|
"purchaseKey" J..= k,
|
|
"request" J..= J.object ["type" J..= ("redeemBadgeCode" :: T.Text), "masterKey" J..= mk, "code" J..= badgeCodeText code]
|
|
]
|
|
-- purchaseKey is optional in the schema, and a nullary command is a bare tagged object
|
|
J.toJSON BadgeServiceRequest {version = Version 1, purchaseKey = Nothing, request = BSCGetBadgeCatalog}
|
|
`shouldBe` J.object ["version" J..= (1 :: Int), "request" J..= J.object ["type" J..= ("getBadgeCatalog" :: T.Text)]]
|
|
roundTrips req
|
|
|
|
testPurchaseRequestJSON :: IO ()
|
|
testPurchaseRequestJSON = do
|
|
drg <- C.newRandom
|
|
mk <- generateMasterKey drg
|
|
(k, _) <- atomically $ C.generateKeyPair drg :: IO (C.KeyPair 'C.Ed25519)
|
|
let payment = SPGoogle {productId = "badge_supporter_01", token = "token"}
|
|
req = BadgeServiceRequest {version = Version 1, purchaseKey = Just k, request = BSCPurchaseBadge {masterKey = mk, payment, upgrade = Nothing}}
|
|
-- the client states its master key and the store's evidence, and nothing a receipt already decides
|
|
J.toJSON req
|
|
`shouldBe` J.object
|
|
[ "version" J..= (1 :: Int),
|
|
"purchaseKey" J..= k,
|
|
"request"
|
|
J..= J.object
|
|
[ "type" J..= ("purchaseBadge" :: T.Text),
|
|
"masterKey" J..= mk,
|
|
"payment" J..= J.object ["type" J..= ("google" :: T.Text), "productId" J..= ("badge_supporter_01" :: T.Text), "token" J..= ("token" :: T.Text)]
|
|
]
|
|
]
|
|
J.toJSON SPApple {jws = "a.b.c"} `shouldBe` J.object ["type" J..= ("apple" :: T.Text), "jws" J..= ("a.b.c" :: T.Text)]
|
|
roundTrips req
|
|
|
|
testStoreTransactionRef :: IO ()
|
|
testStoreTransactionRef = do
|
|
let jws transactionId signature = T.intercalate "." [part "{\"alg\":\"ES256\"}", part ("{\"transactionId\":\"" <> transactionId <> "\",\"productId\":\"BADGE_SUPPORTER_01\"}"), signature]
|
|
part = safeDecodeUtf8 . B64U.encodeUnpadded . encodeUtf8
|
|
apple = storeTransactionRef . SPApple
|
|
-- the store may sign the same transaction again, and a retry must find the keys it stashed
|
|
apple (jws "2000000812345671" "c2lnbmVkIG9uY2U") `shouldBe` Just (StoreTransactionRef PPApple "2000000812345671")
|
|
apple (jws "2000000812345671" "c2lnbmVkIGFnYWlu") `shouldBe` apple (jws "2000000812345671" "c2lnbmVkIG9uY2U")
|
|
apple (jws "2000000812345672" "c2lnbmVkIG9uY2U") `shouldNotBe` apple (jws "2000000812345671" "c2lnbmVkIG9uY2U")
|
|
apple "not.a-jws" `shouldBe` Nothing
|
|
apple (T.intercalate "." [part "{}", part "{\"productId\":\"BADGE_SUPPORTER_01\"}", "sig"]) `shouldBe` Nothing
|
|
-- a Play token is a bearer secret, so it is kept only as its hash
|
|
let google = storeTransactionRef SPGoogle {productId = "badge_supporter_01", token = "play-token"}
|
|
google `shouldSatisfy` maybe False (\(StoreTransactionRef provider ref) -> provider == PPGoogle && ref /= "play-token")
|
|
google `shouldBe` storeTransactionRef SPGoogle {productId = "badge_supporter_01", token = "play-token"}
|
|
storeTransactionRef SPInvoice {invoiceId = InvoiceId "inv"} `shouldBe` Nothing
|
|
|
|
-- every renewal of a subscription is a new transaction with a new id, and must still find the purchase its first charge made
|
|
testAppleTransactionRef :: IO ()
|
|
testAppleTransactionRef = do
|
|
let jws fields = T.intercalate "." [part "{\"alg\":\"ES256\"}", part (safeDecodeUtf8 $ LB.toStrict $ J.encode $ J.object fields), "c2lnbmVk"]
|
|
part = safeDecodeUtf8 . B64U.encodeUnpadded . encodeUtf8
|
|
ids = ["transactionId" J..= ("2000000900000002" :: T.Text), "originalTransactionId" J..= ("2000000900000001" :: T.Text)]
|
|
ofType t = ("type" J..= (t :: T.Text)) : ids
|
|
appleTransactionRef (jws $ ofType "Auto-Renewable Subscription") `shouldBe` Just "2000000900000001"
|
|
appleTransactionRef (jws $ ofType "Consumable") `shouldBe` Just "2000000900000002"
|
|
appleTransactionRef (jws ids) `shouldBe` Just "2000000900000002"
|
|
-- a subscription is never claimed by its own transaction id, which the next renewal would not share
|
|
appleTransactionRef (jws $ take 2 (ofType "Auto-Renewable Subscription")) `shouldBe` Nothing
|
|
|
|
testAppleTransactionFacts :: IO ()
|
|
testAppleTransactionFacts = do
|
|
let jws fields = T.intercalate "." [part "{\"alg\":\"ES256\"}", part (safeDecodeUtf8 $ LB.toStrict $ J.encode $ J.object fields), "c2lnbmVk"]
|
|
part = safeDecodeUtf8 . B64U.encodeUnpadded . encodeUtf8
|
|
renewal = ["transactionId" J..= ("2000000900000002" :: T.Text), "type" J..= ("Auto-Renewable Subscription" :: T.Text)]
|
|
facts purchaseDate revoked autoRenewable = Just AppleTransactionFacts {transactionId = "2000000900000002", productId = Nothing, purchaseDate, expiresDate = Nothing, revoked, autoRenewable}
|
|
appleTransactionFacts (jws $ ("purchaseDate" J..= (1769904000000 :: Int)) : renewal) `shouldBe` facts (Just 1769904000000) False True
|
|
appleTransactionFacts (jws $ ("productId" J..= ("SUBSCR_BADGE_LEGEND_YEAR_01" :: T.Text)) : renewal)
|
|
`shouldBe` Just AppleTransactionFacts {transactionId = "2000000900000002", productId = Just "SUBSCR_BADGE_LEGEND_YEAR_01", purchaseDate = Nothing, expiresDate = Nothing, revoked = False, autoRenewable = True}
|
|
appleTransactionFacts (jws $ ("expiresDate" J..= (1772582400000 :: Int)) : renewal) `shouldBe` ((\f -> f {expiresDate = Just 1772582400000}) <$> facts Nothing False True)
|
|
appleTransactionFacts (jws $ ("expiresDate" J..= ("next month" :: T.Text)) : renewal) `shouldBe` facts Nothing False True
|
|
-- the service reads a null revocationDate as not revoked, and so does the client
|
|
appleTransactionFacts (jws $ ("revocationDate" J..= J.Null) : renewal) `shouldBe` facts Nothing False True
|
|
appleTransactionFacts (jws $ ("revocationDate" J..= (1770000000000 :: Int)) : renewal) `shouldBe` facts Nothing True True
|
|
-- a date that does not read is absent, and leaves the rest of the payload readable
|
|
appleTransactionFacts (jws $ ("purchaseDate" J..= ("yesterday" :: T.Text)) : renewal) `shouldBe` facts Nothing False True
|
|
appleTransactionFacts (jws $ take 1 renewal <> ["type" J..= ("Consumable" :: T.Text)]) `shouldBe` facts Nothing False False
|
|
appleTransactionFacts (jws $ drop 1 renewal) `shouldBe` Nothing
|
|
appleTransactionFacts "not.a-jws" `shouldBe` Nothing
|
|
|
|
testResumableCharge :: IO ()
|
|
testResumableCharge = do
|
|
let nowSeconds = 1770000000 :: Integer
|
|
now = posixSecondsToUTCTime $ fromInteger nowSeconds
|
|
secondsAhead s = addUTCTime (fromInteger s) now
|
|
epochMs s = (nowSeconds + s) * 1000
|
|
oneDay = 86400
|
|
oneMonth = 30 * oneDay
|
|
jws fields = T.intercalate "." [part "{\"alg\":\"ES256\"}", part (safeDecodeUtf8 $ LB.toStrict $ J.encode $ J.object fields), "c2lnbmVk"]
|
|
part = safeDecodeUtf8 . B64U.encodeUnpadded . encodeUtf8
|
|
ofType t fields = SPApple {jws = jws $ ["transactionId" J..= ("2000000900000002" :: T.Text), "type" J..= (t :: T.Text)] <> fields}
|
|
renewalWith = ofType "Auto-Renewable Subscription"
|
|
dated bought expires = renewalWith ["purchaseDate" J..= epochMs bought, "expiresDate" J..= epochMs expires]
|
|
resumableCharge now (dated 0 oneMonth) `shouldBe` Just now
|
|
resumableCharge now (dated 60 oneMonth) `shouldBe` Just (secondsAhead 60)
|
|
resumableCharge now (dated (oneDay - 1) oneMonth) `shouldBe` Just (secondsAhead (oneDay - 1))
|
|
-- dated as far ahead as the allowed skew or further, as a forged payload can be
|
|
resumableCharge now (dated oneDay oneMonth) `shouldBe` Nothing
|
|
resumableCharge now (dated (365 * oneDay) (400 * oneDay)) `shouldBe` Nothing
|
|
-- the paid period it bought has ended
|
|
resumableCharge now (dated (-oneMonth) 1) `shouldBe` Just (secondsAhead (-oneMonth))
|
|
resumableCharge now (dated (-oneMonth) 0) `shouldBe` Nothing
|
|
resumableCharge now (renewalWith ["purchaseDate" J..= epochMs 0, "expiresDate" J..= epochMs oneMonth, "revocationDate" J..= epochMs 0]) `shouldBe` Nothing
|
|
resumableCharge now (ofType "Non-Renewing Subscription" ["purchaseDate" J..= epochMs 0, "expiresDate" J..= epochMs oneMonth]) `shouldBe` Nothing
|
|
resumableCharge now (renewalWith ["expiresDate" J..= epochMs oneMonth]) `shouldBe` Nothing
|
|
resumableCharge now (renewalWith ["purchaseDate" J..= epochMs 0]) `shouldBe` Nothing
|
|
resumableCharge now SPGoogle {productId = "subscr_badge_supporter_01", token = "fake-play-token"} `shouldBe` Nothing
|
|
resumeHoldEnded (secondsAhead oneDay) now `shouldBe` True
|
|
resumeHoldEnded (secondsAhead (oneDay - 1)) now `shouldBe` False
|
|
|
|
testChargePeriodOver :: IO ()
|
|
testChargePeriodOver = do
|
|
let startsAt = UTCTime (fromGregorian 2026 10 20) 43200
|
|
endsAt = addUTCTime 300 startsAt
|
|
charge = StoreCharge {chargeRef = "2000000900000002", planId = "SUBSCR_BADGE_SUPPORTER_MONTH_01", periodStart = startsAt, periodEnd = endsAt, chargePaid = Nothing, revoked = False, offer = False}
|
|
grantAt t = grantableCharge PPApple t SubscriptionCheck {subscriptionState = SSRenewing, testSubscription = False, latestCharge = Just charge}
|
|
periodOver = \case
|
|
Left NGPeriodOver -> True
|
|
_ -> False
|
|
either (const Nothing) (Just . snd) (grantAt $ addUTCTime 240 startsAt) `shouldBe` Just (BTSupporter, 1)
|
|
grantAt endsAt `shouldSatisfy` periodOver
|
|
grantAt (addUTCTime 60 endsAt) `shouldSatisfy` periodOver
|
|
|
|
testShownServiceRequest :: IO ()
|
|
testShownServiceRequest = do
|
|
drg <- C.newRandom
|
|
mk <- generateMasterKey drg
|
|
(k, _) <- atomically $ C.generateKeyPair drg :: IO (C.KeyPair 'C.Ed25519)
|
|
let shown request = case J.toJSON BadgeServiceRequest {version = Version 1, purchaseKey = Just k, request} of
|
|
J.Object o -> J.Object (shownServiceRequest o)
|
|
_ -> J.Null
|
|
typeOnly t = J.object ["request" J..= J.object ["type" J..= (t :: T.Text)]]
|
|
shown BSCPurchaseBadge {masterKey = mk, payment = SPApple {jws = "a.b.c"}, upgrade = Nothing} `shouldBe` typeOnly "purchaseBadge"
|
|
shown BSCRedeemBadgeCode {masterKey = mk, code = "SB-00000-00000-00000-00001"} `shouldBe` typeOnly "redeemBadgeCode"
|
|
shown BSCTransferBadge {masterKey = mk, payment = SPApple {jws = "a.b.c"}} `shouldBe` typeOnly "transferBadge"
|
|
|
|
testGoogleProductIdPath :: IO ()
|
|
testGoogleProductIdPath = do
|
|
let refused productId = case toStoreReceipt uncalledVerifier SPGoogle {productId, token = validPlayToken} of
|
|
Just (Left SRInvalid {}) -> True
|
|
_ -> False
|
|
mapM_ (\p -> refused p `shouldBe` True) ["badge_legend_01/tokens/other?", "badge_legend_01?x", "badge_legend_01#x", "..", "../badge_legend_01", "Badge_legend_01", ""]
|
|
case toStoreReceipt uncalledVerifier SPGoogle {productId = "badge_supporter_01", token = validPlayToken} of
|
|
Just (Right StoreReceipt {txRef = StoreTransactionRef {provider}}) -> provider `shouldBe` PPGoogle
|
|
_ -> expectationFailure "a valid product id and token were refused"
|
|
|
|
testGoogleTokenPath :: IO ()
|
|
testGoogleTokenPath = do
|
|
let unsent token = case toStoreReceipt uncalledVerifier SPGoogle {productId = "badge_supporter_01", token} of
|
|
Just (Left SRUnreachable {}) -> True
|
|
_ -> False
|
|
mapM_ (\t -> unsent t `shouldBe` True) ["a/b", "../x", "t?x", "t#x", "t x", ""]
|
|
|
|
uncalledVerifier :: StoreVerifier
|
|
uncalledVerifier = StoreVerifier {verifyApple = Nothing, verifyGoogle = Just $ \_ _ -> error "verifier called", acknowledgeGoogle = Nothing, acknowledgeGoogleSubscription = Nothing, checkSubscription = Nothing, verifyTimeout = 500000, storeChecks = ChecksAfterCoverage, creditTestPurchases = False}
|
|
|
|
validPlayToken :: T.Text
|
|
validPlayToken = "fake-play-token.AO-J1Oz9x2kqE7wYt3"
|
|
|
|
testMockVouchesForClaim :: IO ()
|
|
testMockVouchesForClaim = do
|
|
mockStoreVerifier <- newMockStoreVerifier getCurrentTime
|
|
let part = safeDecodeUtf8 . B64U.encodeUnpadded . encodeUtf8
|
|
signed = T.intercalate "." [part "{\"alg\":\"ES256\"}", part "{\"transactionId\":\"2000000812345671\",\"productId\":\"BADGE_SUPPORTER_01\"}", "c2lnbmVk"]
|
|
vouchesForClaim payment = case toStoreReceipt mockStoreVerifier payment of
|
|
Just (Right StoreReceipt {txRef = StoreTransactionRef {transactionRef = providerRef}, verifyReceipt}) ->
|
|
verifyReceipt >>= \case
|
|
Right VerifiedStoreTransaction {transactionRef, testPurchase} -> (transactionRef, testPurchase) `shouldBe` (providerRef, False)
|
|
Left refusal -> expectationFailure ("the mock refused: " <> show refusal)
|
|
_ -> expectationFailure "refused before the mock was asked"
|
|
vouchesForClaim SPApple {jws = signed}
|
|
vouchesForClaim SPGoogle {productId = "badge_supporter_01", token = "fake-play-token.AO-J1Oz9x2kqE7wYt3"}
|
|
|
|
testSurviveRequestFailure :: IO ()
|
|
testSurviveRequestFailure = do
|
|
survive "a request" (throwIO $ userError "failed") `shouldReturn` ()
|
|
started <- newEmptyMVar
|
|
stopped <- newEmptyMVar
|
|
t <- forkIO $ survive "a request" (putMVar started () >> threadDelay 10000000) `catch` (putMVar stopped . asyncException)
|
|
takeMVar started
|
|
killThread t
|
|
takeMVar stopped `shouldReturn` True
|
|
where
|
|
asyncException :: SomeException -> Bool
|
|
asyncException e = isJust (fromException e :: Maybe SomeAsyncException)
|
|
|
|
testCredentialResponseJSON :: IO ()
|
|
testCredentialResponseJSON = do
|
|
Right (_, sk) <- bbsKeyGen
|
|
drg <- C.newRandom
|
|
mk <- generateMasterKey drg
|
|
let info = BadgeInfo {badgeType = BTSupporter, badgeExpiry = futureTime, badgeExtra = ""}
|
|
Right cred <- issueBadge testKeyIdx sk (VerifiedBadgeRequest BadgeRequest {masterKey = mk, badgeInfo = info})
|
|
let resp = BSPBadgeCredential {credential = Just cred, receipt = Nothing, statement = BadgeStatement {entries = [], previousEntryId = Nothing}, subscription = Nothing}
|
|
J.toJSON resp
|
|
`shouldBe` J.object
|
|
[ "type" J..= ("badgeCredential" :: T.Text),
|
|
"credential" J..= cred,
|
|
"statement" J..= J.object ["entries" J..= ([] :: [J.Value])]
|
|
]
|
|
roundTrips resp
|
|
|
|
testCredentialSubscriptionJSON :: IO ()
|
|
testCredentialSubscriptionJSON = do
|
|
let states = [(SSRenewing, "renewing"), (SSCancelled, "cancelled"), (SSBillingRetry, "billingRetry"), (SSEnded, "ended")]
|
|
mapM_ (\(s, t) -> (J.toJSON s, J.fromJSON (J.String t)) `shouldBe` (J.String t, J.Success s)) states
|
|
let response subscription_ = J.object $ ["type" J..= ("badgeCredential" :: T.Text), "statement" J..= J.object ["entries" J..= ([] :: [J.Value])]] <> maybe [] (\s -> ["subscription" J..= (s :: T.Text)]) subscription_
|
|
subscriptionOf v = case J.fromJSON v of
|
|
J.Success BSPBadgeCredential {subscription} -> Right subscription
|
|
J.Success _ -> Left "not a badgeCredential"
|
|
J.Error e -> Left e
|
|
subscriptionOf (response Nothing) `shouldBe` Right Nothing
|
|
subscriptionOf (response (Just "billingRetry")) `shouldBe` Right (Just SSBillingRetry)
|
|
-- a state added by a newer service does not fail the response, and is not read as ended
|
|
subscriptionOf (response (Just "paused")) `shouldBe` Right (Just (SSUnknown "paused"))
|
|
J.toJSON (SSUnknown "paused") `shouldBe` J.String "paused"
|
|
let resp = BSPBadgeCredential {credential = Nothing, receipt = Nothing, statement = BadgeStatement {entries = [], previousEntryId = Nothing}, subscription = Just SSRenewing}
|
|
J.toJSON resp `shouldBe` response (Just "renewing")
|
|
roundTrips resp
|
|
|
|
testBadgeSubscriptionJSON :: IO ()
|
|
testBadgeSubscriptionJSON = do
|
|
drg <- C.newRandom
|
|
(k, _) <- atomically $ C.generateKeyPair drg :: IO (C.KeyPair 'C.Ed25519)
|
|
let badgeState subscription =
|
|
BT.BadgeState {badgePurchaseId = 1, purchaseKey = k, badgeType = BTSupporter, shown = BoolDef True, monthsLeft = 0, paidThrough = futureTime, renewsAt = Nothing, willRenew = False, alert = Nothing, issueError = Nothing, nextWakeAt = Nothing, subscription}
|
|
subscriptionField v = case J.toJSON v of
|
|
J.Object o -> KM.lookup "subscription" o
|
|
_ -> Nothing
|
|
subscriptionField (badgeState Nothing) `shouldBe` Nothing
|
|
subscriptionField (badgeState $ Just BadgeSubscription {planMonths = 12, status = Just SSCancelled, transactionRef = Nothing})
|
|
`shouldBe` Just (J.object ["planMonths" J..= (12 :: Int), "status" J..= ("cancelled" :: T.Text)])
|
|
-- not yet observed: the field is left out rather than sent as null
|
|
subscriptionField (badgeState $ Just BadgeSubscription {planMonths = 1, status = Nothing, transactionRef = Nothing})
|
|
`shouldBe` Just (J.object ["planMonths" J..= (1 :: Int)])
|
|
let withRef = BadgeSubscription {planMonths = 1, status = Just SSRenewing, transactionRef = Just "2000000812345680"}
|
|
subscriptionField (badgeState $ Just withRef)
|
|
`shouldBe` Just (J.object ["planMonths" J..= (1 :: Int), "status" J..= ("renewing" :: T.Text), "transactionRef" J..= ("2000000812345680" :: T.Text)])
|
|
J.fromJSON (J.toJSON withRef) `shouldBe` J.Success withRef
|
|
-- as an older core sends it
|
|
J.fromJSON (J.object ["planMonths" J..= (1 :: Int)]) `shouldBe` J.Success BadgeSubscription {planMonths = 1, status = Nothing, transactionRef = Nothing}
|
|
let renewal status = badgeRenewal futureTime $ Just BadgeSubscription {planMonths = 1, status, transactionRef = Nothing}
|
|
renewal (Just SSRenewing) `shouldBe` (Just futureTime, True)
|
|
mapM_ (\s -> renewal s `shouldBe` (Nothing, False)) [Nothing, Just SSCancelled, Just SSBillingRetry, Just SSEnded, Just (SSUnknown "renewing soon")]
|
|
badgeRenewal futureTime Nothing `shouldBe` (Nothing, False)
|
|
boundedSubscriptionState SSBillingRetry `shouldBe` SSBillingRetry
|
|
boundedSubscriptionState (SSUnknown "onHold") `shouldBe` SSUnknown "onHold"
|
|
boundedSubscriptionState (SSUnknown "Visit evil.example.com!\ESC[2J") `shouldBe` SSUnknown "Visitevilexamplecom2J"
|
|
boundedSubscriptionState (SSUnknown (T.replicate 100 "a")) `shouldBe` SSUnknown (T.replicate 32 "a")
|
|
boundedSubscriptionState (SSUnknown "") `shouldBe` SSUnknown "unknown"
|
|
|
|
testSubscriptionAlertDerivation :: IO ()
|
|
testSubscriptionAlertDerivation = do
|
|
drg <- C.newRandom
|
|
(k, pk) <- atomically $ C.generateKeyPair drg :: IO (C.KeyPair 'C.Ed25519)
|
|
mk <- generateMasterKey drg
|
|
let start = at 2026 3 10
|
|
ends = addMonths 1 start
|
|
balance = grant start 1 (newBalance start)
|
|
failedAt = at 2026 3 20
|
|
failure = BadgeIssueError {failedSince = failedAt, lastAttemptAt = failedAt, reason = BIFServiceError {code = BSEUnknownPurchaseKey, retryable = False}}
|
|
early = addUTCTime (-10 * nominalDay) ends
|
|
soon = addUTCTime (-nominalDay) ends
|
|
past = addUTCTime nominalDay ends
|
|
subscription months st = SB.PKSubscription BadgeSubscription {planMonths = months, status = st, transactionRef = Nothing}
|
|
alertOf = alertAfter balance
|
|
alertAfter tip t kind' isShown err =
|
|
let p = SB.UserBadgePurchase {badgePurchaseId = 1, purchaseKey = k, purchasePrivKey = pk, masterKey = mk, badgeType = BTSupporter, shown = isShown, alertAcked = Nothing, alertSnoozeUntil = Nothing, issueError = err, nextWakeAt = Nothing, unrenewedRun = Nothing, purchaseKind = kind'}
|
|
in (\BT.BadgeAlert {kind, date} -> (kind, date)) <$> derivedBadgeAlert t p Nothing tip
|
|
renewing = Just SSRenewing
|
|
cancelled = Just SSCancelled
|
|
billingRetry = Just SSBillingRetry
|
|
mapM_
|
|
(\(t, kind', isShown, err, expected) -> alertOf t kind' isShown err `shouldBe` expected)
|
|
[ -- retired at or after paidThrough, whatever else holds
|
|
(past, subscription 1 renewing, False, Nothing, Just (BASubscriptionEnded, ends)),
|
|
(past, subscription 12 billingRetry, False, Just failure, Just (BASubscriptionEnded, ends)),
|
|
(past, subscription 1 cancelled, False, Nothing, Just (BASubscriptionEnded, ends)),
|
|
-- still shown past paidThrough: waiting for the store to charge
|
|
(past, subscription 1 renewing, True, Nothing, Nothing),
|
|
(past, subscription 12 Nothing, True, Nothing, Nothing),
|
|
(past, subscription 1 cancelled, True, Nothing, Nothing),
|
|
-- billing retry before and after paidThrough, over a renewal failure
|
|
(early, subscription 12 billingRetry, True, Nothing, Just (BAPaymentIssue, ends)),
|
|
(past, subscription 1 billingRetry, True, Just failure, Just (BAPaymentIssue, ends)),
|
|
-- a renewal failure over a cancellation and a reminder
|
|
(soon, subscription 1 cancelled, True, Just failure, Just (BAIssueFailed, failedAt)),
|
|
(soon, subscription 12 renewing, True, Just failure, Just (BAIssueFailed, failedAt)),
|
|
(early, subscription 1 cancelled, True, Nothing, Just (BASubscriptionCancelled, ends)),
|
|
(soon, subscription 12 cancelled, True, Nothing, Just (BASubscriptionCancelled, ends)),
|
|
-- reminded only for a renewing annual plan, and only in the last three days
|
|
(soon, subscription 12 renewing, True, Nothing, Just (BARenewalApproaching, ends)),
|
|
(early, subscription 12 renewing, True, Nothing, Nothing),
|
|
(soon, subscription 1 renewing, True, Nothing, Nothing),
|
|
(soon, subscription 12 Nothing, True, Nothing, Nothing),
|
|
(soon, subscription 12 (Just $ SSUnknown "paused"), True, Nothing, Nothing),
|
|
(soon, subscription 1 (Just SSEnded), True, Nothing, Nothing),
|
|
-- prepaid, as before
|
|
(past, SB.PKPrepaid, True, Nothing, Just (BASupportEnded, ends)),
|
|
(past, SB.PKPrepaid, False, Just failure, Just (BASupportEnded, ends)),
|
|
(soon, SB.PKPrepaid, True, Just failure, Just (BAIssueFailed, failedAt)),
|
|
(soon, SB.PKPrepaid, True, Nothing, Nothing)
|
|
]
|
|
-- the reminder starts exactly three days before paidThrough
|
|
alertOf (addUTCTime (-3 * nominalDay) ends) (subscription 12 renewing) True Nothing `shouldBe` Just (BARenewalApproaching, ends)
|
|
alertOf (addUTCTime (-3 * nominalDay - 1) ends) (subscription 12 renewing) True Nothing `shouldBe` Nothing
|
|
-- a purchase whose payment Restore moved to another key derives none of them
|
|
let movedOut = debitEntry past "" (SDTransferOut k) balance
|
|
mapM_
|
|
(\kind' -> alertAfter movedOut past kind' False (Just failure) `shouldBe` Nothing)
|
|
[subscription 1 renewing, subscription 12 billingRetry, subscription 1 cancelled, SB.PKPrepaid]
|
|
|
|
testErrorResponseJSON :: IO ()
|
|
testErrorResponseJSON = do
|
|
let resp = BSPError {code = BSECodeInvalid, message = Nothing, retryAfter = Nothing}
|
|
J.toJSON resp `shouldBe` J.object ["type" J..= ("error" :: T.Text), "code" J..= ("code_invalid" :: T.Text)]
|
|
J.toJSON BSPError {code = BSERateLimited, message = Just "slow down", retryAfter = Just 30}
|
|
`shouldBe` J.object ["type" J..= ("error" :: T.Text), "code" J..= ("rate_limited" :: T.Text), "message" J..= ("slow down" :: T.Text), "retryAfter" J..= (30 :: Int)]
|
|
|
|
testStatementJSON :: IO ()
|
|
testStatementJSON = do
|
|
let entry =
|
|
StatementEntry
|
|
{ entryId = "e1",
|
|
changeMonths = 3,
|
|
balanceMonths = 3,
|
|
balanceStartTs = futureTime,
|
|
balanceAnchorTs = futureTime,
|
|
balanceBadgeType = BTSupporter,
|
|
wasPausedSince = Nothing,
|
|
createdAt = futureTime,
|
|
entryType = SECredit {credit = SCPayment {invoiceId = Nothing}}
|
|
}
|
|
-- the whole entry: the required fields, and wasPausedSince omitted rather than sent as null
|
|
J.toJSON entry
|
|
`shouldBe` J.object
|
|
[ "entryId" J..= ("e1" :: T.Text),
|
|
"changeMonths" J..= (3 :: Int),
|
|
"balanceMonths" J..= (3 :: Int),
|
|
"balanceStartTs" J..= futureTime,
|
|
"balanceAnchorTs" J..= futureTime,
|
|
"balanceBadgeType" J..= ("supporter" :: T.Text),
|
|
"createdAt" J..= futureTime,
|
|
"entryType" J..= entryType entry
|
|
]
|
|
J.toJSON entry {wasPausedSince = Just pastTime} `shouldNotBe` J.toJSON entry
|
|
J.toJSON (entryType entry) `shouldBe` J.object ["type" J..= ("credit" :: T.Text), "credit" J..= J.object ["type" J..= ("payment" :: T.Text)]]
|
|
J.toJSON SEDebit {debit = SDBadge} `shouldBe` J.object ["type" J..= ("debit" :: T.Text), "debit" J..= J.object ["type" J..= ("badge" :: T.Text)]]
|
|
J.toJSON SEDebit {debit = SDLapse} `shouldBe` J.object ["type" J..= ("debit" :: T.Text), "debit" J..= J.object ["type" J..= ("lapse" :: T.Text)]]
|
|
-- a code grant is its own credit type, not a payment whose invoiceId happens to be absent
|
|
J.toJSON SECredit {credit = SCCode} `shouldBe` J.object ["type" J..= ("credit" :: T.Text), "credit" J..= J.object ["type" J..= ("code" :: T.Text)]]
|
|
J.toJSON SECredit {credit = SCCode} `shouldNotBe` J.toJSON SECredit {credit = SCPayment {invoiceId = Nothing}}
|
|
-- an entry type from a newer service is stored and re-emitted unchanged
|
|
let futureCredit = J.object ["type" J..= ("grant" :: T.Text), "grantedBy" J..= ("operator" :: T.Text)]
|
|
case J.fromJSON futureCredit of
|
|
J.Success c@SCUnknown {tag} -> do
|
|
tag `shouldBe` "grant"
|
|
J.toJSON c `shouldBe` futureCredit
|
|
r -> expectationFailure $ "expected SCUnknown, got " <> show (fmap (const ()) r)
|
|
|
|
-- decoding and re-encoding reproduces the encoding, without Eq on the protocol types
|
|
roundTrips :: (HasCallStack, J.ToJSON a, J.FromJSON a) => a -> IO ()
|
|
roundTrips x = case J.eitherDecode (J.encode x) of
|
|
Right x' -> J.toJSON (x' `asTypeOf` x) `shouldBe` J.toJSON x
|
|
Left e -> expectationFailure e
|