diff --git a/lib/host/blog.sx b/lib/host/blog.sx index a3bb1521..0d874db6 100644 --- a/lib/host/blog.sx +++ b/lib/host/blog.sx @@ -85,35 +85,68 @@ (else (host/blog--render-node tree)))) (str "

(empty post)

"))))) ;; ── related posts (blog × relations) ──────────────────────────────── -;; A "related" link between two posts is a SYMMETRIC pair of edges in the -;; relations graph (lib/relations): node = "blog:", kind = related. Edges go -;; both ways so "related posts" reads the same from either side via children alone -;; — composing two already-migrated domains (blog + relations) on the host. -(define host/blog--rel-kind (string->symbol "related")) +;; Every link between posts is a typed edge in the relations graph (lib/relations): +;; node = "blog:", kind = a relation kind. "related" is symmetric; directed +;; kinds (is-a, tagged) carry meaning by direction. The registry below is the one +;; place that knows each kind's direction, label, and candidate set — relate, the +;; picker, and rendering all read from it (see plans/typed-posts-and-relations.md). +;; "Typing is just relating to a type": classification is an is-a/tagged edge to a +;; type-post, and types ARE posts (same blog: namespace). (define host/blog--node (fn (slug) (string->symbol (str "blog:" slug)))) -(define host/blog-relate! - (fn (a b) - (begin - (relations/relate (host/blog--node a) (host/blog--node b) host/blog--rel-kind) - (relations/relate (host/blog--node b) (host/blog--node a) host/blog--rel-kind)))) -(define host/blog-unrelate! - (fn (a b) - (begin - (relations/unrelate (host/blog--node a) (host/blog--node b) host/blog--rel-kind) - (relations/unrelate (host/blog--node b) (host/blog--node a) host/blog--rel-kind)))) +(define host/blog-rel-kinds + (list + {:kind "related" :label "Related posts" :symmetric true :candidates "all"} + {:kind "is-a" :label "Types" :symmetric false :candidates "types" + :inverse-label "Instances"} + {:kind "tagged" :label "Tags" :symmetric false :candidates "tags" + :inverse-label "Tagged with this"})) -;; related slugs for a post: blog children under "related", stripped to slug, and -;; limited to posts that still exist (a deleted post can leave a dangling edge). -;; Existence is checked against ONE kv-keys read (host/blog-slugs), not a perform -;; per candidate — keeping IO out of the inner filter. -(define host/blog-related - (fn (slug) +;; registry lookup; nil for an unknown kind (relate validates against this) +(define host/blog--kind-spec + (fn (kind) + (reduce (fn (acc k) (if (= (get k :kind) kind) k acc)) nil host/blog-rel-kinds))) +(define host/blog--kind-symmetric? + (fn (kind) (let ((s (host/blog--kind-spec kind))) (and s (get s :symmetric))))) + +;; ── edges (parameterised by kind) ─────────────────────────────────── +;; A symmetric kind writes both directions, so children alone read it from either +;; side; a directed kind writes one edge (the inverse is host/blog-in). +(define host/blog-relate! + (fn (a b kind) + (let ((k (string->symbol kind))) + (begin + (relations/relate (host/blog--node a) (host/blog--node b) k) + (when (host/blog--kind-symmetric? kind) + (relations/relate (host/blog--node b) (host/blog--node a) k)))))) +(define host/blog-unrelate! + (fn (a b kind) + (let ((k (string->symbol kind))) + (begin + (relations/unrelate (host/blog--node a) (host/blog--node b) k) + (when (host/blog--kind-symmetric? kind) + (relations/unrelate (host/blog--node b) (host/blog--node a) k)))))) + +;; nodes -> existing blog slugs: strip "blog:", drop non-blog and deleted targets. +;; Existence is one kv-keys read (host/blog-slugs), NOT a perform per candidate — +;; keeping IO out of the inner filter (and out of the page-render quasiquote). +(define host/blog--edge-slugs + (fn (nodes) (let ((existing (host/blog-slugs))) - (let ((kids (relations/children (host/blog--node slug) host/blog--rel-kind))) - (filter (fn (s) (contains? existing s)) - (map (fn (n) (substr (symbol->string n) 5)) - (filter (fn (n) (starts-with? (symbol->string n) "blog:")) kids))))))) + (filter (fn (s) (contains? existing s)) + (map (fn (n) (substr (symbol->string n) 5)) + (filter (fn (n) (starts-with? (symbol->string n) "blog:")) nodes)))))) + +;; outgoing targets / incoming sources of `slug` under `kind`, as slug lists. +(define host/blog-out + (fn (slug kind) + (host/blog--edge-slugs (relations/children (host/blog--node slug) (string->symbol kind))))) +(define host/blog-in + (fn (slug kind) + (host/blog--edge-slugs (relations/parents (host/blog--node slug) (string->symbol kind))))) + +;; back-compat: "related posts" is just the symmetric "related" kind. +(define host/blog-related (fn (slug) (host/blog-out slug "related"))) ;; ── relate picker (filterable, paginated candidate list) ──────────── ;; Candidates to relate `slug` to: every post except itself and ones already @@ -421,42 +454,57 @@ (host/error 400 "invalid payload"))))) ;; DELETE /posts/ +;; drop every edge touching `slug`, across all kinds + both directions, so a +;; deleted post leaves no dangling links anywhere in the graph. +(define host/blog--drop-all-edges! + (fn (slug) + (for-each + (fn (spec) + (let ((kind (get spec :kind))) + (begin + (for-each (fn (o) (host/blog-unrelate! slug o kind)) (host/blog-out slug kind)) + (for-each (fn (o) (host/blog-unrelate! o slug kind)) (host/blog-in slug kind))))) + host/blog-rel-kinds))) + (define host/blog-delete-handler (fn (req) (let ((slug (dream-param req "slug"))) (if (host/blog-exists? slug) (begin - ;; drop the post's related edges so no dangling links survive it - (for-each (fn (o) (host/blog-unrelate! slug o)) (host/blog-related slug)) + (host/blog--drop-all-edges! slug) (host/blog-delete! slug) (host/ok {:slug slug :deleted true})) (host/error 404 "no such post"))))) -;; POST //relate — relate this post to another (form field `other` = slug). -;; Validated: the other post must exist and differ; otherwise it's a no-op. Always -;; redirects back to the edit page. Guarded like the other browser write routes. +;; POST //relate — relate this post to another (form `other` = slug, `kind` = +;; relation kind, default "related"). Validated: kind must be a known kind and the +;; other post must exist and differ; otherwise a no-op. Redirects back to the edit +;; page. Guarded like the other browser write routes. (define host/blog-relate-submit (fn (req) (let ((slug (dream-param req "slug")) - (other (dream-form-field req "other"))) + (other (dream-form-field req "other")) + (kind (or (dream-form-field req "kind") "related"))) (if (nil? (host/blog-get slug)) (dream-html-status 404 (host/blog--page "Not found" (quasiquote (div (h1 "404") (p (unquote (str "No post: " slug))))))) (begin - (when (and other (not (= other "")) (not (= other slug)) (host/blog-exists? other)) - (host/blog-relate! slug other)) + (when (and other (not (= other "")) (not (= other slug)) + (host/blog--kind-spec kind) (host/blog-exists? other)) + (host/blog-relate! slug other kind)) (dream-redirect (str "/" slug "/edit"))))))) -;; POST //unrelate — remove the relation to `other`. Idempotent; redirects -;; back to the edit page. +;; POST //unrelate — remove the relation to `other` under `kind` (default +;; "related"). Idempotent; redirects back to the edit page. (define host/blog-unrelate-submit (fn (req) (let ((slug (dream-param req "slug")) - (other (dream-form-field req "other"))) + (other (dream-form-field req "other")) + (kind (or (dream-form-field req "kind") "related"))) (begin - (when (and other (not (= other ""))) - (host/blog-unrelate! slug other)) + (when (and other (not (= other "")) (host/blog--kind-spec kind)) + (host/blog-unrelate! slug other kind)) (dream-redirect (str "/" slug "/edit")))))) ;; GET //edit — edit form pre-filled with the post's current title, raw diff --git a/lib/host/tests/blog.sx b/lib/host/tests/blog.sx index dc59fe39..bf78240c 100644 --- a/lib/host/tests/blog.sx +++ b/lib/host/tests/blog.sx @@ -267,10 +267,10 @@ (list true false)) (host-bl-test "relate-options excludes already-related candidates" (begin - (host/blog-relate! "alpha-post" "beta-post") + (host/blog-relate! "alpha-post" "beta-post" "related") (contains? (dream-resp-body (host-bl-app (host-bl-req "/alpha-post/relate-options"))) "Beta Post")) false) -(host/blog-unrelate! "alpha-post" "beta-post") +(host/blog-unrelate! "alpha-post" "beta-post" "related") (host-bl-test "relate-picker.js served as javascript" (dream-resp-header (host-bl-app (host-bl-req "/relate-picker.js")) "content-type") "application/javascript; charset=utf-8") @@ -281,6 +281,40 @@ (host-bl-test "related block: empty when anonymous + no relations" (= (host/blog--related-block "gamma-post" false) "") true) +;; -- Phase 1: relations carry a kind -- +(host-bl-test "symmetric kind (related) reads from both sides" + (begin + (host/blog-relate! "alpha-post" "gamma-post" "related") + (list (contains? (host/blog-out "alpha-post" "related") "gamma-post") + (contains? (host/blog-out "gamma-post" "related") "alpha-post"))) + (list true true)) +(host-bl-test "directed kind (tagged) writes one direction; inverse via host/blog-in" + (begin + (host/blog-relate! "alpha-post" "beta-post" "tagged") + (list (contains? (host/blog-out "alpha-post" "tagged") "beta-post") + (contains? (host/blog-out "beta-post" "tagged") "alpha-post") + (contains? (host/blog-in "beta-post" "tagged") "alpha-post"))) + (list true false true)) +(host-bl-test "unrelate is kind-scoped (related edge survives a tagged unrelate)" + (begin + (host/blog-unrelate! "alpha-post" "beta-post" "tagged") + (list (contains? (host/blog-out "alpha-post" "tagged") "beta-post") + (contains? (host/blog-out "alpha-post" "related") "gamma-post"))) + (list false true)) +(host/blog-unrelate! "alpha-post" "gamma-post" "related") +(host-bl-test "relate-submit rejects an unknown kind (no-op)" + (begin + (host-bl-wapp (host-bl-send "POST" "/alpha-post/relate" "Bearer good" + "application/x-www-form-urlencoded" "other=beta-post&kind=bogus")) + (contains? (host/blog-out "alpha-post" "bogus") "beta-post")) + false) +(host-bl-test "default kind is related (no kind field)" + (begin + (host-bl-wapp (host-bl-send "POST" "/alpha-post/relate" "Bearer good" + "application/x-www-form-urlencoded" "other=beta-post")) + (contains? (host/blog-out "alpha-post" "related") "beta-post")) + true) + ;; -- experimental unguarded create-only route (POST /new, no auth) -- (define host-bl-oapp (host/make-app (list host/blog-open-create-routes host/blog-routes))) (host/blog-use-store! (persist/open)) diff --git a/plans/typed-posts-and-relations.md b/plans/typed-posts-and-relations.md new file mode 100644 index 00000000..21f3320d --- /dev/null +++ b/plans/typed-posts-and-relations.md @@ -0,0 +1,96 @@ +# Typed posts & relations — typing is just relating to a type + +> host-on-sx. Driving idea: **classification is a relation to a type node, and +> types are posts.** Everything (related, tag, category, series, type) becomes a +> typed edge in `lib/relations` over `blog:` nodes. One primitive. + +## Decisions + +- **Types are posts.** No new node namespace — content-posts and type/tag posts + are all `blog:`. A "tag" is a post; tagging documents itself. +- **`is-a` is the typing edge; `tagged` is membership.** Kept distinct so a tag + page can list members without conflating "ocaml is a tag" with "hello is + tagged ocaml". +- **Hierarchy is core, not deferred.** `is-a`/`subtype-of` transitive closure via + `lib/relations` reachability is what makes typing-as-relation more than flat + labels. All typing helpers are transitive from the first line, or subtypes + silently break candidate/`is-a?` checks later. +- **Validation is gradual, not deferred.** A type-post *optionally* carries a + schema slot; validation runs only where one exists. Tags declare none (stay + folksonomy-free); `article` can declare "needs a heading". The hook lands with + the type phase (reusing `host/blog-content-ok?`); only schema *expressiveness* + grows over time. This closes the nominal/structural loop: the declared `is-a` + edge is a claim, the validator checks the content honors it. +- **Scalars stay fields.** `status`/`title`/`sx_content` remain fields, not edges + — listings filter on them constantly and `lib/relations` re-saturates Datalog + per query. Links-to-shared-nodes → edges; per-post hot scalars → fields. + +## The linchpin: a relation-kind registry + +One data structure drives validation, the picker candidate sets, and rendering: + +``` +host/blog-rel-kinds = + ({:kind "related" :label "Related posts" :symmetric true :candidates "all"} + {:kind "is-a" :label "Types" :symmetric false :candidates "types" + :inverse-label "Instances"} + {:kind "tagged" :label "Tags" :symmetric false :candidates "tags" + :inverse-label "Tagged with this"}) +``` + +`:symmetric` → write both directions on relate. `:candidates` → what the picker +offers (`all` = every post; `tags` = `is-a? blog:tag` transitively; `types` = +`is-a? blog:type`). `:label`/`:inverse-label` → headings. + +## Phases + +### Phase 1 — Kind generalization + registry ← START HERE +Pure refactor; zero user-visible change (related keeps working). +- `host/blog-rel-kinds` registry + `host/blog--kind-spec`/`--kind-symmetric?`. +- `host/blog-relate!(a,b,kind)` / `unrelate!(a,b,kind)` — directed; symmetric kinds + also write the reverse (today's "related" behavior = the symmetric case). +- `host/blog-out(slug,kind)` (children) / `host/blog-in(slug,kind)` (parents), + existence-filtered. `host/blog-related(slug)` = `out(slug,"related")` (back-compat). +- Routes carry `kind` (form field, default `"related"`); validated against registry. +- `delete` cleanup drops edges across **all** kinds, both directions. + +### Phase 2 — Type resolution via reachability (the spine) +- Seed root type-posts: `blog:type` ("Type") and `blog:tag is-a blog:type`, + each documenting itself. Idempotent seed in `serve.sh`. +- `host/blog-types-of(slug)` = direct `is-a` targets ∪ `subtype-of`-reach of each + (SX-side composition over `lib/relations` reach — no new Datalog rules). +- `host/blog-is-a?(slug, type)` — **transitive**. +- Type-posts carry an optional `:schema` slot (designed now, mostly empty). +- Validation hook: `host/blog-content-ok?` extended to also run any schema(s) + implied by the post's declared types. No schema → no-op (gradual). + +### Phase 3 — Tags as posts +- "is a tag" = `host/blog-is-a? slug "tag"` (transitive). Helpers + `host/blog-tags(slug)` = `out(slug,"tagged")`, `host/blog-tagged-with(tag)` = + `in(tag,"tagged")`. +- Edit page: a "This post is a tag" toggle = add/remove `is-a blog:tag` edge. + +### Phase 4 — Render (data-driven from the registry) +- Post page iterates the registry → "Related posts" + "Tags" blocks, same code. +- Tag-post page: its own content (the tag's documentation) **plus** "Tagged with + this" (incoming `tagged`). A tag page documents the tag AND lists its members. +- Optional `/tags` index = posts `is-a? blog:tag`. + +### Phase 5 — Generalize the picker +- `host/blog--relate-candidates(slug, q, kind)` branches on the kind's + `:candidates` (all / tags / types). +- `relate-options` endpoint takes `&kind=`; picker filter input carries + `data-kind`; `relate-picker.js` forwards it. +- Edit page renders one picker section per kind from the registry. + +### Phase 6 — Schema expressiveness (ongoing) +- Grow the type `:schema` language: start minimal (required block kinds / a + predicate over content), richer later. Enforcement already wired in Phase 2; + only the language grows. Not a blocker — a gradient. + +## Notes +- Node model unchanged (`blog:`); only `kind` varies. The relate machinery, + picker, and post-page block all generalize by lifting the hard-coded + `kind: "related"` into a parameter. +- A type can *be* a post all the way up (`blog:tag is-a blog:type`); meta-circular + but bounded by seeding a small root set.