cinema tickets: capacity-enforced buy across events→shop→identity (4 domains)
People can now buy tickets, from the web UI, with capacity enforcement — the heart of the model. - Showing page (events): a 🎟 Tickets section (host/blog--showing-extras) shows capacity/sold + a Buy form per Offering (ticket type + price). host/blog--showing-capacity = the showing's override else its calendar's screen's default (via on-calendar → has-calendar reverse). - host/blog-buy-ticket (events): CAPACITY-CHECKED (sold < capacity), then POSTs to shop /ticket and records showing --sold--> ticket. Sold out → the Buy form is replaced by 'sold out'. - host/blog-ticket (shop): issues a Ticket (is-a ticket, for showing, bought-as offering, owned-by the person's email) + registers the person on the identity peer. - host/blog-person (identity): find-or-create a Person keyed by email (login-optional) → person:<id>. - IDENTITY is a new 4th fed-sx peer (sx_identity, SX_DOMAIN=identity, id.rose-ash.com-ready); shop gets SX_IDENTITY_BASE. serve.sh gains shop 'ticket' type + identity 'person' type seeds. LIVE end-to-end: events.rose-ash.com/<showing> → Buy adult (alice@example.com) → sold 0→1, a ticket on market.rose-ash.com, a person on identity. blog 218/218. Co-Authored-By: Claude Opus 4.8 <noreply@anthropic.com>
This commit is contained in:
@@ -146,6 +146,8 @@ services:
|
|||||||
SX_ACTOR: "shop.rose-ash.com"
|
SX_ACTOR: "shop.rose-ash.com"
|
||||||
SX_SELF_URL: "http://sx_shop:8000"
|
SX_SELF_URL: "http://sx_shop:8000"
|
||||||
SX_FED_SECRET: "rose-ash-fed-2026-shared-a3f9"
|
SX_FED_SECRET: "rose-ash-fed-2026-shared-a3f9"
|
||||||
|
# Cross-domain: where to register the person who bought a ticket (the identity peer).
|
||||||
|
SX_IDENTITY_BASE: "http://sx_identity:8000"
|
||||||
volumes:
|
volumes:
|
||||||
- ./spec:/app/spec:ro
|
- ./spec:/app/spec:ro
|
||||||
- ./lib:/app/lib:ro
|
- ./lib:/app/lib:ro
|
||||||
@@ -159,6 +161,41 @@ services:
|
|||||||
- default
|
- default
|
||||||
restart: unless-stopped
|
restart: unless-stopped
|
||||||
|
|
||||||
|
# The IDENTITY domain — a fed-sx peer running lib/host with SX_DOMAIN=identity (a "person" type).
|
||||||
|
# People are keyed by a contact-id (email), login-optional, created at checkout by the shop.
|
||||||
|
sx_identity:
|
||||||
|
image: registry.rose-ash.com:5000/sx_docs:latest
|
||||||
|
container_name: sx-dev-sx_identity-1
|
||||||
|
entrypoint: ["bash", "/app/lib/host/serve.sh"]
|
||||||
|
working_dir: /app
|
||||||
|
environment:
|
||||||
|
SX_PROJECT_DIR: /app
|
||||||
|
SX_SERVER: /app/bin/sx_server
|
||||||
|
HOST_PORT: "8000"
|
||||||
|
SX_HTTP_HOST: "0.0.0.0"
|
||||||
|
SX_PERSIST_DIR: /data/persist
|
||||||
|
SX_ADMIN_USER: admin
|
||||||
|
SX_ADMIN_PASSWORD: "sx-identity-camper-2026"
|
||||||
|
SX_SESSION_SECRET: "identity-sess-9d2e1f"
|
||||||
|
SX_SERVING_JIT: "1"
|
||||||
|
OCAMLRUNPARAM: "b"
|
||||||
|
SX_DOMAIN: "identity"
|
||||||
|
SX_ACTOR: "id.rose-ash.com"
|
||||||
|
SX_SELF_URL: "http://sx_identity:8000"
|
||||||
|
SX_FED_SECRET: "rose-ash-fed-2026-shared-a3f9"
|
||||||
|
volumes:
|
||||||
|
- ./spec:/app/spec:ro
|
||||||
|
- ./lib:/app/lib:ro
|
||||||
|
- ./next:/app/next:ro
|
||||||
|
- ./web:/app/web:ro
|
||||||
|
- ./shared/static:/app/shared/static:ro
|
||||||
|
- ./hosts/ocaml/_build/default/bin/sx_server.exe:/app/bin/sx_server:ro
|
||||||
|
- /root/sx-identity-persist:/data/persist
|
||||||
|
networks:
|
||||||
|
- externalnet
|
||||||
|
- default
|
||||||
|
restart: unless-stopped
|
||||||
|
|
||||||
networks:
|
networks:
|
||||||
externalnet:
|
externalnet:
|
||||||
external: true
|
external: true
|
||||||
|
|||||||
@@ -154,6 +154,8 @@
|
|||||||
(define host/blog--set-events-base! (fn (b) (set! host/blog--events-base b)))
|
(define host/blog--set-events-base! (fn (b) (set! host/blog--events-base b)))
|
||||||
(define host/blog--shop-base "") ;; the shop peer base URL (serve-set from SX_SHOP_BASE)
|
(define host/blog--shop-base "") ;; the shop peer base URL (serve-set from SX_SHOP_BASE)
|
||||||
(define host/blog--set-shop-base! (fn (b) (set! host/blog--shop-base b)))
|
(define host/blog--set-shop-base! (fn (b) (set! host/blog--shop-base b)))
|
||||||
|
(define host/blog--identity-base "") ;; the identity peer base URL (serve-set from SX_IDENTITY_BASE)
|
||||||
|
(define host/blog--set-identity-base! (fn (b) (set! host/blog--identity-base b)))
|
||||||
;; buy a ticket for an event: a directed cross-domain call to the shop (POST /order/<event>) that
|
;; buy a ticket for an event: a directed cross-domain call to the shop (POST /order/<event>) that
|
||||||
;; creates an order and returns "order:<id>"; we then link event--sold-->order. (Synchronous cross-
|
;; creates an order and returns "order:<id>"; we then link event--sold-->order. (Synchronous cross-
|
||||||
;; domain call, like the RA kernel — not everything is a federated activity; directed reads/writes
|
;; domain call, like the RA kernel — not everything is a federated activity; directed reads/writes
|
||||||
@@ -2397,6 +2399,7 @@
|
|||||||
(unquote type-population)
|
(unquote type-population)
|
||||||
(unquote relations)
|
(unquote relations)
|
||||||
(unquote (host/blog--allocate-form slug))
|
(unquote (host/blog--allocate-form slug))
|
||||||
|
(unquote (host/blog--showing-extras slug))
|
||||||
(p :style "margin-top:2em;font-size:0.9em;opacity:0.8"
|
(p :style "margin-top:2em;font-size:0.9em;opacity:0.8"
|
||||||
(a :href (unquote (str "/" slug "/source")) "view source")
|
(a :href (unquote (str "/" slug "/source")) "view source")
|
||||||
" · "
|
" · "
|
||||||
@@ -3157,6 +3160,82 @@
|
|||||||
(input :name "capacity" :placeholder "cap (opt)" :style "width:6em") " "
|
(input :name "capacity" :placeholder "cap (opt)" :style "width:6em") " "
|
||||||
(button :type "submit" "Book showing"))))))))
|
(button :type "submit" "Book showing"))))))))
|
||||||
|
|
||||||
|
;; a showing's capacity: its own override, else its calendar's screen's default.
|
||||||
|
(define host/blog--showing-capacity
|
||||||
|
(fn (slug)
|
||||||
|
(let ((override (get (host/blog-field-values-of slug) "capacity")))
|
||||||
|
(if (and override (not (= override ""))) (parse-int override 0)
|
||||||
|
(let ((cals (host/blog--out-raw slug "on-calendar")))
|
||||||
|
(if (= (len cals) 0) 0
|
||||||
|
(let ((screens (host/blog-in (first cals) "has-calendar")))
|
||||||
|
(if (= (len screens) 0) 0
|
||||||
|
(parse-int (or (get (host/blog-field-values-of (first screens)) "capacity") "0") 0)))))))))
|
||||||
|
;; the TICKETS section shown on a showing's page: capacity/sold + a Buy form per Offering.
|
||||||
|
(define host/blog--showing-extras
|
||||||
|
(fn (slug)
|
||||||
|
(if (not (contains? (host/blog--out-raw slug "is-a") "showing")) ""
|
||||||
|
(let ((cap (host/blog--showing-capacity slug)) (sold (len (host/blog--out-raw slug "sold"))))
|
||||||
|
(quasiquote
|
||||||
|
(div :style "margin:1.5em 0;padding:0.8em 1em;border:2px solid #b9a;border-radius:6px;background:#fbf7fb"
|
||||||
|
(h3 :style "margin:0 0 0.2em" "🎟 Tickets")
|
||||||
|
(p :style "font-size:0.9em;color:#555"
|
||||||
|
(unquote (str "Capacity " (str cap) " · sold " (str sold) (if (>= sold cap) " · SOLD OUT" ""))))
|
||||||
|
(unquote
|
||||||
|
(cons (quote div)
|
||||||
|
(map (fn (off)
|
||||||
|
(let ((tt (host/blog--out-raw off "of-type")) (price (get (host/blog-field-values-of off) "price")))
|
||||||
|
(quasiquote (div :style "margin:0.35em 0"
|
||||||
|
(b (unquote (if (> (len tt) 0) (first tt) off))) (unquote (str " — £" (or price "?") " "))
|
||||||
|
(unquote (if (>= sold cap) (quote (span :style "color:#999" "sold out"))
|
||||||
|
(quasiquote (form :method "post"
|
||||||
|
:action (unquote (str "/buy-ticket?showing=" slug "&offering=" off)) :style "display:inline"
|
||||||
|
(input :name "email" :placeholder "your email" :style "width:12em") " "
|
||||||
|
(button :type "submit" "Buy")))))))))
|
||||||
|
(host/blog--out-raw slug "offers"))))))))))
|
||||||
|
|
||||||
|
;; events: buy a ticket for a showing/offering — CAPACITY-CHECKED, then a cross-domain order on shop.
|
||||||
|
(define host/blog-buy-ticket
|
||||||
|
(fn (req)
|
||||||
|
(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 ""))
|
||||||
|
(< (len (host/blog--out-raw showing "sold")) (host/blog--showing-capacity showing))
|
||||||
|
(not (= host/blog--shop-base "")))
|
||||||
|
(let ((body (get (http-request "POST"
|
||||||
|
(str host/blog--shop-base "/ticket?showing=" showing "&offering=" offering "&email=" email)
|
||||||
|
{} "") "body")))
|
||||||
|
(when (starts-with? body "ticket:")
|
||||||
|
(host/blog-relate! showing (substr body 7 (- (len body) 7)) "sold"))))
|
||||||
|
(dream-redirect (str "/" showing "/"))))))
|
||||||
|
;; shop: issue a ticket (is-a ticket, for showing, bought-as offering, owned-by person) → "ticket:<id>".
|
||||||
|
(define host/blog-ticket
|
||||||
|
(fn (req)
|
||||||
|
(let ((showing (or (dream-query-param req "showing") "")) (offering (or (dream-query-param req "offering") ""))
|
||||||
|
(email (or (dream-query-param req "email") "")))
|
||||||
|
(let ((tid (str "ticket-" showing "-" (str (len (host/blog-slugs))))))
|
||||||
|
(begin
|
||||||
|
(host/blog-put! tid (str "Ticket: " showing) (str "(article (h1 \"Ticket\") (p \"" showing " · " offering "\"))") "published")
|
||||||
|
(host/blog-relate! tid "ticket" "is-a")
|
||||||
|
(host/blog-relate! tid showing "for")
|
||||||
|
(host/blog-relate! tid offering "bought-as")
|
||||||
|
(host/blog-relate! tid email "owned-by")
|
||||||
|
(host/blog--set-field-values! tid {"email" email})
|
||||||
|
(when (not (= host/blog--identity-base ""))
|
||||||
|
(http-request "POST" (str host/blog--identity-base "/person?email=" email) {} ""))
|
||||||
|
(dream-response 200 {:content-type "text/plain; charset=utf-8"} (str "ticket:" tid)))))))
|
||||||
|
;; identity: find-or-create a Person keyed by a contact-id (email), login-optional → "person:<id>".
|
||||||
|
(define host/blog-person
|
||||||
|
(fn (req)
|
||||||
|
(let ((email (or (dream-query-param req "email") "")))
|
||||||
|
(let ((pid (str "person-" (host/blog-slugify email))))
|
||||||
|
(begin
|
||||||
|
(when (not (host/blog-exists? pid))
|
||||||
|
(begin
|
||||||
|
(host/blog-put! pid email (str "(article (h1 \"" email "\"))") "published")
|
||||||
|
(host/blog-relate! pid "person" "is-a")
|
||||||
|
(host/blog--set-field-values! pid {"email" email})))
|
||||||
|
(dream-response 200 {:content-type "text/plain; charset=utf-8"} (str "person:" pid)))))))
|
||||||
;; ── /orders — the shop domain view: ticket orders placed for events (federated from events) ──
|
;; ── /orders — the shop domain view: ticket orders placed for events (federated from events) ──
|
||||||
(define host/blog-orders
|
(define host/blog-orders
|
||||||
(fn (req)
|
(fn (req)
|
||||||
@@ -3257,6 +3336,9 @@
|
|||||||
(dream-get "/orders" host/blog-orders)
|
(dream-get "/orders" host/blog-orders)
|
||||||
(dream-post "/new-film" host/blog-new-film)
|
(dream-post "/new-film" host/blog-new-film)
|
||||||
(dream-post "/new-showing" host/blog-new-showing)
|
(dream-post "/new-showing" host/blog-new-showing)
|
||||||
|
(dream-post "/buy-ticket" host/blog-buy-ticket)
|
||||||
|
(dream-post "/ticket" host/blog-ticket)
|
||||||
|
(dream-post "/person" host/blog-person)
|
||||||
(dream-post "/new-event" host/blog-new-event)
|
(dream-post "/new-event" host/blog-new-event)
|
||||||
(dream-post "/buy" host/blog-buy)
|
(dream-post "/buy" host/blog-buy)
|
||||||
(dream-post "/order" host/blog-order)
|
(dream-post "/order" host/blog-order)
|
||||||
|
|||||||
@@ -255,10 +255,24 @@ EPOCH=1
|
|||||||
echo "(eval \"(host/blog-seed-cinema!)\")"
|
echo "(eval \"(host/blog-seed-cinema!)\")"
|
||||||
EPOCH=$((EPOCH+1))
|
EPOCH=$((EPOCH+1))
|
||||||
elif [ "${SX_DOMAIN:-blog}" = "shop" ]; then
|
elif [ "${SX_DOMAIN:-blog}" = "shop" ]; then
|
||||||
# The SHOP domain: an "order" type. POST /order?event= creates an order (is-a order) for an event.
|
# The SHOP domain: "order" + "ticket" types. POST /order creates an order; POST /ticket issues a
|
||||||
|
# cinema ticket (for a showing, bought-as an offering, owned-by a person) + registers the person
|
||||||
|
# on the identity peer. SX_IDENTITY_BASE points at that peer.
|
||||||
echo "(epoch $EPOCH)"
|
echo "(epoch $EPOCH)"
|
||||||
echo "(eval \"(host/blog-seed! \\\"order\\\" \\\"Order\\\" \\\"(article (h1 \\\\\\\"Order\\\\\\\"))\\\" \\\"published\\\")\")"
|
echo "(eval \"(host/blog-seed! \\\"order\\\" \\\"Order\\\" \\\"(article (h1 \\\\\\\"Order\\\\\\\"))\\\" \\\"published\\\")\")"
|
||||||
EPOCH=$((EPOCH+1))
|
EPOCH=$((EPOCH+1))
|
||||||
|
echo "(epoch $EPOCH)"
|
||||||
|
echo "(eval \"(host/blog-seed! \\\"ticket\\\" \\\"Ticket\\\" \\\"(article (h1 \\\\\\\"Ticket\\\\\\\"))\\\" \\\"published\\\")\")"
|
||||||
|
EPOCH=$((EPOCH+1))
|
||||||
|
echo "(epoch $EPOCH)"
|
||||||
|
echo "(eval \"(host/blog--set-identity-base! \\\"${SX_IDENTITY_BASE:-}\\\")\")"
|
||||||
|
EPOCH=$((EPOCH+1))
|
||||||
|
elif [ "${SX_DOMAIN:-blog}" = "identity" ]; then
|
||||||
|
# The IDENTITY domain: a "person" type. POST /person?email= find-or-creates a login-optional
|
||||||
|
# Person keyed by a contact-id (email). The shop calls this when a ticket is bought.
|
||||||
|
echo "(epoch $EPOCH)"
|
||||||
|
echo "(eval \"(host/blog-seed! \\\"person\\\" \\\"Person\\\" \\\"(article (h1 \\\\\\\"Person\\\\\\\"))\\\" \\\"published\\\")\")"
|
||||||
|
EPOCH=$((EPOCH+1))
|
||||||
else
|
else
|
||||||
# The BLOG domain: article create→publish (sync) + update→blog-digest (durable kernel) + a
|
# The BLOG domain: article create→publish (sync) + update→blog-digest (durable kernel) + a
|
||||||
# "category" field for the edit form; and point at the events peer for cross-domain allocate.
|
# "category" field for the edit form; and point at the events peer for cross-domain allocate.
|
||||||
|
|||||||
Reference in New Issue
Block a user