From 5ead6e73c77acd3ada8021ed668cb8801f700c8e Mon Sep 17 00:00:00 2001 From: giles Date: Tue, 30 Jun 2026 20:43:06 +0000 Subject: [PATCH] =?UTF-8?q?host:=20live=20context=20=E2=80=94=20device/loc?= =?UTF-8?q?ale=20routed=20into=20the=20render-fold=20(composition=20roadma?= =?UTF-8?q?p=20step=204)?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit 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 --- lib/host/blog.sx | 29 ++++++++++++++++++++++++----- lib/host/tests/blog.sx | 18 ++++++++++++++++-- 2 files changed, 40 insertions(+), 7 deletions(-) diff --git a/lib/host/blog.sx b/lib/host/blog.sx index ad4d7608..44f3b3a4 100644 --- a/lib/host/blog.sx +++ b/lib/host/blog.sx @@ -539,11 +539,27 @@ (cond ((= rel "is-a") (map host/blog-get (host/blog-instances-of type))) (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 - (fn (principal) - (merge (if (nil? principal) {} {"auth" "yes"}) - {"query" host/blog--comp-query}))) + (fn (principal req) + (merge + (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 ;; shows seq + alt(when auth) + row(par) + each — and renders DIFFERENTLY logged-in vs out. (define host/blog-seed-compose-demo! @@ -564,6 +580,9 @@ (text "

This whole page is one composition object, rendered by the fold — it renders differently depending on context.

") (alt (when (has "auth") (text "

Members: you are logged in.

")) (else (text "

Log in to see the member-only block.

"))) + ;; live context: a responsive variant chosen by the request's device (User-Agent). + (alt (when (eq "device" "mobile") (text "

📱 Mobile layout (device from the request).

")) + (else (text "

🖥️ Desktop layout (device from the request).

"))) (text "

Two columns (par)

") (row (text "
Column A
") (text "
Column B
")) @@ -1153,7 +1172,7 @@ ;; (host/comp-render) against a context (auth from the principal); else the ;; legacy sx_content path. The SAME object renders differently per context. (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))) ;; all relation blocks (Related, Tags, Types, Tagged-with-this …) ;; come from iterating the registry — one section, registry-driven. diff --git a/lib/host/tests/blog.sx b/lib/host/tests/blog.sx index 1db48075..0d28c4d3 100644 --- a/lib/host/tests/blog.sx +++ b/lib/host/tests/blog.sx @@ -764,7 +764,7 @@ (let ((out (host/comp-render (quote (each (query is-a qtype) (seq (text "") (field :title) (text "")))) - (host/blog--comp-ctx nil)))) + (host/blog--comp-ctx nil nil)))) ;; field wraps in (display); val is raw (for the href attribute). (list (contains? out "Item One") (contains? out "Item Two") (contains? out "/qi-1") (contains? out "Item One")))) @@ -773,8 +773,22 @@ (host-bl-test "each(query is-a TYPE) with no instances renders empty" (host/comp-render (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/blog-type-valid? "ppost" "(p \"anything\")") true) (host-bl-test "edit-submit rejects content violating the type schema (not saved)"