diff --git a/docker-compose.dev-sx-host.yml b/docker-compose.dev-sx-host.yml index f5fee2cd..691edbaa 100644 --- 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 diff --git a/lib/host/blog.sx b/lib/host/blog.sx index 338a1e3a..d187b9cb 100644 --- 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/) that ;; creates an order and returns "order:"; 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:". +(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:". +(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) diff --git a/lib/host/serve.sh b/lib/host/serve.sh index edee57ab..dc86e1f8 100755 --- 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.