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

polls on blog posts: a non-commercial Claim (vote), proving the grammar off the commerce axis

Browse Source 
Demonstrates a DIFFERENT configuration on the same substrate: a post carries polls; a vote is the
same 'acquire, deduped by actor' shape as a booking, with money + capacity turned OFF.

- host/blog-add-poll: a poll is-a poll (field question), post --has-poll--> poll, options as option
  posts (is-a option, field label), poll --option--> opt.
- host/blog-vote: one vote per voter per poll (host/blog--voted-in-poll? checks all options), records
  option --voted--> voter. No capacity, no payment — a Claim with those axes off.
- host/blog--post-polls / --poll-view / --poll-form: results (per-option counts) + a vote form per
  option + an Add-a-poll form, shown on every post page.

LIVE on blog.rose-ash.com/welcome: Dune 2 / Oppenheimer 1 / Barbie 0 (a repeat voter refused). Same
dedup as ev/book!, zero new mechanism. blog 218/218.

Co-Authored-By: Claude Opus 4.8 <noreply@anthropic.com>
This commit is contained in:
giles
2026-07-03 09:48:23 +00:00
parent ab058147fc
commit a7533b26b1
1 changed files with 74 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

74
lib/host/blog.sx
View File

@@ -2400,6 +2400,8 @@
(unquote relations)
(unquote (host/blog--allocate-form slug))
(unquote (host/blog--showing-extras slug))
(unquote (host/blog--post-polls slug))
(unquote (host/blog--poll-form slug))
(p :style "margin-top:2em;font-size:0.9em;opacity:0.8"
(a :href (unquote (str "/" slug "/source")) "view source")
" · "
@@ -3342,6 +3344,76 @@
(map (fn (p) (let ((email (get (host/blog-field-values-of p) "email")))
(quasiquote (li (b (unquote (str p))) (unquote (str " — " (or email "")))))))
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")))
(quasiquote
(div :style "margin:0.7em 0;padding:0.6em 0.8em;border:1px solid #cce;border-radius:5px;background:#f6f8ff"
(b (unquote (or q poll)))
(unquote
(cons (quote div)
(map (fn (opt)
(let ((label (get (host/blog-field-values-of opt) "label"))
(n (len (host/blog--out-raw opt "voted"))))
(quasiquote (div :style "margin:0.3em 0"
(form :method "post" :action (unquote (str "/vote?poll=" poll "&option=" opt)) :style "display:inline"
(input :name "voter" :placeholder "email" :style "width:9em") " "
(button :type "submit" (unquote (or label opt))))
(span :style "margin-left:0.6em;color:#558" (unquote (str (str n) " votes")))))))
(host/blog--out-raw poll "option")))))))))
(define host/blog--post-polls
(fn (slug)
(let ((polls (host/blog--out-raw slug "has-poll")))
(if (= (len polls) 0) ""
(cons (quote div) (map host/blog--poll-view polls))))))
(define host/blog--poll-form
(fn (slug)
(quasiquote
(details :style "margin-top:0.5em;font-size:0.9em"
(summary :style "cursor:pointer;color:#66a" "➕ Add a poll")
(form :method "post" :action (unquote (str "/add-poll?post=" slug)) :style "padding:0.4em"
(input :name "question" :placeholder "Question" :style "width:16em")
" " (input :name "options" :placeholder "options, comma-separated" :style "width:16em")
" " (button :type "submit" "Create poll"))))))
(define host/blog-add-poll
(fn (req)
(let ((post (dream-query-param req "post"))
(question (or (host/field req "question") ""))
(options (or (host/field req "options") "")))
(begin
(when (and post (not (= question "")))
(let ((poll (str post "-poll-" (str (len (host/blog-slugs))))))
(begin
(host/blog-put! poll question "(article (h1 \"Poll\"))" "published")
(host/blog-relate! poll "poll" "is-a")
(host/blog-relate! post poll "has-poll")
(host/blog--set-field-values! poll {"question" question})
(for-each (fn (label)
(when (not (= label ""))
(let ((opt (str poll "-" (host/blog-slugify label))))
(begin
(host/blog-put! opt label "(article (h1 \"Option\"))" "published")
(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 ","))))))
(dream-redirect (str "/" post "/"))))))
(define host/blog-vote
(fn (req)
(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"))
(let ((posts (host/blog-in poll "has-poll")))
(dream-redirect (str "/" (if (> (len posts) 0) (first posts) "") "/")))))))
;; ── /orders — the shop domain view: ticket orders placed for events (federated from events) ──
(define host/blog-orders
(fn (req)
@@ -3447,6 +3519,8 @@
(dream-post "/offering-add" host/blog-offering-add)
(dream-post "/offering-update" host/blog-offering-update)
(dream-post "/offering-remove" host/blog-offering-remove)
(dream-post "/add-poll" host/blog-add-poll)
(dream-post "/vote" host/blog-vote)
(dream-post "/ticket" host/blog-ticket)
(dream-post "/person" host/blog-person)
(dream-post "/new-event" host/blog-new-event)