diff --git a/lib/host/blog.sx b/lib/host/blog.sx index dd3dea9c..7fff5cea 100644 --- a/lib/host/blog.sx +++ b/lib/host/blog.sx @@ -3310,29 +3310,35 @@ (let ((showing (dream-query-param req "showing")) (offering (dream-query-param req "offering")) (email (or (host/field req "email") ""))) (begin - (when (and showing offering (not (= email "")) - (host/blog--offering-available? offering) - (not (= host/blog--shop-base ""))) - ;; lib/events ATOMIC capacity-safe booking (persist append-expect, retry-on-conflict) — - ;; 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 ((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--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))))))) + (when (and showing offering (not (= email "")) (not (= host/blog--shop-base ""))) + ;; TWO ATOMIC POOLS, both capacity-safe (append-expect, no oversell under concurrency): + ;; the SHOWING seat (physical capacity) AND the OFFERING allocation (per-type / store stock). + ;; A ticket needs BOTH; either full ⇒ refuse. R1 makes the offering pool a real gate (was an + ;; advisory sold-edge count). H5 two-phase: hold both → guarded mint → confirm both / release + ;; both. Offering "off-pool" = the stream "offering:", cap = its :cap field (∞ if unset). + (let ((actor (str email "#" (str (len (ev/roster host/blog-store showing))))) + (off-pool (str "offering:" offering)) + (off-cap (let ((c (get (host/blog-field-values-of offering) "cap"))) + (if (and c (not (= c ""))) (parse-int c 0) 1000000000)))) + (let ((seat (ev/hold! host/blog-store showing (host/blog--showing-capacity showing) actor))) + (when (= (get seat :status) :held) + (let ((alloc (ev/hold! host/blog-store off-pool off-cap actor))) + (if (not (= (get alloc :status) :held)) + (ev/release! host/blog-store showing actor) ;; offering full → free the seat + (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) + (ev/confirm! host/blog-store off-pool actor) + (host/blog-relate! showing 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)}))) + (begin + (ev/release! host/blog-store showing actor) + (ev/release! host/blog-store off-pool 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 3c9e8bd1..1fb7dc0c 100644 --- a/lib/host/tests/blog.sx +++ b/lib/host/tests/blog.sx @@ -1560,6 +1560,37 @@ (host/blog--out-raw "h7a" "h7k")) (list "h7b")) +;; ── R1: per-offering cap is ATOMIC stock (the store-shape of the seat race) ──────────────── +;; A ticket consumes a seat (showing pool) AND an allocation (offering pool). The offering pool — +;; not the sold-edge count — is the gate; a pool-full buy must not leak a showing seat. +(host/blog-use-store! (persist/open)) +(host/blog-put! "r1-show" "R1" "(article (h1 \"s\"))" "published") +(host/blog-relate! "r1-show" "showing" "is-a") +(host/blog--set-field-values! "r1-show" {"capacity" "100"}) +(host/blog-put! "r1-show--vip" "vip" "(article (h1 \"o\"))" "published") +(host/blog-relate! "r1-show" "r1-show--vip" "offers") +(host/blog--set-field-values! "r1-show--vip" {"cap" "1"}) +(set! host/blog--shop-base "http://mock-r1") +(set! host/blog--mint-ticket (fn (s o e) (str "ticket:t-" e))) +(define host-bl-r1-buy + (fn (email) + (host-bl-h2-app (dream-request "POST" "/buy-ticket?showing=r1-show&offering=r1-show--vip" + {:content-type "application/x-www-form-urlencoded"} (str "email=" email))))) + +(host-bl-r1-buy "r1a@x.com") +(host-bl-test "R1: a capped-offering buy writes the atomic pool stream offering:" + (> (len (ev/roster host/blog-store "offering:r1-show--vip")) 0) true) +;; wipe r1a's sold edge so the ADVISORY edge-count says "available" (0) — the pool must still gate. +(host/blog-unrelate! "r1-show--vip" (first (host/blog--out-raw "r1-show--vip" "sold")) "sold") +(define host-bl-r1-seatbefore (len (ev/roster host/blog-store "r1-show"))) +(host-bl-r1-buy "r1b@x.com") +(host-bl-test "R1: the POOL is the gate — refused though the sold-edge projection is empty" + (contains? (host/blog--out-raw "r1-show--vip" "sold") "t-r1b@x.com") false) +(host-bl-test "R1: the pool-refused buy left NO showing seat (no leak)" + (len (ev/roster host/blog-store "r1-show")) host-bl-r1-seatbefore) +(set! host/blog--mint-ticket host-bl-h5-mint-was) +(set! host/blog--shop-base host-bl-h5-shop-was) + (define host-bl-tests-run! (fn ()