diff --git a/lib/host/blog.sx b/lib/host/blog.sx index 38ce2527..2d4cc891 100644 --- a/lib/host/blog.sx +++ b/lib/host/blog.sx @@ -416,6 +416,87 @@ (when r (host/blog--write! slug (merge r {:schema schema})))))) +;; ── Slice 8: typed scalar FIELDS on a type (the keystone for the UI) ─ +;; A type declares :fields — a list of {:name :type [:widget] [:required]} specs. A +;; field holds a typed VALUE on an instance (vs a relation, which is an edge to a post). +;; value-type names map to a default input widget; fields drive BOTH the generic edit +;; form (one input per field) AND the render template. Direct fields for now; inheritance +;; through subtype-of is a follow-up. See plans/relations-as-posts.md ("Types define the UI"). +(define host/blog-value-types + {"String" {:widget "text"} + "Text" {:widget "textarea"} + "URL" {:widget "url"} + "Int" {:widget "number"} + "Date" {:widget "date"} + "Bool" {:widget "checkbox"}}) +;; the input widget for a field: its explicit :widget, else its value-type's default, +;; else "text" (an unknown value-type degrades to a plain text input). +(define host/blog--widget-for + (fn (field) + (or (get field :widget) + (let ((vt (get host/blog-value-types (get field :type)))) + (if vt (get vt :widget) "text"))))) +;; a type-post's declared fields (empty list if none). +(define host/blog-fields-of + (fn (type-slug) (or (get (host/blog-get type-slug) :fields) (list)))) +;; attach/replace a type-post's :fields (idempotent; preserves the rest of the record). +(define host/blog--set-fields! + (fn (slug fields) + (let ((r (host/blog-get slug))) + (when r + (host/blog--write! slug (merge r {:fields fields})))))) +;; "name:Type, name:Type" — a one-line summary of a field list (for /meta). "—" if none. +(define host/blog--fields-summary + (fn (fields) + (if (and fields (> (len fields) 0)) + (join ", " (map (fn (f) (str (get f :name) ":" (get f :type))) fields)) + "—"))) + +;; ── Slice 8b: field VALUES on an instance + the generic, type-driven form ── +;; An instance carries :field-values = {field-name -> value}. The fields applicable to +;; a post are the union of the fields declared by every type it is-a (deduped by name) — +;; so the SAME form is generated from the type definitions, no per-type code. This IS +;; "the editor maps onto the types": host/blog--field-inputs turns a type's fields into +;; the edit inputs; host/blog-edit-submit reads them back. Display-via-template is next. +(define host/blog-field-values-of + (fn (slug) (or (get (host/blog-get slug) :field-values) {}))) +(define host/blog--set-field-values! + (fn (slug vals) + (let ((r (host/blog-get slug))) + (when r (host/blog--write! slug (merge r {:field-values vals})))))) +;; the fields applicable to a post = union over its (transitive) types' fields, deduped +;; by name. One durable graph read (types-of) up front — call in a handler let, not a render. +(define host/blog--fields-for-post + (fn (slug) + (reduce + (fn (acc t) + (reduce + (fn (a f) + (if (contains? (map (fn (g) (get g :name)) a) (get f :name)) + a + (concat a (list f)))) + acc + (host/blog-fields-of t))) + (list) + (host/blog-types-of slug)))) +;; render one labelled input per field, pre-filled from `values`. Widget per value-type +;; (textarea for Text, else a typed ). Pure — takes pre-fetched fields + values. +(define host/blog--field-inputs + (fn (fields values) + (map (fn (f) + (let ((nm (get f :name)) (w (host/blog--widget-for f))) + (let ((val (or (get values nm) ""))) + (quasiquote + (p (label :style "display:block;font-size:0.85em;opacity:0.7" + (unquote (str nm " (" (get f :type) ")"))) + (unquote + (if (= w "textarea") + (quasiquote (textarea :name (unquote (str "field-" nm)) :rows "3" + :style "width:100%" (unquote val))) + (quasiquote (input :type (unquote w) :name (unquote (str "field-" nm)) + :value (unquote val) :style "width:100%"))))))))) + fields))) + ;; every element tag in a parsed content tree, recursively (the heads of nested ;; lists) — so "requires h1" matches an h1 even inside an article/section wrapper. (define host/blog--all-tags @@ -490,6 +571,11 @@ (host/blog-relate! "article" "type" "subtype-of") ;; article's schema lives ON the article post now (Slice 5) — install/migrate it. (host/blog--set-schema! "article" (list {:block "h1" :msg "an article needs a heading (h1)"})) + ;; article's typed FIELDS (Slice 8) — these drive the generic edit form + the render + ;; template: a subtitle (plain text) and an optional hero image URL. + (host/blog--set-fields! "article" + (list {:name "subtitle" :type "String"} + {:name "hero" :type "URL"})) ;; relation DECLARATIONS (see plans/relations-as-posts.md). A type-post declares ;; which relation it anchors at its OBJECT end ("you may point at me with R"); the ;; picker's candidate set is the down-closure of a relation's anchors through the @@ -1016,9 +1102,9 @@ (define host/blog-meta-index (fn (req) (let ((type-recs - (map (fn (s) {:slug s - :title (get (host/blog-get s) :title) - :schema (host/blog-schema-of s)}) + (map (fn (s) + (let ((r (host/blog-get s))) + {:slug s :title (get r :title) :schema (get r :schema) :fields (get r :fields)})) (sort (host/blog-type-defs)))) (rel-specs host/blog-rel-kinds) (auth-foot (host/auth-footer req))) @@ -1027,6 +1113,7 @@ (quasiquote (tr (td (a :href (unquote (str "/" (get p :slug) "/")) (unquote (get p :title)))) + (td (unquote (host/blog--fields-summary (get p :fields)))) (td (unquote (host/blog--schema-summary (get p :schema))))))) type-recs)) (rel-rows @@ -1046,7 +1133,7 @@ (h2 (unquote (str "Types (" (len type-recs) ")"))) (unquote (if (> (len type-recs) 0) (cons (quote table) - (cons (quote (tr (th "Type") (th "Required blocks"))) type-rows)) + (cons (quote (tr (th "Type") (th "Fields") (th "Required blocks"))) type-rows)) (quote (p "No types yet.")))) (h2 (unquote (str "Relations (" (len rel-specs) ")"))) (unquote (if (> (len rel-specs) 0) @@ -1207,6 +1294,8 @@ ;; here, not in the quasiquote, so IO stays in the handler body. (let ((relation-editors (host/blog--relation-editors slug)) (tag-toggle (host/blog--is-tag-toggle slug)) + (post-fields (host/blog--fields-for-post slug)) + (field-values (host/blog-field-values-of slug)) (mk-opt (fn (val label) (if (= val status) @@ -1223,6 +1312,11 @@ (p (textarea :name "sx_content" :rows "16" :style "width:100%;font-family:monospace" (unquote (or (get r :sx-content) "")))) + (unquote (if (> (len post-fields) 0) + (cons (quote div) + (cons (quote (h3 :style "font-size:1em;margin:1em 0 0.3em" "Fields")) + (host/blog--field-inputs post-fields field-values))) + "")) (p (select :name "status" (unquote (mk-opt "draft" "Draft")) (unquote (mk-opt "published" "Published"))) @@ -1247,7 +1341,8 @@ (quasiquote (div (h1 "404") (p (unquote (str "No post: " slug))))))) (let ((title (or (host/field req "title") (get r :title))) (sx-content (or (host/field req "sx_content") "")) - (status (or (host/field req "status") (get r :status)))) + (status (or (host/field req "status") (get r :status))) + (post-fields (host/blog--fields-for-post slug))) ;; collect issues up front (perform): unparseable markup, then each ;; schema requirement the post's types impose. Empty = save. (let ((issues (if (host/blog-content-ok? sx-content) @@ -1256,6 +1351,12 @@ (if (= (len issues) 0) (begin (host/blog-put! slug title sx-content status) + ;; store the typed field values from the generic, type-driven form (Slice 8b) + (host/blog--set-field-values! slug + (reduce (fn (acc f) + (assoc acc (get f :name) + (or (host/field req (str "field-" (get f :name))) ""))) + {} post-fields)) (dream-redirect (str "/" slug "/"))) (let ((issue-items (map (fn (i) (quasiquote (li (unquote i)))) issues))) (host/blog--resp req 400 diff --git a/lib/host/tests/blog.sx b/lib/host/tests/blog.sx index c9040061..a8f7f794 100644 --- a/lib/host/tests/blog.sx +++ b/lib/host/tests/blog.sx @@ -602,6 +602,55 @@ (contains? body "h1") (contains? body "related") (contains? body "symmetric"))) (list true true true true true)) + +;; -- Slice 8: typed scalar fields on a type -- +(host-bl-test "fields-of reads a type's declared fields (seeded on article)" + (map (fn (f) (get f :name)) (host/blog-fields-of "article")) + (list "subtitle" "hero")) +(host-bl-test "widget-for: explicit > value-type default > text fallback" + (list (host/blog--widget-for {:name "a" :type "URL"}) + (host/blog--widget-for {:name "b" :type "Text"}) + (host/blog--widget-for {:name "c" :type "Nonsense"}) + (host/blog--widget-for {:name "d" :type "String" :widget "custom"})) + (list "url" "textarea" "text" "custom")) +(host-bl-test "set-fields! is idempotent + preserves the rest of the record" + (begin + (host/blog--set-fields! "article" + (list {:name "subtitle" :type "String"} {:name "hero" :type "URL"})) + (list (get (host/blog-get "article") :title) (len (host/blog-fields-of "article")))) + (list "Article" 2)) +(host-bl-test "a type with no declared fields -> empty list" + (host/blog-fields-of "tag") (list)) +(host-bl-test "/meta shows the article's typed fields" + (contains? (dream-resp-body (host-bl-app (host-bl-req "/meta"))) "subtitle:String") true) + +;; -- Slice 8b: field values + the generic, type-driven edit form -- +(host-bl-test "fields-for-post = union of the post's (transitive) types' fields" + (begin + (host/blog-put! "fpost" "F Post" "(article (h1 \"F\"))" "published") + (host/blog-relate! "fpost" "article" "is-a") + (map (fn (f) (get f :name)) (host/blog--fields-for-post "fpost"))) + (list "subtitle" "hero")) +(host-bl-test "a post of no typed type has no fields" + (host/blog--fields-for-post "hello") (list)) +(host-bl-test "set/get field-values round-trips on an instance" + (begin + (host/blog--set-field-values! "fpost" {"subtitle" "A subtitle" "hero" "http://x/y.png"}) + (list (get (host/blog-field-values-of "fpost") "subtitle") + (get (host/blog-field-values-of "fpost") "hero"))) + (list "A subtitle" "http://x/y.png")) +(host-bl-test "edit form renders one input per field for a typed post" + (let ((body (dream-resp-body (host-bl-wapp (host-bl-send "GET" "/fpost/edit" "Bearer good" nil ""))))) + (list (contains? body "field-subtitle") (contains? body "field-hero") (contains? body "Fields"))) + (list true true true)) +(host-bl-test "edit-submit stores the typed field values from the form" + (begin + (host-bl-wapp (host-bl-send "POST" "/fpost/edit" "Bearer good" + "application/x-www-form-urlencoded" + "sx_content=(article+(h1+%22F%22))&field-subtitle=Saved+Sub&field-hero=http%3A%2F%2Fz%2Fq.png")) + (list (get (host/blog-field-values-of "fpost") "subtitle") + (get (host/blog-field-values-of "fpost") "hero"))) + (list "Saved Sub" "http://z/q.png")) (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)"