host: read the type definition on a type's PUBLIC page
A type post's public page (/article/) now shows a read-only Type-definition panel: its fields,
each Composition field's block grammar ("may contain: heading, text, image, …; control blocks:
cond, each"), and the relations its instances may use — so anyone can read what a type IS, not
just admins on the edit page. host/blog--type-def-view (the read form of host/blog--type-def-
editor's data); injected in host/blog-post after the body when host/blog--is-type?.
blog 191/191, full conformance 420/420 (+ tests: the view renders fields/grammar/relations;
GET /article/ shows it, an instance's page doesn't).
Co-Authored-By: Claude Opus 4.8 <noreply@anthropic.com>
This commit is contained in:
@@ -1902,6 +1902,31 @@
|
|||||||
(quasiquote (:id "type-def" :style "margin-top:1.5em;border-top:2px solid #999;padding-top:1em"
|
(quasiquote (:id "type-def" :style "margin-top:1.5em;border-top:2px solid #999;padding-top:1em"
|
||||||
(h3 :style "font-size:1em;margin:0 0 0.4em" "Type definition — what this type's instances may contain")))
|
(h3 :style "font-size:1em;margin:0 0 0.4em" "Type definition — what this type's instances may contain")))
|
||||||
(append rows (list (host/blog--relations-form slug)))))))))
|
(append rows (list (host/blog--relations-form slug)))))))))
|
||||||
|
;; the READ-ONLY type definition, shown on a type's PUBLIC page so anyone can read what the
|
||||||
|
;; type is: its fields, each Composition field's block grammar, and the relations its instances
|
||||||
|
;; may use. (The edit page's host/blog--type-def-editor is the writable form of the same data.)
|
||||||
|
(define host/blog--type-def-view
|
||||||
|
(fn (slug)
|
||||||
|
(let ((fields (host/blog-fields-of slug))
|
||||||
|
(rels (or (host/blog--type-relations slug) (host/blog--all-rel-kinds))))
|
||||||
|
(let ((rows
|
||||||
|
(map (fn (f)
|
||||||
|
(if (= (get f :type) "Composition")
|
||||||
|
(let ((blocks (or (get f :blocks) (host/blog--subtype-closure (list "card") :in)))
|
||||||
|
(allow (or (get f :allow) (list "cond" "each"))))
|
||||||
|
(quasiquote (li
|
||||||
|
(b (unquote (str (get f :name)))) " — composition; may contain "
|
||||||
|
(unquote (join ", " (map host/blog--card-label blocks)))
|
||||||
|
(unquote (if (empty? allow) "" (str "; control blocks: " (join ", " allow)))))))
|
||||||
|
(quasiquote (li (b (unquote (str (get f :name)))) (unquote (str " : " (get f :type)))))))
|
||||||
|
fields)))
|
||||||
|
(quasiquote
|
||||||
|
(aside :style "margin-top:2em;border:1px solid #ccc;background:#fafafa;padding:0.8em 1em;border-radius:4px"
|
||||||
|
(h3 :style "margin:0 0 0.4em;font-size:1em" "Type definition")
|
||||||
|
(unquote (if (> (len fields) 0)
|
||||||
|
(cons (quote ul) (append (quasiquote (:style "margin:0.3em 0")) rows))
|
||||||
|
(quote (p :style "color:#999;margin:0" "No declared fields."))))
|
||||||
|
(p :style "margin:0.4em 0 0" (b "Instances may be linked by: ") (unquote (join ", " rels)))))))))
|
||||||
|
|
||||||
;; ── read handlers ───────────────────────────────────────────────────
|
;; ── read handlers ───────────────────────────────────────────────────
|
||||||
;; Post body is rendered per-block (a guarded HTML string) then injected raw.
|
;; Post body is rendered per-block (a guarded HTML string) then injected raw.
|
||||||
@@ -1929,6 +1954,9 @@
|
|||||||
;; the typed render-template block (Slice 8c) — field values shown via
|
;; the typed render-template block (Slice 8c) — field values shown via
|
||||||
;; the post's types' templates. A durable read, so pre-fetch it here.
|
;; the post's types' templates. A durable read, so pre-fetch it here.
|
||||||
(typed-block (host/blog--typed-block slug))
|
(typed-block (host/blog--typed-block slug))
|
||||||
|
;; a TYPE post shows its definition (fields + grammar + relations) publicly —
|
||||||
|
;; read-only; the edit page has the writable form.
|
||||||
|
(type-def-view (if (host/blog--is-type? slug) (host/blog--type-def-view slug) ""))
|
||||||
(auth-foot (host/auth-footer req)))
|
(auth-foot (host/auth-footer req)))
|
||||||
(host/blog--resp req 200
|
(host/blog--resp req 200
|
||||||
(host/blog--page req (get r :title)
|
(host/blog--page req (get r :title)
|
||||||
@@ -1936,6 +1964,7 @@
|
|||||||
(div
|
(div
|
||||||
(unquote typed-block)
|
(unquote typed-block)
|
||||||
(article (raw! (unquote body-html)))
|
(article (raw! (unquote body-html)))
|
||||||
|
(unquote type-def-view)
|
||||||
(unquote relations)
|
(unquote relations)
|
||||||
(p :style "margin-top:2em;font-size:0.9em;opacity:0.8"
|
(p :style "margin-top:2em;font-size:0.9em;opacity:0.8"
|
||||||
(a :href (unquote (str "/" slug "/source")) "view source")
|
(a :href (unquote (str "/" slug "/source")) "view source")
|
||||||
|
|||||||
@@ -1040,6 +1040,16 @@
|
|||||||
(let ((r (host/blog--type-relations "rtype")))
|
(let ((r (host/blog--type-relations "rtype")))
|
||||||
(list (contains? r "related") (contains? r "tagged") (contains? r "is-a"))))
|
(list (contains? r "related") (contains? r "tagged") (contains? r "is-a"))))
|
||||||
(list true true false))
|
(list true true false))
|
||||||
|
;; the type definition is READABLE on a type's PUBLIC page (read-only view of the same data).
|
||||||
|
(host-bl-test "the public type-def view shows fields, block grammar, and allowed relations"
|
||||||
|
(let ((html (render-page (host/blog--type-def-view "article"))))
|
||||||
|
(list (contains? html "Type definition") (contains? html "subtitle")
|
||||||
|
(contains? html "may contain") (contains? html "Instances may be linked by")))
|
||||||
|
(list true true true true))
|
||||||
|
(host-bl-test "GET /article/ (public) shows the type definition; an instance's page does not"
|
||||||
|
(list (contains? (dream-resp-body (host-bl-app (host-bl-req "/article/"))) "Type definition")
|
||||||
|
(contains? (dream-resp-body (host-bl-app (host-bl-req "/my-first-post/"))) "Type definition"))
|
||||||
|
(list true false))
|
||||||
;; the editor renders a HAND-AUTHORED composition (text/row/alt-with-text) WITHOUT falling
|
;; the editor renders a HAND-AUTHORED composition (text/row/alt-with-text) WITHOUT falling
|
||||||
;; through to "(unknown block)" — every node kind gets a labelled row (the compose-demo case).
|
;; through to "(unknown block)" — every node kind gets a labelled row (the compose-demo case).
|
||||||
(host-bl-test "the block editor renders text/layout/inline-alt nodes (no unknown block)"
|
(host-bl-test "the block editor renders text/layout/inline-alt nodes (no unknown block)"
|
||||||
|
|||||||
Reference in New Issue
Block a user