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>
2026-07-03 08:02:38 +00:00
parent 7aaf2c9b17
commit 78d8fd54c5
3 changed files with 134 additions and 1 deletions
--- a/docker-compose.dev-sx-host.yml
+++ b/docker-compose.dev-sx-host.yml
@@ -146,6 +146,8 @@ services:
      SX_ACTOR: "shop.rose-ash.com"
      SX_SELF_URL: "http://sx_shop:8000"
      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:
      - ./spec:/app/spec:ro
      - ./lib:/app/lib:ro
@@ -159,6 +161,41 @@ services:
      - default
    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:
  externalnet:
    external: true
--- a/lib/host/blog.sx
+++ b/lib/host/blog.sx
@@ -154,6 +154,8 @@
 (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--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
 ;; 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
@@ -2397,6 +2399,7 @@
                      (unquote type-population)
                      (unquote relations)
                      (unquote (host/blog--allocate-form slug))
+                      (unquote (host/blog--showing-extras slug))
                      (p :style "margin-top:2em;font-size:0.9em;opacity:0.8"
                        (a :href (unquote (str "/" slug "/source")) "view source")
                        " · "
@@ -3157,6 +3160,82 @@
              (input :name "capacity" :placeholder "cap (opt)" :style "width:6em") " "
              (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) ──
 (define host/blog-orders
  (fn (req)
@@ -3257,6 +3336,9 @@
    (dream-get "/orders" host/blog-orders)
    (dream-post "/new-film" host/blog-new-film)
    (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 "/buy" host/blog-buy)
    (dream-post "/order" host/blog-order)
--- a/lib/host/serve.sh
+++ b/lib/host/serve.sh
@@ -255,10 +255,24 @@ EPOCH=1
    echo "(eval \"(host/blog-seed-cinema!)\")"
    EPOCH=$((EPOCH+1))
  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 "(eval \"(host/blog-seed! \\\"order\\\" \\\"Order\\\" \\\"(article (h1 \\\\\\\"Order\\\\\\\"))\\\" \\\"published\\\")\")"
    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
    # 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.