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)"