diff --git a/lib/host/blog.sx b/lib/host/blog.sx index 0754fb77..33ab21fe 100644 --- a/lib/host/blog.sx +++ b/lib/host/blog.sx @@ -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)