giles
05d5c46730
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 42s
ticket.sx: checkout-request (events->commerce) + payment-result (commerce->events) wire shapes — commerce imports the contract. ev/request- ticket! holds a seat + emits a checkout request; ev/settle-payment! confirms on :paid, releases on failure/expiry. Idempotent; late paid for a vanished hold -> :paid-but-no-hold (refund signal). 175/175 green. Co-Authored-By: Claude Opus 4.8 (1M context) <noreply@anthropic.com>
253 lines
7.2 KiB
Plaintext
253 lines
7.2 KiB
Plaintext
;; lib/events/tests/ticket.sx — paid-ticket contract + settlement orchestration.
|
|
|
|
(define ev-tk-pass 0)
|
|
(define ev-tk-fail 0)
|
|
(define ev-tk-failures (list))
|
|
|
|
(define
|
|
ev-tk-check!
|
|
(fn
|
|
(name got expected)
|
|
(if
|
|
(= got expected)
|
|
(set! ev-tk-pass (+ ev-tk-pass 1))
|
|
(do
|
|
(set! ev-tk-fail (+ ev-tk-fail 1))
|
|
(append!
|
|
ev-tk-failures
|
|
(str name "\n expected: " expected "\n got: " got))))))
|
|
|
|
(define
|
|
ev-tk-run-all!
|
|
(fn
|
|
()
|
|
(do
|
|
(let
|
|
((req (ev/checkout-request "occ1" (quote nia) 1500 "GBP" "ref-1")))
|
|
(do
|
|
(ev-tk-check!
|
|
"checkout-request is tagged"
|
|
(ev/checkout-request? req)
|
|
true)
|
|
(ev-tk-check!
|
|
"payment-result is not a checkout-request"
|
|
(ev/checkout-request? (ev/payment-paid "o" (quote a) "r"))
|
|
false)
|
|
(ev-tk-check!
|
|
"request occ-key accessor"
|
|
(ev/req-occ-key req)
|
|
"occ1")
|
|
(ev-tk-check!
|
|
"request actor accessor"
|
|
(ev/req-actor req)
|
|
(quote nia))
|
|
(ev-tk-check!
|
|
"request amount accessor"
|
|
(ev/req-amount req)
|
|
1500)
|
|
(ev-tk-check!
|
|
"request currency accessor"
|
|
(ev/req-currency req)
|
|
"GBP")
|
|
(ev-tk-check! "request ref accessor" (ev/req-ref req) "ref-1")))
|
|
(let
|
|
((res (ev/payment-paid "occ1" (quote nia) "ref-1")))
|
|
(do
|
|
(ev-tk-check!
|
|
"payment-result is tagged"
|
|
(ev/payment-result? res)
|
|
true)
|
|
(ev-tk-check! "result status accessor" (ev/result-status res) :paid)
|
|
(ev-tk-check!
|
|
"failed constructor carries status"
|
|
(ev/result-status (ev/payment-failed "o" (quote a) "r"))
|
|
:failed)
|
|
(ev-tk-check!
|
|
"expired constructor carries status"
|
|
(ev/result-status (ev/payment-expired "o" (quote a) "r"))
|
|
:expired)))
|
|
(let
|
|
((b (persist/open)))
|
|
(do
|
|
(let
|
|
((r (ev/request-ticket! b "show" 1 (quote a) 2000 "GBP" "ref-a")))
|
|
(do
|
|
(ev-tk-check!
|
|
"request-ticket awaiting-payment"
|
|
(get r :status)
|
|
:awaiting-payment)
|
|
(ev-tk-check!
|
|
"request-ticket returns a checkout-request"
|
|
(ev/checkout-request? (get r :request))
|
|
true)
|
|
(ev-tk-check!
|
|
"checkout-request carries the amount"
|
|
(ev/req-amount (get r :request))
|
|
2000)))
|
|
(ev-tk-check!
|
|
"held seat reserves capacity"
|
|
(ev/seats-left b "show" 1)
|
|
0)
|
|
(ev-tk-check!
|
|
"second buyer is full while payment pends"
|
|
(get
|
|
(ev/request-ticket!
|
|
b
|
|
"show"
|
|
1
|
|
(quote c)
|
|
2000
|
|
"GBP"
|
|
"ref-c")
|
|
:status)
|
|
:full)
|
|
(ev-tk-check!
|
|
"held seat state pending"
|
|
(ev/seat-state b "show" (quote a))
|
|
:held)))
|
|
(let
|
|
((b (persist/open)))
|
|
(do
|
|
(ev/request-ticket!
|
|
b
|
|
"gig"
|
|
2
|
|
(quote a)
|
|
2000
|
|
"GBP"
|
|
"ref-a")
|
|
(let
|
|
((s (ev/settle-payment! b (ev/payment-paid "gig" (quote a) "ref-a"))))
|
|
(ev-tk-check! "settle paid confirms" (get s :status) :confirmed))
|
|
(ev-tk-check!
|
|
"confirmed seat state"
|
|
(ev/seat-state b "gig" (quote a))
|
|
:confirmed)
|
|
(ev-tk-check!
|
|
"redelivered paid is still confirmed (idempotent)"
|
|
(get
|
|
(ev/settle-payment!
|
|
b
|
|
(ev/payment-paid "gig" (quote a) "ref-a"))
|
|
:status)
|
|
:confirmed)
|
|
(ev-tk-check!
|
|
"still exactly one seat taken"
|
|
(ev-booking-count b "gig")
|
|
1)))
|
|
(let
|
|
((b (persist/open)))
|
|
(do
|
|
(ev/request-ticket!
|
|
b
|
|
"fail"
|
|
1
|
|
(quote a)
|
|
2000
|
|
"GBP"
|
|
"ref-a")
|
|
(ev-tk-check!
|
|
"seat held before failure"
|
|
(ev/seats-left b "fail" 1)
|
|
0)
|
|
(let
|
|
((s (ev/settle-payment! b (ev/payment-failed "fail" (quote a) "ref-a"))))
|
|
(ev-tk-check! "settle failed releases" (get s :status) :released))
|
|
(ev-tk-check!
|
|
"released seat frees capacity"
|
|
(ev/seats-left b "fail" 1)
|
|
1)
|
|
(ev-tk-check!
|
|
"redelivered failure is a noop"
|
|
(get
|
|
(ev/settle-payment!
|
|
b
|
|
(ev/payment-failed "fail" (quote a) "ref-a"))
|
|
:status)
|
|
:noop)
|
|
(ev-tk-check!
|
|
"freed seat available to next buyer"
|
|
(get
|
|
(ev/request-ticket!
|
|
b
|
|
"fail"
|
|
1
|
|
(quote c)
|
|
2000
|
|
"GBP"
|
|
"ref-c")
|
|
:status)
|
|
:awaiting-payment)
|
|
(ev/request-ticket!
|
|
b
|
|
"exp"
|
|
1
|
|
(quote a)
|
|
2000
|
|
"GBP"
|
|
"ref-a")
|
|
(ev-tk-check!
|
|
"settle expired releases"
|
|
(get
|
|
(ev/settle-payment!
|
|
b
|
|
(ev/payment-expired "exp" (quote a) "ref-a"))
|
|
:status)
|
|
:released)))
|
|
(let
|
|
((b (persist/open)))
|
|
(do
|
|
(ev/request-ticket!
|
|
b
|
|
"race"
|
|
1
|
|
(quote a)
|
|
2000
|
|
"GBP"
|
|
"ref-a")
|
|
(ev/settle-payment!
|
|
b
|
|
(ev/payment-expired "race" (quote a) "ref-a"))
|
|
(ev-tk-check!
|
|
"late paid for a vanished hold needs a refund"
|
|
(get
|
|
(ev/settle-payment!
|
|
b
|
|
(ev/payment-paid "race" (quote a) "ref-a"))
|
|
:status)
|
|
:paid-but-no-hold)
|
|
(ev-tk-check!
|
|
"no phantom seat created"
|
|
(ev-booking-count b "race")
|
|
0)))
|
|
(let
|
|
((b (persist/open)))
|
|
(do
|
|
(let
|
|
((start (ev/request-ticket! b "e2e" 3 (quote nia) 2500 "GBP" "ref-nia")))
|
|
(ev/settle-payment!
|
|
b
|
|
(ev/payment-paid
|
|
(ev/req-occ-key (get start :request))
|
|
(ev/req-actor (get start :request))
|
|
(ev/req-ref (get start :request)))))
|
|
(ev-tk-check!
|
|
"e2e roster holds the buyer"
|
|
(ev/roster b "e2e")
|
|
(list (quote nia)))
|
|
(ev-tk-check!
|
|
"e2e seat confirmed"
|
|
(ev/seat-state b "e2e" (quote nia))
|
|
:confirmed))))))
|
|
|
|
(define
|
|
ev-ticket-tests-run!
|
|
(fn
|
|
()
|
|
(do
|
|
(set! ev-tk-pass 0)
|
|
(set! ev-tk-fail 0)
|
|
(set! ev-tk-failures (list))
|
|
(ev-tk-run-all!)
|
|
{:failures ev-tk-failures :total (+ ev-tk-pass ev-tk-fail) :passed ev-tk-pass :failed ev-tk-fail})))
|