R1: per-offering cap is atomic stock — the store-shape of the seat race (TDD)
Failing tests first (3 red: no offering pool stream; the sold-EDGE count was the only gate, so a buy went through after the projection was wiped; the pool-refused buy leaked a showing seat). A ticket now acquires from TWO atomic pools: the showing seat (physical capacity) AND the offering allocation (stream 'offering:<off>', cap = its :cap field, ∞ if unset — so uncapped offerings are unaffected). Both ev/hold! → guarded mint → confirm both / release both; offering-full releases the seat. This is the co-op's product stock: in the store shape the offering IS the product and its cap is the only pool, now genuinely atomic. Advisory offering-available? stays for button-hiding only. blog suite 259/259 (+3). Co-Authored-By: Claude Opus 4.8 <noreply@anthropic.com>
This commit is contained in:
@@ -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:<off>", 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
|
||||
|
||||
@@ -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:<off>"
|
||||
(> (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 ()
|
||||
|
||||
Reference in New Issue
Block a user