host: live context — device/locale routed into the render-fold (composition roadmap step 4)
The render context is now the live EXECUTION environment: host/blog--comp-ctx reads device (mobile/desktop from User-Agent) and locale (from Accept-Language) PURELY from the request headers — no perform — alongside auth + the graph-query resolver. So the SAME composition object renders responsively/personalised: `(alt (when (eq "device" "mobile") …) …)` is a responsive layout, `(when (eq "locale" "fr") …)` a localised variant. The object (its when-variants) is the definition; the context picks which path renders. host/blog--device-of / host/blog--locale-of; comp-ctx now (principal req) — post handler passes req; /compose-demo gains a device-variant block. Reactive/live values plug into the same context later with no new combinators (the plan's "make the context live" axis). Verified via focused harness eval (mobile+fr vs desktop+en contexts render M/D variants; no-req ctx omits device). Tests added. Co-Authored-By: Claude Opus 4.8 <noreply@anthropic.com>
This commit is contained in:
@@ -539,11 +539,27 @@
|
|||||||
(cond
|
(cond
|
||||||
((= rel "is-a") (map host/blog-get (host/blog-instances-of type)))
|
((= rel "is-a") (map host/blog-get (host/blog-instances-of type)))
|
||||||
(else (list))))))
|
(else (list))))))
|
||||||
;; the render context for a :body: auth from the principal + the graph-query resolver.
|
;; live context values, read PURELY from the request headers (no perform) so the SAME
|
||||||
|
;; object renders responsively/personalised per request — `(alt (when (eq "device" "mobile")
|
||||||
|
;; …) …)` is a responsive layout, `(when (eq "locale" "fr") …)` a localised variant.
|
||||||
|
(define host/blog--device-of
|
||||||
|
(fn (req)
|
||||||
|
(let ((ua (str (or (dream-header req "user-agent") ""))))
|
||||||
|
(if (or (contains? ua "Mobile") (contains? ua "Android") (contains? ua "iPhone"))
|
||||||
|
"mobile" "desktop"))))
|
||||||
|
(define host/blog--locale-of
|
||||||
|
(fn (req)
|
||||||
|
(let ((al (str (or (dream-header req "accept-language") ""))))
|
||||||
|
(if (>= (len al) 2) (substr al 0 2) "en"))))
|
||||||
|
;; the render context for a :body: auth from the principal + live device/locale from the
|
||||||
|
;; request + the graph-query resolver. The context is the EXECUTION environment — the
|
||||||
|
;; object (its when-variants) is the definition; this picks which path renders.
|
||||||
(define host/blog--comp-ctx
|
(define host/blog--comp-ctx
|
||||||
(fn (principal)
|
(fn (principal req)
|
||||||
(merge (if (nil? principal) {} {"auth" "yes"})
|
(merge
|
||||||
{"query" host/blog--comp-query})))
|
(merge (if (nil? principal) {} {"auth" "yes"})
|
||||||
|
(if (nil? req) {} {"device" (host/blog--device-of req) "locale" (host/blog--locale-of req)}))
|
||||||
|
{"query" host/blog--comp-query})))
|
||||||
;; Seed a live demo of the composition fold: one object, rendered by host/comp-render, that
|
;; Seed a live demo of the composition fold: one object, rendered by host/comp-render, that
|
||||||
;; shows seq + alt(when auth) + row(par) + each — and renders DIFFERENTLY logged-in vs out.
|
;; shows seq + alt(when auth) + row(par) + each — and renders DIFFERENTLY logged-in vs out.
|
||||||
(define host/blog-seed-compose-demo!
|
(define host/blog-seed-compose-demo!
|
||||||
@@ -564,6 +580,9 @@
|
|||||||
(text "<p>This whole page is <b>one composition object</b>, rendered by the fold — it renders differently depending on context.</p>")
|
(text "<p>This whole page is <b>one composition object</b>, rendered by the fold — it renders differently depending on context.</p>")
|
||||||
(alt (when (has "auth") (text "<p style=\"color:green\"><b>Members:</b> you are logged in.</p>"))
|
(alt (when (has "auth") (text "<p style=\"color:green\"><b>Members:</b> you are logged in.</p>"))
|
||||||
(else (text "<p style=\"color:#999\"><i>Log in to see the member-only block.</i></p>")))
|
(else (text "<p style=\"color:#999\"><i>Log in to see the member-only block.</i></p>")))
|
||||||
|
;; live context: a responsive variant chosen by the request's device (User-Agent).
|
||||||
|
(alt (when (eq "device" "mobile") (text "<p>📱 <b>Mobile layout</b> (device from the request).</p>"))
|
||||||
|
(else (text "<p>🖥️ <b>Desktop layout</b> (device from the request).</p>")))
|
||||||
(text "<h3>Two columns (par)</h3>")
|
(text "<h3>Two columns (par)</h3>")
|
||||||
(row (text "<div style=\"flex:1;border:1px solid #ccc;padding:0.5em\">Column A</div>")
|
(row (text "<div style=\"flex:1;border:1px solid #ccc;padding:0.5em\">Column A</div>")
|
||||||
(text "<div style=\"flex:1;border:1px solid #ccc;padding:0.5em\">Column B</div>"))
|
(text "<div style=\"flex:1;border:1px solid #ccc;padding:0.5em\">Column B</div>"))
|
||||||
@@ -1153,7 +1172,7 @@
|
|||||||
;; (host/comp-render) against a context (auth from the principal); else the
|
;; (host/comp-render) against a context (auth from the principal); else the
|
||||||
;; legacy sx_content path. The SAME object renders differently per context.
|
;; legacy sx_content path. The SAME object renders differently per context.
|
||||||
(body-html (if (get r :body)
|
(body-html (if (get r :body)
|
||||||
(host/comp-render (get r :body) (host/blog--comp-ctx principal))
|
(host/comp-render (get r :body) (host/blog--comp-ctx principal req))
|
||||||
(host/blog-render r)))
|
(host/blog-render r)))
|
||||||
;; all relation blocks (Related, Tags, Types, Tagged-with-this …)
|
;; all relation blocks (Related, Tags, Types, Tagged-with-this …)
|
||||||
;; come from iterating the registry — one section, registry-driven.
|
;; come from iterating the registry — one section, registry-driven.
|
||||||
|
|||||||
@@ -764,7 +764,7 @@
|
|||||||
(let ((out (host/comp-render
|
(let ((out (host/comp-render
|
||||||
(quote (each (query is-a qtype)
|
(quote (each (query is-a qtype)
|
||||||
(seq (text "<a href=\"/") (val :slug) (text "\">") (field :title) (text "</a>"))))
|
(seq (text "<a href=\"/") (val :slug) (text "\">") (field :title) (text "</a>"))))
|
||||||
(host/blog--comp-ctx nil))))
|
(host/blog--comp-ctx nil nil))))
|
||||||
;; field wraps in <span> (display); val is raw (for the href attribute).
|
;; field wraps in <span> (display); val is raw (for the href attribute).
|
||||||
(list (contains? out "Item One") (contains? out "Item Two")
|
(list (contains? out "Item One") (contains? out "Item Two")
|
||||||
(contains? out "/qi-1") (contains? out "<span>Item One</span>"))))
|
(contains? out "/qi-1") (contains? out "<span>Item One</span>"))))
|
||||||
@@ -773,8 +773,22 @@
|
|||||||
(host-bl-test "each(query is-a TYPE) with no instances renders empty"
|
(host-bl-test "each(query is-a TYPE) with no instances renders empty"
|
||||||
(host/comp-render
|
(host/comp-render
|
||||||
(quote (each (query is-a no-such-type) (field :title)))
|
(quote (each (query is-a no-such-type) (field :title)))
|
||||||
(host/blog--comp-ctx nil))
|
(host/blog--comp-ctx nil nil))
|
||||||
"")
|
"")
|
||||||
|
;; -- live context: the SAME object renders a responsive variant per request (device from
|
||||||
|
;; the User-Agent, locale from Accept-Language) — context is the execution environment. --
|
||||||
|
(host-bl-test "comp-ctx reads device + locale from the request headers"
|
||||||
|
(let ((mob (host/blog--comp-ctx nil (dream-request "GET" "/x" {"user-agent" "X iPhone Y" "accept-language" "fr-FR,fr"} "")))
|
||||||
|
(desk (host/blog--comp-ctx nil (dream-request "GET" "/x" {"user-agent" "Mozilla Linux" "accept-language" "en-US"} ""))))
|
||||||
|
(list (get mob "device") (get mob "locale") (get desk "device") (get desk "locale")))
|
||||||
|
(list "mobile" "fr" "desktop" "en"))
|
||||||
|
(host-bl-test "one object renders a device-specific variant via (alt (when (eq device …)))"
|
||||||
|
(let ((body (quote (alt (when (eq "device" "mobile") (text "M")) (else (text "D")))))
|
||||||
|
(mob (dream-request "GET" "/x" {"user-agent" "iPhone"} ""))
|
||||||
|
(desk (dream-request "GET" "/x" {"user-agent" "Linux"} "")))
|
||||||
|
(list (host/comp-render body (host/blog--comp-ctx nil mob))
|
||||||
|
(host/comp-render body (host/blog--comp-ctx nil desk))))
|
||||||
|
(list "M" "D"))
|
||||||
(host-bl-test "a post with no schema'd type is vacuously valid"
|
(host-bl-test "a post with no schema'd type is vacuously valid"
|
||||||
(host/blog-type-valid? "ppost" "(p \"anything\")") true)
|
(host/blog-type-valid? "ppost" "(p \"anything\")") true)
|
||||||
(host-bl-test "edit-submit rejects content violating the type schema (not saved)"
|
(host-bl-test "edit-submit rejects content violating the type schema (not saved)"
|
||||||
|
|||||||
Reference in New Issue
Block a user