coop/rose-ash
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

H5: two-phase buy — hold → guarded mint → confirm/release (TDD, seat-leak fix)

Browse Source 
Failing tests first (red: a failed mint left the seat consumed — the cross-domain leak; a RAISING
mint escaped the handler entirely, proving no guard). host/blog--mint-ticket is now an injectable
seam (default: signed HTTP to the shop). buy-ticket: ev/hold! reserves (capacity-counted, atomic) →
mint runs inside (guard (e (true "")) ...) → 'ticket:' ⇒ ev/confirm! + sold edges + a 'sell'
activity (H4's missing emission); anything else ⇒ ev/release! frees the seat. Held seats count
toward capacity, so a pending mint can't be oversold either.

blog suite 247/247 (+3).

Co-Authored-By: Claude Opus 4.8 <noreply@anthropic.com>
This commit is contained in:
giles
2026-07-03 10:43:26 +00:00
parent e5fd4f8e0b
commit edbb2d4a37
2 changed files with 60 additions and 7 deletions
Download Patch File Download Diff File Expand all files Collapse all files

26
lib/host/blog.sx
View File

@@ -3261,6 +3261,13 @@
(host/blog--out-raw slug "offers"))))
(unquote (host/blog--offering-editor slug))))))))
;; the ticket MINT seam: ask the shop to issue a ticket → "ticket:<id>" (signed internal call).
;; A settable fn so tests (and other shop backends) can inject; the default is the HTTP shop.
(define host/blog--mint-ticket
(fn (showing offering email)
(let ((target (str "/ticket?showing=" showing "&offering=" offering "&email=" email)))
(get (http-request "POST" (str host/blog--shop-base target)
(host/blog--int-headers target) "") "body"))))
;; events: buy a ticket for a showing/offering — CAPACITY-CHECKED, then a cross-domain order on shop.
(define host/blog-buy-ticket
(fn (req)
@@ -3274,17 +3281,22 @@
;; replaces the former read-check-write race. A unique actor per seat (email + current
;; count) lets one person hold several seats while collapsing double-clicks; :full ⇒ no
;; oversell even under concurrent buys for the last seat.
;; H5 TWO-PHASE: hold the seat (provisional, capacity-counted) → mint the ticket (guarded —
;; a shop failure/raise must not leak the seat) → confirm on success / RELEASE on failure.
(let ((actor (str email "#" (str (len (ev/roster host/blog-store showing))))))
(let ((bk (ev/book! host/blog-store showing (host/blog--showing-capacity showing) actor)))
(when (= (get bk :status) :booked)
(let ((body (let ((target (str "/ticket?showing=" showing "&offering=" offering "&email=" email)))
(get (http-request "POST" (str host/blog--shop-base target)
(host/blog--int-headers target) "") "body"))))
(when (starts-with? body "ticket:")
(let ((hold (ev/hold! host/blog-store showing (host/blog--showing-capacity showing) actor)))
(when (= (get hold :status) :held)
(let ((body (guard (e (true "")) (host/blog--mint-ticket showing offering email))))
(if (starts-with? body "ticket:")
(let ((tid (substr body 7 (- (len body) 7))))
(begin
(ev/confirm! host/blog-store showing actor)
(host/blog-relate! showing tid "sold")
(host/blog-relate! offering tid "sold")))))))))
(host/blog-relate! offering tid "sold")
(host/blog--emit! {:verb "sell" :actor host/blog--actor :object showing
:object-type "showing" :target offering :delta tid
:id (str "sell:" tid)})))
(ev/release! host/blog-store showing actor)))))))
(dream-redirect (str "/" showing "/"))))))
;; the showing an offering belongs to (showing --offers--> offering).
(define host/blog--offering-showing

41
lib/host/tests/blog.sx
View File

@@ -1463,6 +1463,47 @@
(some (fn (e) (contains? (str e) "secret@x.com")) host/blog--activity-log)))))
(list true false))
;; ── HARDENING H5: hold→confirm→release — a failed mint must NOT consume the seat ──────────
;; The buy is two-phase: ev/hold! reserves; the mint (injectable seam host/blog--mint-ticket) runs
;; guarded; success → ev/confirm! + sold edges + a sell activity; failure/raise → ev/release!.
(host/blog-use-store! (persist/open))
(host/blog-put! "h5-show" "H5 Showing" "(article (h1 \"s\"))" "published")
(host/blog-relate! "h5-show" "showing" "is-a")
(host/blog--set-field-values! "h5-show" {"capacity" "2"})
(host/blog-put! "h5-show--adult" "adult @ h5" "(article (h1 \"o\"))" "published")
(host/blog-relate! "h5-show" "h5-show--adult" "offers")
(define host-bl-h5-shop-was host/blog--shop-base)
(define host-bl-h5-mint-was host/blog--mint-ticket)
(set! host/blog--shop-base "http://mock-shop")
(define host-bl-h5-buy
(fn (email)
(host-bl-h2-app (dream-request "POST" "/buy-ticket?showing=h5-show&offering=h5-show--adult"
{:content-type "application/x-www-form-urlencoded"} (str "email=" email)))))
(host-bl-test "H5: FAILED mint releases the seat (no leak)"
(begin
(set! host/blog--mint-ticket (fn (s o e) "")) ;; shop says no
(host-bl-h5-buy "leak@x.com")
(len (ev/roster host/blog-store "h5-show")))
0)
(host-bl-test "H5: RAISING mint also releases (guarded)"
(begin
(set! host/blog--mint-ticket (fn (s o e) (raise "shop down")))
(host-bl-h5-buy "crash@x.com")
(len (ev/roster host/blog-store "h5-show")))
0)
(host-bl-test "H5: successful mint confirms seat + sold edge + sell activity"
(begin
(set! host/blog--mint-ticket (fn (s o e) "ticket:h5-t1"))
(set! host/blog--activity-log (list))
(host-bl-h5-buy "ok@x.com")
(list (len (ev/roster host/blog-store "h5-show"))
(contains? (host/blog--out-raw "h5-show" "sold") "h5-t1")
(contains? (map (fn (e) (get e "verb")) host/blog--activity-log) "sell")))
(list 1 true true))
(set! host/blog--shop-base host-bl-h5-shop-was)
(set! host/blog--mint-ticket host-bl-h5-mint-was)
(define
host-bl-tests-run!
(fn ()