diff --git a/lib/host/blog.sx b/lib/host/blog.sx index 919333e4..595d727a 100644 --- a/lib/host/blog.sx +++ b/lib/host/blog.sx @@ -158,6 +158,16 @@ :object post :object-type (host/blog--post-type post) :slug post :target calendar :to host/blog--events-base :delta (str "allocate to " calendar) :id (str "allocate:" post ":" calendar)})) +;; the UI form to allocate THIS post to a calendar on the events peer (shown only when a peer is set). +(define host/blog--allocate-form + (fn (slug) + (if (= host/blog--events-base "") "" + (quasiquote + (form :method "post" :action (unquote (str "/" slug "/allocate")) + :style "margin:1.5em 0;padding:0.7em 1em;border:1px dashed #b9a;background:#fbf7fb;border-radius:4px;font-size:0.9em" + (b "πŸ“… Allocate to a calendar: ") + (input :name "calendar" :value "main" :style "width:8em") + " " (button :type "submit" "Allocate on events")))))) ;; MARSHAL the canonical activity β†’ next/'s Erlang proplist shape, for the Erlang runner adapter ;; (RA). The seam activity is canonical; each runner adapter maps it to its substrate. Unused until ;; RA, defined + tested here so the reconcile is complete and RA has its bridge ready. @@ -299,13 +309,19 @@ ;; persisted to the blog store under one key, so /flows survives a restart. Boot-loaded via ;; host/blog-load-flowlog!. (Whole-list rewrite per effect β€” fine at P0 volume; cap/rotate later.) (define host/blog--flowlog-key "flowlog") +;; the DRIVER dispatches effect-as-data. Beyond logging, it PERFORMS known action-effects (closing +;; the loop β€” P4): a `relate` effect {:args (src kind dst)} mutates the relation graph, so a behavior +;; can create real cross-domain links (the events calendar behavior relates calendarβ†’post). (define host/blog--driver {:dispatch (fn (eff) - (begin (set! host/blog--flow-log - (concat host/blog--flow-log - (list {"verb" (get eff :verb) "args" (get eff :args)}))) - (persist/backend-kv-put host/blog-store host/blog--flowlog-key host/blog--flow-log) - (list)))}) ;; record the effect (durably); no follow-up activities (P0) + (begin + (when (= (get eff :verb) "relate") + (let ((a (get eff :args))) + (host/blog-relate! (first a) (first (rest (rest a))) (first (rest a))))) + (set! host/blog--flow-log + (concat host/blog--flow-log (list {"verb" (get eff :verb) "args" (get eff :args)}))) + (persist/backend-kv-put host/blog-store host/blog--flowlog-key host/blog--flow-log) + (list)))}) ;; record the effect (durably); no follow-up activities (P0) ;; rebuild the in-memory flow log from the durable store (call on boot, like host/blog-load-edges!). (define host/blog-load-flowlog! (fn () @@ -2364,6 +2380,7 @@ (unquote type-def-view) (unquote type-population) (unquote relations) + (unquote (host/blog--allocate-form slug)) (p :style "margin-top:2em;font-size:0.9em;opacity:0.8" (a :href (unquote (str "/" slug "/source")) "view source") " Β· " @@ -2964,6 +2981,22 @@ (unquote (if (> (len (get e "args")) 0) (str (first (get e "args"))) ""))))) host/blog--flow-log)))))))))))) +;; ── /calendars β€” the events domain view: posts allocated to each calendar (federated from blog) ── +(define host/blog-calendars + (fn (req) + (host/blog--resp req 200 + (host/blog--page req "Calendars" + (quasiquote + (div (h1 "Calendars") + (p "Posts allocated to a calendar (federated in from blog, linked by the calendar type's on-allocate behavior).") + (h3 :style "margin:1em 0 0.3em" "main") + (unquote + (let ((posts (host/blog-out "main" "allocated"))) + (if (= (len posts) 0) + (quote (p :style "color:#999" (em "Nothing allocated yet."))) + (cons (quote ul) + (map (fn (p) (quasiquote (li (unquote (str p))))) posts))))))))))) + ;; ── /activities β€” P2: the EVENT SOURCE ─────────────────────────────── ;; Every observable state change emitted as a canonical activity (Create/Update on content, ;; Add/Remove on relations). This is what federates (TA pushes it to peers) and what triggers @@ -3018,6 +3051,7 @@ (dream-get "/workflow-demo" host/blog-workflow-demo) (dream-get "/flows" host/blog-flows) (dream-get "/fed-tick" host/blog-fed-tick) + (dream-get "/calendars" host/blog-calendars) (dream-get "/activities" host/blog-activities) (dream-get "/:slug/source" host/blog-source) (dream-get "/:slug/relate-options" host/blog-relate-options) @@ -3041,7 +3075,8 @@ ;; directed "allocate" activity that federates to events, whose calendar type reacts (P1 behavior). (define host/blog-allocate (fn (req) - (let ((post (dream-param req "slug")) (calendar (or (dream-query-param req "calendar") "main"))) + (let ((post (dream-param req "slug")) + (calendar (or (host/field req "calendar") (dream-query-param req "calendar") "main"))) (begin (when (not (= host/blog--events-base "")) (host/blog--allocate! post calendar)) (dream-redirect (str "/" post "/")))))) diff --git a/lib/host/serve.sh b/lib/host/serve.sh index cd87d268..73ffac04 100755 --- a/lib/host/serve.sh +++ b/lib/host/serve.sh @@ -230,8 +230,15 @@ EPOCH=1 echo "(epoch $EPOCH)" echo "(eval \"(host/blog-seed! \\\"calendar\\\" \\\"Calendar\\\" \\\"(article (h1 \\\\\\\"Calendar\\\\\\\") (p \\\\\\\"Posts allocated to this calendar.\\\\\\\"))\\\" \\\"published\\\")\")" EPOCH=$((EPOCH+1)) + # a concrete calendar instance ("main") posts get allocated to. echo "(epoch $EPOCH)" - echo "(eval \"(host/blog--register-dag! \\\"allocate-link\\\" (quote (effect linked (field \\\"slug\\\"))))\")" + echo "(eval \"(host/blog-seed! \\\"main\\\" \\\"Main Calendar\\\" \\\"(article (h1 \\\\\\\"Main Calendar\\\\\\\"))\\\" \\\"published\\\")\")" + EPOCH=$((EPOCH+1)) + echo "(epoch $EPOCH)" + echo "(eval \"(host/blog-relate! \\\"main\\\" \\\"calendar\\\" \\\"is-a\\\")\")" + EPOCH=$((EPOCH+1)) + echo "(epoch $EPOCH)" + echo "(eval \"(host/blog--register-dag! \\\"allocate-link\\\" (quote (effect relate (field \\\"target\\\") \\\"allocated\\\" (field \\\"slug\\\"))))\")" EPOCH=$((EPOCH+1)) echo "(epoch $EPOCH)" echo "(eval \"(host/blog--set-type-behavior! \\\"calendar\\\" (list {\\\"verb\\\" \\\"allocate\\\" \\\"type\\\" \\\"article\\\" \\\"dag\\\" \\\"allocate-link\\\"}))\")"