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

H3: votes are atomic claims on the persist stream (TDD)

Browse Source 
Failing tests first (2 red: the vote wasn't on the stream, and dedup vanished if the projection
edge was removed — proving it was an edge-scan). host/blog-vote now acquires on stream
'vote:<poll>' via ev/book! (append-expect, retry-on-conflict — the same atomicity as seats);
the option --voted--> edge is a projection recorded only on :booked. Removed the read-check-write
host/blog--voted-in-poll?. Governance-grade: no double vote under concurrency, dedup survives
projection wipes + restarts (store-backed).

blog suite 238/238 (+4).

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

13
lib/host/blog.sx
View File

@@ -3364,10 +3364,6 @@
people)))))))))))
;; ── POLLS (non-commercial): a post carries polls; a VOTE is a Claim with money + capacity turned
;; OFF — the same "acquire, deduped by actor" shape as a booking, one vote per voter per poll.
(define host/blog--voted-in-poll?
(fn (poll voter)
(some (fn (opt) (contains? (host/blog--out-raw opt "voted") voter))
(host/blog--out-raw poll "option"))))
(define host/blog--poll-view
(fn (poll)
(let ((q (get (host/blog-field-values-of poll) "question")))
@@ -3427,8 +3423,13 @@
(let ((poll (dream-query-param req "poll")) (option (dream-query-param req "option"))
(voter (or (host/field req "voter") "")))
(begin
(when (and poll option (not (= voter "")) (not (host/blog--voted-in-poll? poll voter)))
(host/blog-relate! option voter "voted"))
;; H3: one-vote-per-voter is an ATOMIC claim on the persist stream "vote:<poll>" — the same
;; append-expect acquire as seats (ev/book! :already = already voted). The option edge is a
;; projection recorded only when the claim lands; the stream is the source of truth.
(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"))))
(let ((posts (host/blog-in poll "has-poll")))
(dream-redirect (str "/" (if (> (len posts) 0) (first posts) "") "/")))))))

33
lib/host/tests/blog.sx
View File

@@ -1379,6 +1379,39 @@
(host-bl-test "H2: /buy-ticket stays PUBLIC (no login redirect)"
(starts-with? (host-bl-h2-loc "POST" "/buy-ticket?showing=s&offering=o" false "email=v@x.com") "/login") false)
;; ── HARDENING H3: votes are ATOMIC claims on the persist stream (not edge-scan dedup) ─────
;; One vote per voter per poll enforced by an ev/book!-style acquire on stream "vote:<poll>" —
;; the same append-expect atomicity as seats. The edge is a projection; the stream is truth.
(host/blog-use-store! (persist/open))
(host/blog-put! "h3-poll" "Q" "(article (h1 \"p\"))" "published")
(host/blog-relate! "h3-poll" "poll" "is-a")
(for-each (fn (o) (begin (host/blog-put! o o "(article (h1 \"o\"))" "published")
(host/blog-relate! "h3-poll" o "option")))
(list "h3-opt-a" "h3-opt-b"))
(define host-bl-h3-vote
(fn (opt voter)
(host-bl-h2-app (dream-request "POST" (str "/vote?poll=h3-poll&option=" opt)
{:content-type "application/x-www-form-urlencoded"} (str "voter=" voter)))))
(host-bl-test "H3: first vote lands"
(begin (host-bl-h3-vote "h3-opt-a" "v1@x.com")
(contains? (host/blog--out-raw "h3-opt-a" "voted") "v1@x.com"))
true)
(host-bl-test "H3: second vote by same voter refused (different option)"
(begin (host-bl-h3-vote "h3-opt-b" "v1@x.com")
(contains? (host/blog--out-raw "h3-opt-b" "voted") "v1@x.com"))
false)
(host-bl-test "H3: the vote is on the persist stream (roster of vote:<poll>)"
(contains? (ev/roster host/blog-store "vote:h3-poll") "v1@x.com")
true)
(host-bl-test "H3: dedup is store-backed — survives edge removal (NOT an edge scan)"
(begin
(host-bl-h3-vote "h3-opt-a" "v2@x.com")
(host/blog-unrelate! "h3-opt-a" "v2@x.com" "voted") ;; wipe the projection
(host-bl-h3-vote "h3-opt-b" "v2@x.com") ;; revote attempt
(contains? (host/blog--out-raw "h3-opt-b" "voted") "v2@x.com"))
false)
(define
host-bl-tests-run!
(fn ()