diff --git a/lib/host/blog.sx b/lib/host/blog.sx index 81987ed3..a4594aeb 100644 --- a/lib/host/blog.sx +++ b/lib/host/blog.sx @@ -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:" (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 diff --git a/lib/host/tests/blog.sx b/lib/host/tests/blog.sx index 41fc8ce4..b0305f64 100644 --- a/lib/host/tests/blog.sx +++ b/lib/host/tests/blog.sx @@ -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 ()