From e5fd4f8e0be25b513ff13ff3174568f2f160b702 Mon Sep 17 00:00:00 2001 From: giles Date: Fri, 3 Jul 2026 10:16:40 +0000 Subject: [PATCH] =?UTF-8?q?H4:=20P2=20restored=20=E2=80=94=20cinema/poll?= =?UTF-8?q?=20mutations=20emit=20activities=20(TDD)?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit 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 --- lib/host/blog.sx | 42 +++++++++++++++++++++++++++------- lib/host/tests/blog.sx | 51 ++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 85 insertions(+), 8 deletions(-) diff --git a/lib/host/blog.sx b/lib/host/blog.sx index c6eeebbd..81987ed3 100644 --- a/lib/host/blog.sx +++ b/lib/host/blog.sx @@ -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:". (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) "") "/"))))))) diff --git a/lib/host/tests/blog.sx b/lib/host/tests/blog.sx index 794b0d29..41fc8ce4 100644 --- a/lib/host/tests/blog.sx +++ b/lib/host/tests/blog.sx @@ -1412,6 +1412,57 @@ (contains? (host/blog--out-raw "h3-opt-b" "voted") "v2@x.com")) false) +;; ── HARDENING H4: P2 restored — cinema/poll state changes EMIT activities ───────────────── +;; Every mutation goes through host/blog--emit! (engine + durable activity log + outbox), so +;; federation followers + other peers' behaviors can react. Votes emit voter-ANONYMOUSLY. +(host/blog-use-store! (persist/open)) +(define host-bl-h4-verbs + (fn () (map (fn (e) (get e "verb")) host/blog--activity-log))) +(define host-bl-h4-admin + (fn (target body) + (host-bl-h2-app (host-bl-send "POST" target "Bearer good" "application/x-www-form-urlencoded" body)))) + +(host-bl-test "H4: new-film emits create(film)" + (begin + (set! host/blog--activity-log (list)) + (host-bl-h4-admin "/new-film" "title=Emit Film") + (map (fn (e) (list (get e "verb") (get e "object") (get e "type"))) host/blog--activity-log)) + (list (list "create" "emit-film" "film"))) +(host-bl-test "H4: new-showing emits schedule(showing)" + (begin + (set! host/blog--activity-log (list)) + (host-bl-h4-admin "/new-showing" "film=emit-film&calendar=h4cal&time=t1") + (contains? (host-bl-h4-verbs) "schedule")) + true) +(host-bl-test "H4: offering-add emits offer(offering)" + (begin + (set! host/blog--activity-log (list)) + (host-bl-h4-admin "/offering-add?showing=emit-film-h4cal-t1" "tickettype=h4-vip&price=9") + (contains? (host-bl-h4-verbs) "offer")) + true) +(host-bl-test "H4: offering-update emits update(offering)" + (begin + (set! host/blog--activity-log (list)) + (host-bl-h4-admin "/offering-update?offering=emit-film-h4cal-t1--h4-vip" "price=12&cap=5") + (contains? (host-bl-h4-verbs) "update")) + true) +(host-bl-test "H4: add-poll emits create(poll)" + (begin + (set! host/blog--activity-log (list)) + (host-bl-h4-admin "/add-poll?post=emit-film" "question=Q&options=a,b") + (contains? (host-bl-h4-verbs) "create")) + true) +(host-bl-test "H4: vote emits vote — voter NOT in the logged activity" + (begin + (set! host/blog--activity-log (list)) + (let ((poll (first (host/blog--out-raw "emit-film" "has-poll")))) + (begin + (host-bl-h2-app (dream-request "POST" (str "/vote?poll=" poll "&option=" poll "-a") + {:content-type "application/x-www-form-urlencoded"} "voter=secret@x.com")) + (list (contains? (host-bl-h4-verbs) "vote") + (some (fn (e) (contains? (str e) "secret@x.com")) host/blog--activity-log))))) + (list true false)) + (define host-bl-tests-run! (fn ()