H4: P2 restored — cinema/poll mutations emit activities (TDD)
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:
@@ -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) "") "/")))))))
|
||||
|
||||
|
||||
@@ -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 ()
|
||||
|
||||
Reference in New Issue
Block a user