coop/rose-ash
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

H4: P2 restored — cinema/poll mutations emit activities (TDD)

Browse Source 
Failing tests first (6 red: no cinema/poll handler emitted anything — films/showings/votes were
invisible to federation and other peers' behaviors). Now: new-film→create(film),
new-showing→schedule(showing), offering-add→offer, offering-update→update (id carries new values so
distinct changes federate, replays dedup), offering-remove→retract, add-poll→create(poll),
new-event→schedule(event), vote→vote(poll) — voter kept OFF the wire (seat number makes the id
unique; pinned by test). All through host/blog--emit! (engine + durable activity log + outbox).
buy-ticket's sell emission lands with H5's injectable mint.

blog suite 244/244 (+6).

Co-Authored-By: Claude Opus 4.8 <noreply@anthropic.com>
This commit is contained in:
giles
2026-07-03 10:16:40 +00:00
parent f1238c1a38
commit e5fd4f8e0b
2 changed files with 85 additions and 8 deletions
Download Patch File Download Diff File Expand all files Collapse all files

42
lib/host/blog.sx
View File

@@ -3045,7 +3045,9 @@
(host/blog-put! slug title (str "(article (h1 \"" title "\") (p \"" date "\"))") "published")
(host/blog-relate! slug "event" "is-a")
(host/blog-relate! "main" slug "scheduled")
(when (not (= post "")) (host/blog-relate! slug post "features")))))
(when (not (= post "")) (host/blog-relate! slug post "features"))
(host/blog--emit! {:verb "schedule" :actor host/blog--actor :object slug :object-type "event"
:slug slug :target "main" :delta date :id (str "schedule:" slug)}))))
(dream-redirect "/calendars")))))
;; events: buy a ticket for an event — a cross-domain order on the shop, then link event--sold-->order.
(define host/blog-buy
@@ -3130,7 +3132,9 @@
(begin
(host/blog-seed! slug title (str "(article (h1 \"" title "\"))") "published")
(host/blog-relate! slug "film" "is-a")
(for-each (fn (tt) (host/blog-relate! slug tt "has-ticket-type")) (list "adult" "u18")))))
(for-each (fn (tt) (host/blog-relate! slug tt "has-ticket-type")) (list "adult" "u18"))
(host/blog--emit! {:verb "create" :actor host/blog--actor :object slug :object-type "film"
:slug slug :delta title :id (str "create:" slug)}))))
(dream-redirect "/cinema")))))
;; book a showing: a Film onto a Calendar at a time; snapshot the film's ticket types as Offerings.
(define host/blog-new-showing
@@ -3155,7 +3159,10 @@
(host/blog-relate! slug off "offers")
(host/blog-relate! off tt "of-type")
(host/blog--set-field-values! off {"price" "10"}))))
(host/blog--out-raw film "has-ticket-type")))))
(host/blog--out-raw film "has-ticket-type"))
(host/blog--emit! {:verb "schedule" :actor host/blog--actor :object slug :object-type "showing"
:slug slug :target calendar :delta (str film " @ " time)
:id (str "schedule:" slug)}))))
(dream-redirect "/cinema")))))
;; ── /cinema — the events domain admin: screens/calendars/showings, add a film, book a showing ──
(define host/blog-cinema
@@ -3288,7 +3295,13 @@
(let ((off (dream-query-param req "offering"))
(price (or (host/field req "price") "")) (cap (or (host/field req "cap") "")))
(begin
(when off (host/blog--set-field-values! off {"price" price "cap" cap}))
(when off
(begin
(host/blog--set-field-values! off {"price" price "cap" cap})
;; id carries the new values → distinct changes get distinct ids, replays dedup.
(host/blog--emit! {:verb "update" :actor host/blog--actor :object off :object-type "offering"
:delta (str "price " price " cap " cap)
:id (str "update:" off ":" price ":" cap)})))
(dream-redirect (str "/" (host/blog--offering-showing off) "/"))))))
;; remove an offering from a showing (unlink; tickets already sold keep their record).
(define host/blog-offering-remove
@@ -3296,7 +3309,11 @@
(let ((off (dream-query-param req "offering")))
(let ((showing (host/blog--offering-showing off)))
(begin
(when off (host/blog-unrelate! showing off "offers"))
(when off
(begin
(host/blog-unrelate! showing off "offers")
(host/blog--emit! {:verb "retract" :actor host/blog--actor :object off :object-type "offering"
:target showing :delta "offering removed" :id (str "retract:" off)})))
(dream-redirect (str "/" showing "/")))))))
;; add an offering to a showing — creating the ticket type first if it's new (e.g. special-offer).
(define host/blog-offering-add
@@ -3316,7 +3333,10 @@
(host/blog-relate! off "offering" "is-a")
(host/blog-relate! showing off "offers")
(host/blog-relate! off tt "of-type")
(host/blog--set-field-values! off {"price" price "cap" cap})))))
(host/blog--set-field-values! off {"price" price "cap" cap})
(host/blog--emit! {:verb "offer" :actor host/blog--actor :object off :object-type "offering"
:target showing :delta (str tt " £" price)
:id (str "offer:" off)})))))
(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
@@ -3416,7 +3436,9 @@
(host/blog-relate! opt "option" "is-a")
(host/blog-relate! poll opt "option")
(host/blog--set-field-values! opt {"label" label})))))
(filter (fn (s) (not (= s ""))) (split options ","))))))
(filter (fn (s) (not (= s ""))) (split options ",")))
(host/blog--emit! {:verb "create" :actor host/blog--actor :object poll :object-type "poll"
:target post :delta question :id (str "create:" poll)}))))
(dream-redirect (str "/" post "/"))))))
(define host/blog-vote
(fn (req)
@@ -3429,7 +3451,11 @@
(when (and poll option (not (= voter "")))
(let ((claim (ev/book! host/blog-store (str "vote:" poll) 1000000000 voter)))
(when (= (get claim :status) :booked)
(host/blog-relate! option voter "voted"))))
(begin
(host/blog-relate! option voter "voted")
;; ANONYMOUS on the wire: the seat number (not the voter) makes the id unique.
(host/blog--emit! {:verb "vote" :actor host/blog--actor :object poll :object-type "poll"
:delta option :id (str "vote:" poll ":" (str (get claim :seat)))})))))
(let ((posts (host/blog-in poll "has-poll")))
(dream-redirect (str "/" (if (> (len posts) 0) (first posts) "") "/")))))))