diff --git a/applications/sxtp/spec.sx b/applications/sxtp/spec.sx index afa8938e..78e5f6cc 100644 --- a/applications/sxtp/spec.sx +++ b/applications/sxtp/spec.sx @@ -97,6 +97,42 @@ (:body "Any SX value — event payload (optional)") (:time "Number — unix timestamp (optional)")))) +;; ── patch (DOM fragment patch — borrowed from Datastar) ─────────── +;; A server-driven instruction to morph a region of the client DOM. +;; Subsumes HTMX swap modes; the :body is an SX subtree that the client +;; renders to DOM nodes before applying the mode at the target. +(define + patch-fields + (quote + ((:target "String — CSS selector for the element to patch (required)") + (:mode "Symbol — patch mode (optional, default outer)") + (:body "SX tree — the new content (omitted for mode remove)") + (:transition "Boolean — use a view transition (optional, default false)")))) + +(define + patch-modes + (quote + ((outer "Replace the target's outerHTML (default; the morph target)") + (inner "Replace the target's innerHTML, preserving the wrapper") + (replace "Hard-replace without morphing (no diff, plain swap)") + (prepend "Insert the body as the target's first child") + (append "Insert the body as the target's last child") + (before "Insert the body before the target") + (after "Insert the body after the target") + (remove "Detach the target; :body MUST be absent")))) + +;; ── signals (reactive state patch — borrowed from Datastar) ────── +;; A server-driven update to client-side reactive signals. :values is a +;; dict of signal-name -> new-value; setting a value to nil REMOVES the +;; signal. With :only-if-missing true, existing signals are not touched +;; (use this to lazily initialise signal state without clobbering). +(define + signals-fields + (quote + ((:values "Dict — signal-name -> new-value (required)") + (:only-if-missing + "Boolean — only set signals that don't yet exist (optional, default false)")))) + (define example-navigate (quote @@ -148,6 +184,23 @@ :message "No such post" :retry false))))) +;; A streaming response intermixing patch + signals: the server pushes +;; DOM updates AND signal updates over the same channel. The client +;; dispatches each message by its head symbol; ordering is preserved. +(define + example-patch-stream + (quote + ((request :verb subscribe :path "/cart/live" :capabilities (fetch)) + (response :status ok :stream true) + (signals :values {:cart/count 3 :cart/loading false}) + (patch + :target "#cart-mini" + :mode outer + :body (~cart-mini :count 3 :total 47.50)) + (patch :target "#flash" :mode inner :body (p "Item added.")) + (signals :values {:cart/loading true}) + (patch :target "#cart-loading-spinner" :mode remove)))) + (define example-inspect (quote diff --git a/docker-compose.dev-sx-host.yml b/docker-compose.dev-sx-host.yml new file mode 100644 index 00000000..9aad03ec --- /dev/null +++ b/docker-compose.dev-sx-host.yml @@ -0,0 +1,58 @@ +# host-on-sx live service — the SX web host (lib/host) served by the native +# http-listen server via lib/host/serve.sh. Joins the sx-dev project + externalnet +# so Caddy can reverse_proxy a subdomain to it (blog.rose-ash.com). Isolated from +# the sx_docs server: separate container, separate port. +# +# Usage: +# docker compose -p sx-dev -f docker-compose.dev-sx-host.yml up -d sx_host +# docker compose -p sx-dev -f docker-compose.dev-sx-host.yml logs -f sx_host +# docker compose -p sx-dev -f docker-compose.dev-sx-host.yml down + +services: + sx_host: + image: registry.rose-ash.com:5000/sx_docs:latest + container_name: sx-dev-sx_host-1 + entrypoint: ["bash", "/app/lib/host/serve.sh"] + working_dir: /app + environment: + SX_PROJECT_DIR: /app + SX_SERVER: /app/bin/sx_server + HOST_PORT: "8000" + # Bind all interfaces so Caddy (on externalnet) can reach it. + SX_HTTP_HOST: "0.0.0.0" + # Durable persist store root — on a named volume so data survives restarts. + SX_PERSIST_DIR: /data/persist + # Blog write auth: admin login + session-cookie signing secret. The blog + # write routes (POST /new, POST/PUT/DELETE /posts) are guarded by a session + # login or Bearer token, so these gate publishing. Not a real site — these + # are demo creds; rotate by editing here and recreating the container. + SX_ADMIN_USER: admin + SX_ADMIN_PASSWORD: "sx-host-camper-van-2026" + SX_SESSION_SECRET: "ra-host-sess-7c1f9b3e2a8d4056" + # Serving-mode JIT: bytecode-compile hot SX (esp. the Datalog/relations path) + # on the epoch serving channel. Validated: host conformance 271/271 under JIT, + # 5.4x faster (1m43s -> 19s). Default-OFF gate, opt in here. + SX_SERVING_JIT: "1" + OCAMLRUNPARAM: "b" + volumes: + # SX source (hot-reload on container restart) + - ./spec:/app/spec:ro + - ./lib:/app/lib:ro + - ./web:/app/web:ro + # Client assets for the blog SPA: the WASM OCaml kernel + sx-platform + the + # web-stack modules, served by lib/host/static.sx at /static/**. + - ./shared/static:/app/shared/static:ro + # OCaml server binary — this worktree's build (has the SX_HTTP_HOST bind fix) + - ./hosts/ocaml/_build/default/bin/sx_server.exe:/app/bin/sx_server:ro + # Durable persist store (the SX op-log/kv on disk) — survives restarts. + # Host dir, chowned to the image's appuser (uid 10001) so the non-root + # server can write: sudo mkdir -p /root/sx-host-persist && sudo chown 10001:10001 /root/sx-host-persist + - /root/sx-host-persist:/data/persist + networks: + - externalnet + - default + restart: unless-stopped + +networks: + externalnet: + external: true diff --git a/hosts/ocaml/bin/run_tests.ml b/hosts/ocaml/bin/run_tests.ml index e0431121..36e356d6 100644 --- a/hosts/ocaml/bin/run_tests.ml +++ b/hosts/ocaml/bin/run_tests.ml @@ -2812,10 +2812,13 @@ let run_spec_tests env test_files = | "insertAdjacentHTML" | "prepend" | "showModal" | "show" | "close" | "getBoundingClientRect" | "getAnimations" | "scrollIntoView" | "scrollTo" | "scroll" | "reset" -> Bool true - | "firstElementChild" -> + | "firstElementChild" | "firstChild" -> + (* the mock treats element children and child nodes alike, so + firstChild == firstElementChild — children-to-fragment walks + firstChild to drain a parsed fragment into a swap target. *) let kids = match Hashtbl.find_opt d "children" with Some (List l) -> l | _ -> [] in (match kids with c :: _ -> c | [] -> Nil) - | "lastElementChild" -> + | "lastElementChild" | "lastChild" -> let kids = match Hashtbl.find_opt d "children" with Some (List l) -> l | _ -> [] in (match List.rev kids with c :: _ -> c | [] -> Nil) | "nextElementSibling" | "nextSibling" -> @@ -2961,6 +2964,15 @@ let run_spec_tests env test_files = | "setTimeout" -> (match rest with fn :: _ -> ignore (Sx_ref.cek_call fn (List [])); Nil | _ -> Nil) | "clearTimeout" -> Nil | _ -> Nil) + (* NodeList.item(i) — dom-query-all iterates the querySelectorAll result + (a bare List) via this method, exactly like a browser NodeList. *) + | (List _ | ListRef _) :: String "item" :: [idx] -> + let items = match args with + | List l :: _ -> l + | ListRef { contents = l } :: _ -> l + | _ -> [] in + let i = match idx with Number n -> int_of_float n | Integer n -> n | _ -> -1 in + if i >= 0 && i < List.length items then List.nth items i else Nil | Dict d :: String "hasOwnProperty" :: [String k] -> Bool (Hashtbl.mem d k) | Dict d :: String m :: rest -> @@ -3070,6 +3082,26 @@ let run_spec_tests env test_files = (* console.log/debug/error — no-op in tests *) Nil + else if mt = "domparser" then + (* DOMParser.parseFromString(text, "text/html") — returns a mock + document whose is parsed from `text`. An empty string yields + a valid empty document (truthy), matching the browser: that's what + the engine's handle-html-response relies on for an empty-body + sx-swap="delete" response. *) + (match m with + | "parseFromString" -> + let text = match rest with String t :: _ -> t | _ -> "" in + let bd = match make_mock_element "body" with Dict d -> d | _ -> Hashtbl.create 0 in + Hashtbl.replace bd "tagName" (String "BODY"); + Hashtbl.replace bd "nodeName" (String "BODY"); + parse_html_into bd text; + Hashtbl.replace bd "innerHTML" (String text); + let doc = Hashtbl.create 4 in + Hashtbl.replace doc "__mock_type" (String "document"); + Hashtbl.replace doc "body" (Dict bd); + Dict doc + | _ -> Nil) + else (* Element methods *) (match m with @@ -3483,6 +3515,10 @@ let run_spec_tests env test_files = Dict ev | [String "Object"] -> Dict (Hashtbl.create 4) + | [String "DOMParser"] -> + let d = Hashtbl.create 4 in + Hashtbl.replace d "__mock_type" (String "domparser"); + Dict d | _ -> Nil); reg "host-callback" (fun args -> @@ -3686,6 +3722,7 @@ let run_spec_tests env test_files = load_module "router.sx" web_dir; load_module "deps.sx" web_dir; load_module "orchestration.sx" web_dir; + load_module "console-render.sx" web_dir; (* Library modules for lib/tests/ *) load_module "bytecode.sx" lib_dir; load_module "compiler.sx" lib_dir; diff --git a/hosts/ocaml/bin/sx_server.ml b/hosts/ocaml/bin/sx_server.ml index d1a7dbd3..7c197d99 100644 --- a/hosts/ocaml/bin/sx_server.ml +++ b/hosts/ocaml/bin/sx_server.ml @@ -32,6 +32,14 @@ let () = ignore (Sx_vm_extensions.id_of_name "") which we swallow so a re-entered server process doesn't die. *) let () = try Erlang_ext.register () with Failure _ -> () +(* Ignore SIGPIPE: a client that closes its connection mid-response (a browser + aborting an in-flight fetch — the SX engine cancels superseded requests on a + debounced filter or a fast nav) must NOT kill the server. SIGPIPE's default + action terminates the process before any exception is raised; ignoring it + turns the failed write into a catchable Sys_error (EPIPE), which the + per-connection handler already swallows, dropping just that one connection. *) +let () = try Sys.set_signal Sys.sigpipe Sys.Signal_ignore with _ -> () + (* ====================================================================== *) (* Font measurement via otfm — reads OpenType/TrueType font tables *) (* ====================================================================== *) @@ -522,9 +530,61 @@ let rec load_library_file path = Printf.eprintf "[load-library] %s: %s\n%!" (Filename.basename path) msg ) exprs -(** IO-aware CEK run — handles suspension by dispatching IO requests. - Import requests are handled locally (load .sx file). - Other IO requests are sent to the Python bridge. *) +(* IO-aware CEK run (cek_run_with_io, below) — handles suspension by dispatching + IO requests. Import requests are handled locally (load .sx file). *) +(** Resolve a single IO request value to its response. Shared by + cek_run_with_io's suspension loop AND the _cek_io_resolver installed for the + http-listen serving path, so the synchronous inline-resolve path (sx_vm.ml's + HO-callback suspend fix) resolves durable reads byte-identically to the + CEK-driven path. Without an installed resolver, a `perform` inside an HO + primitive callback (map/filter/…) unwinds the native loop and corrupts the + stack — the host's map/rest/drop serving-JIT miscompile. *) +and resolve_io_request request = + let op = match Sx_runtime.get_val request (String "op") with String s -> s | _ -> "" in + (match op with + | "import" -> + (* Resolve library locally — load the .sx file *) + let lib_spec = Sx_runtime.get_val request (String "library") in + (* library_loaded_p takes the library SPEC and computes the key itself — + passing an already-computed key string double-applies library_name_key + and crashes (sx_to_list on a string). *) + if Sx_types.sx_truthy (Sx_ref.library_loaded_p lib_spec) then + (* Already loaded — just resume *) + Nil + else begin + (match resolve_library_path lib_spec with + | Some path -> load_library_file path + | None -> + Printf.eprintf "[import] WARNING: no file for library %s\n%!" + (Sx_runtime.value_to_str lib_spec)); + Nil + end + | "text-measure" -> + let args = let a = Sx_runtime.get_val request (String "args") in + (match a with List l -> l | _ -> [a]) in + let font = match args with String f :: _ -> f | _ -> "serif" in + let size = match args with + | [_font; Number sz; _text] -> sz + | [_font; Number sz] -> sz + | _ -> 16.0 in + let text = match args with + | [_font; _sz; String t] -> t + | _ -> "" in + let (w, h, asc, desc) = measure_text_otfm font size text in + let d = Hashtbl.create 4 in + Hashtbl.replace d "width" (Number w); + Hashtbl.replace d "height" (Number h); + Hashtbl.replace d "ascent" (Number asc); + Hashtbl.replace d "descent" (Number desc); + Dict d + | _ -> + let argsv = Sx_runtime.get_val request (String "args") in + (match Sx_persist_store.handle_op op argsv with + | Some resp -> resp + | None -> + let args = (match argsv with List l -> l | _ -> [argsv]) in + io_request op args)) + and cek_run_with_io state = let s = ref state in let is_terminal s = match Sx_ref.cek_terminal_p s with Bool true -> true | _ -> false in @@ -535,49 +595,7 @@ and cek_run_with_io state = done; if is_suspended !s then begin let request = Sx_runtime.get_val !s (String "request") in - let op = match Sx_runtime.get_val request (String "op") with String s -> s | _ -> "" in - let response = match op with - | "import" -> - (* Resolve library locally — load the .sx file *) - let lib_spec = Sx_runtime.get_val request (String "library") in - let key = Sx_ref.library_name_key lib_spec in - if Sx_types.sx_truthy (Sx_ref.library_loaded_p key) then - (* Already loaded — just resume *) - Nil - else begin - (match resolve_library_path lib_spec with - | Some path -> load_library_file path - | None -> - Printf.eprintf "[import] WARNING: no file for library %s\n%!" - (Sx_runtime.value_to_str lib_spec)); - Nil - end - | "text-measure" -> - let args = let a = Sx_runtime.get_val request (String "args") in - (match a with List l -> l | _ -> [a]) in - let font = match args with String f :: _ -> f | _ -> "serif" in - let size = match args with - | [_font; Number sz; _text] -> sz - | [_font; Number sz] -> sz - | _ -> 16.0 in - let text = match args with - | [_font; _sz; String t] -> t - | _ -> "" in - let (w, h, asc, desc) = measure_text_otfm font size text in - let d = Hashtbl.create 4 in - Hashtbl.replace d "width" (Number w); - Hashtbl.replace d "height" (Number h); - Hashtbl.replace d "ascent" (Number asc); - Hashtbl.replace d "descent" (Number desc); - Dict d - | _ -> - let argsv = Sx_runtime.get_val request (String "args") in - (match Sx_persist_store.handle_op op argsv with - | Some resp -> resp - | None -> - let args = (match argsv with List l -> l | _ -> [argsv]) in - io_request op args) - in + let response = resolve_io_request request in s := Sx_ref.cek_resume !s response; loop () end else @@ -745,9 +763,27 @@ let setup_evaluator_bridge env = | _ -> raise (Eval_error "http-listen: (port handler)") in let sock = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in Unix.setsockopt sock Unix.SO_REUSEADDR true; + (* Bind host: loopback by default (safe for tests + local runs); set + SX_HTTP_HOST=0.0.0.0 to expose on the network (container/Caddy). *) + let bind_addr = + match Sys.getenv_opt "SX_HTTP_HOST" with + | Some h -> (try Unix.inet_addr_of_string h + with _ -> Unix.inet_addr_loopback) + | None -> Unix.inet_addr_loopback in Unix.bind sock - (Unix.ADDR_INET (Unix.inet_addr_loopback, port)); + (Unix.ADDR_INET (bind_addr, port)); Unix.listen sock 64; + (* Install the synchronous IO resolver for the serving path. Without it, a + `perform` (durable kv read) that fires inside an HO-primitive callback + (map/filter/reduce/…) during request handling suspends through the + native OCaml loop, dropping its iteration state and leaving the stack + misaligned — the serving-JIT host miscompile (map/rest/drop wrong args, + blank pages, empty picker). With a resolver installed, sx_vm.ml resolves + that callback's IO inline (byte-identically to cek_run_with_io) and the + loop is never unwound. Only set if one isn't already installed. *) + (if !Sx_types._cek_io_resolver = None then + Sx_types._cek_io_resolver := + Some (fun request _state -> resolve_io_request request)); (* SX runtime is shared across threads — serialize handler calls. *) let mtx = Mutex.create () in let reason = function @@ -807,9 +843,31 @@ let setup_evaluator_bridge env = Hashtbl.replace req "body" (String body); Mutex.lock mtx; let resp = - (try Sx_runtime.sx_call handler [Dict req] - with e -> Mutex.unlock mtx; raise e) in - Mutex.unlock mtx; + (* Run the handler through the IO-aware CEK runner (not bare + sx_call) so request handlers can perform per-request IO — + durable store reads/writes resolve via cek_run_with_io's + suspension loop instead of returning an unresolved suspension. + On ANY handler exception, synthesise a 500 response rather than + letting it escape: an escaped exception drops the connection + with no bytes written, which a reverse proxy (Caddy/Cloudflare) + surfaces as a 502 error page. A real 500 keeps the origin + responsive and debuggable. Note: a native exception (e.g. the + parser's Parse_error) cannot be caught by an SX (guard ...), so + this boundary is the only place it can be trapped. *) + (try + let st = Sx_ref.continue_with_call handler + (List [Dict req]) (Env (Sx_types.make_env ())) + (List [Dict req]) (List []) in + let r = cek_run_with_io st in + Mutex.unlock mtx; r + with e -> + Mutex.unlock mtx; + Printf.eprintf "[http-listen] handler error: %s\n%!" + (Printexc.to_string e); + let d = Sx_types.make_dict () in + Hashtbl.replace d "status" (Integer 500); + Hashtbl.replace d "body" (String "Internal Server Error"); + Dict d) in let getk k = match resp with | Dict h -> Hashtbl.find_opt h k | _ -> None in let status = match getk "status" with @@ -835,6 +893,18 @@ let setup_evaluator_bridge env = List.iter (fun (k, v) -> Buffer.add_string buf (Printf.sprintf "%s: %s\r\n" k v)) rhdrs; + (* Cookies: a response carries :set-cookies as a LIST of pre-formatted + cookie strings (Dream's dream-set-cookie), because a headers Dict + cannot hold more than one Set-Cookie. Emit one header per item. *) + (match getk "set-cookies" with + | Some (List items) -> + List.iter (fun v -> + match v with + | String s -> + Buffer.add_string buf + (Printf.sprintf "Set-Cookie: %s\r\n" s) + | _ -> ()) items + | _ -> ()); if not (List.exists (fun (k, _) -> String.lowercase_ascii k = "content-type") @@ -1227,6 +1297,20 @@ let setup_type_constructors env = (* Already a value — return as-is *) v | _ -> raise (Eval_error "parse: expected string")); + (* Like parse, but returns nil instead of raising on malformed input. The + parser raises a native Parse_error that an SX-level (guard ...) cannot catch + (guard only traps SX conditions, not host exceptions), so code that handles + untrusted text — e.g. a stored post body — needs a value-returning parse to + degrade gracefully rather than crash the request. *) + bind "parse-safe" (fun args -> + match args with + | [String s] | [SxExpr s] -> + (try + let exprs = Sx_parser.parse_all s in + (match exprs with [e] -> e | _ -> List exprs) + with _ -> Nil) + | [v] -> v + | _ -> Nil); (* Native bytecode compiler — bootstrapped from lib/compiler.sx *) bind "compile" (fun args -> match args with [expr] -> Sx_compiler.compile expr | _ -> Nil); @@ -1714,6 +1798,10 @@ let rec dispatch env cmd = | Nil -> "nil" | Bool true -> "true" | Bool false -> "false" | Number n -> Sx_types.format_number n + (* Bytecode opcodes + arity/upvalue-count are Integers; without this case + they hit the `_ -> "nil"` fallthrough, so every .sxbc came out as + `:bytecode (nil nil ...)` -> "VM: unknown opcode 0" -> source fallback. *) + | Integer n -> string_of_int n | String s -> "\"" ^ escape_sx_string s ^ "\"" | Symbol s -> s | Keyword k -> ":" ^ k | List items | ListRef { contents = items } -> "(" ^ String.concat " " (List.map raw_serialize items) ^ ")" @@ -1741,8 +1829,9 @@ let rec dispatch env cmd = | _ -> "" in let response = if op = "import" then begin let lib_spec = Sx_runtime.get_val request (String "library") in - let key = Sx_ref.library_name_key lib_spec in - if Sx_types.sx_truthy (Sx_ref.library_loaded_p key) then Nil + (* pass the SPEC, not a pre-computed key — library_loaded_p applies + library_name_key itself (a key string would crash sx_to_list). *) + if Sx_types.sx_truthy (Sx_ref.library_loaded_p lib_spec) then Nil else begin (match resolve_library_path lib_spec with | Some path -> load_library_file path | None -> ()); @@ -4901,6 +4990,14 @@ let () = else begin (* Normal persistent server mode *) let env = make_server_env () in + (* render-page: render an (unevaluated) SX page/component expression to HTML + using the server env, so http-listen handlers can serve interactive SX + pages. render-to-html expands components + collects keyword attrs itself; + SX handlers can't reach the server env, so this primitive supplies it. *) + ignore (env_bind env "render-page" (NativeFn ("render-page", fun args -> + match args with + | expr :: _ -> String (sx_render_to_html expr env) + | _ -> raise (Eval_error "render-page: (expr)")))); (* JIT in the epoch serving mode is OPT-IN via SX_SERVING_JIT=1. Default OFF: this mode is the shared command channel used by every loop's conformance runner, and enabling JIT globally regresses diff --git a/hosts/ocaml/browser/bundle.sh b/hosts/ocaml/browser/bundle.sh index 5e833b20..6409992a 100755 --- a/hosts/ocaml/browser/bundle.sh +++ b/hosts/ocaml/browser/bundle.sh @@ -71,6 +71,11 @@ cp "$ROOT/shared/sx/templates/tw-layout.sx" "$DIST/sx/" cp "$ROOT/shared/sx/templates/tw-type.sx" "$DIST/sx/" cp "$ROOT/shared/sx/templates/tw.sx" "$DIST/sx/" +# 9b. Host app components (content-addressed, client-expanded on boosted nav). +# Listed in the host's data-sx-manifest "boot" array so the client eager-loads +# them after the web stack — see lib/host/static.sx + sx-platform.js loadWebStack. +cp "$ROOT/lib/host/sx/relate-picker.sx" "$DIST/sx/" + # 10. Hyperscript for f in tokenizer parser compiler runtime integration htmx; do cp "$ROOT/lib/hyperscript/$f.sx" "$DIST/sx/hs-$f.sx" diff --git a/hosts/ocaml/browser/compile-modules.js b/hosts/ocaml/browser/compile-modules.js index 11c64058..f813bdd0 100644 --- a/hosts/ocaml/browser/compile-modules.js +++ b/hosts/ocaml/browser/compile-modules.js @@ -48,6 +48,8 @@ const SOURCE_MAP = { 'boot.sx': 'web/boot.sx', 'tw-layout.sx': 'web/tw-layout.sx', 'tw-type.sx': 'web/tw-type.sx', 'tw.sx': 'web/tw.sx', 'text-layout.sx': 'lib/text-layout.sx', + // Host app components (content-addressed, client-expanded on boosted nav). + 'relate-picker.sx': 'lib/host/sx/relate-picker.sx', }; let synced = 0; for (const [dist, src] of Object.entries(SOURCE_MAP)) { @@ -87,6 +89,8 @@ const FILES = [ 'hs-tokenizer.sx', 'hs-parser.sx', 'hs-compiler.sx', 'hs-runtime.sx', 'hs-worker.sx', 'hs-prolog.sx', 'hs-integration.sx', 'hs-htmx.sx', + // Host app components — standalone defcomps, no inter-module deps. + 'relate-picker.sx', 'boot.sx', ]; diff --git a/hosts/ocaml/browser/sx-platform.js b/hosts/ocaml/browser/sx-platform.js index 1b873404..69217bdc 100644 --- a/hosts/ocaml/browser/sx-platform.js +++ b/hosts/ocaml/browser/sx-platform.js @@ -646,6 +646,18 @@ // Load entry point itself (boot.sx — not a library, just defines + init) loadBytecodeFile("sx/" + entry.file) || loadSxFile("sx/" + entry.file.replace(/\.sxbc$/, '.sx')); + // App components: the page's data-sx-manifest "boot" array lists app-specific + // modules (e.g. ~relate-picker) to eager-load after the web stack, so their + // defcomps are registered before a boosted fragment references them. Loaded + // content-addressed, the same as any module. + var pageM = loadPageManifest(); + if (pageM && pageM.boot && pageM.boot.length) { + for (var b = 0; b < pageM.boot.length; b++) { + var bf = pageM.boot[b]; + loadBytecodeFile("sx/" + bf) || loadSxFile("sx/" + bf.replace(/\.sxbc$/, '.sx')); + } + } + if (K.endModuleLoad) K.endModuleLoad(); var count = Object.keys(_loadedLibs).length + 1; // +1 for entry var dt = Math.round(performance.now() - t0); diff --git a/hosts/ocaml/browser/sx_browser.ml b/hosts/ocaml/browser/sx_browser.ml index 34d019ad..451d6ed3 100644 --- a/hosts/ocaml/browser/sx_browser.ml +++ b/hosts/ocaml/browser/sx_browser.ml @@ -73,6 +73,7 @@ let rec value_to_js (v : value) : Js.Unsafe.any = | Nil -> Js.Unsafe.inject Js.null | Bool b -> Js.Unsafe.inject (Js.bool b) | Number n -> Js.Unsafe.inject (Js.number_of_float n) + | Integer n -> Js.Unsafe.inject (Js.number_of_float (float_of_int n)) | String s -> Js.Unsafe.inject (Js.string s) | RawHTML s -> Js.Unsafe.inject (Js.string s) | Symbol s -> @@ -329,8 +330,9 @@ let handle_import_suspension request = let lib_spec = match request with | Dict d -> (match Hashtbl.find_opt d "library" with Some v -> v | _ -> Nil) | _ -> Nil in - let key = Sx_ref.library_name_key lib_spec in - if Sx_types.sx_truthy (Sx_ref.library_loaded_p key) then + (* library_loaded_p takes the SPEC and applies library_name_key itself — + passing a pre-computed key string double-applies it and crashes. *) + if Sx_types.sx_truthy (Sx_ref.library_loaded_p lib_spec) then Some Nil (* Already loaded — resume immediately *) else None (* Not loaded — JS platform must fetch it *) diff --git a/hosts/ocaml/lib/sx_cbor.ml b/hosts/ocaml/lib/sx_cbor.ml index b4ec7ba1..97affef6 100644 --- a/hosts/ocaml/lib/sx_cbor.ml +++ b/hosts/ocaml/lib/sx_cbor.ml @@ -15,25 +15,29 @@ exception Cbor_error of string let write_head buf major v = let m = major lsl 5 in + (* Width selection + big-endian byte emission via Int64, so the web targets + compute identically to native: on js_of_ocaml [int] is 32-bit, so the + literal 0x100000000 (2^32) truncates to 0 (sending small values to the + 8-byte branch) and [v lsr (8*i)] with i>=4 is shift-mod-32. Int64 has the + full 64-bit width and well-defined shifts on every target. *) + let v64 = Int64.of_int v in + let put_be nbytes = + for i = nbytes - 1 downto 0 do + Buffer.add_char buf + (Char.chr (Int64.to_int + (Int64.logand (Int64.shift_right_logical v64 (8 * i)) 0xFFL))) + done + in if v < 24 then Buffer.add_char buf (Char.chr (m lor v)) else if v < 0x100 then begin - Buffer.add_char buf (Char.chr (m lor 24)); - Buffer.add_char buf (Char.chr v) + Buffer.add_char buf (Char.chr (m lor 24)); put_be 1 end else if v < 0x10000 then begin - Buffer.add_char buf (Char.chr (m lor 25)); - Buffer.add_char buf (Char.chr ((v lsr 8) land 0xFF)); - Buffer.add_char buf (Char.chr (v land 0xFF)) - end else if v < 0x100000000 then begin - Buffer.add_char buf (Char.chr (m lor 26)); - for i = 3 downto 0 do - Buffer.add_char buf (Char.chr ((v lsr (8 * i)) land 0xFF)) - done + Buffer.add_char buf (Char.chr (m lor 25)); put_be 2 + end else if Int64.compare v64 0x100000000L < 0 then begin + Buffer.add_char buf (Char.chr (m lor 26)); put_be 4 end else begin - Buffer.add_char buf (Char.chr (m lor 27)); - for i = 7 downto 0 do - Buffer.add_char buf (Char.chr ((v lsr (8 * i)) land 0xFF)) - done + Buffer.add_char buf (Char.chr (m lor 27)); put_be 8 end (* dag-cbor map key order: shorter key first, then bytewise. *) diff --git a/hosts/ocaml/lib/sx_cid.ml b/hosts/ocaml/lib/sx_cid.ml index 380fef01..d31a5932 100644 --- a/hosts/ocaml/lib/sx_cid.ml +++ b/hosts/ocaml/lib/sx_cid.ml @@ -32,7 +32,11 @@ let base32_lower (s : string) : string = while !bits >= 5 do bits := !bits - 5; Buffer.add_char buf b32_alpha.[(!acc lsr !bits) land 0x1f] - done) s; + done; + (* Keep only the unconsumed low [bits] bits, so [acc] stays tiny (< 2^13). + Without this it grows by 8 bits per byte and overflows native [int] on + the 32-bit web targets, corrupting the emitted symbols. *) + acc := !acc land ((1 lsl !bits) - 1)) s; if !bits > 0 then Buffer.add_char buf b32_alpha.[(!acc lsl (5 - !bits)) land 0x1f]; Buffer.contents buf diff --git a/hosts/ocaml/lib/sx_ed25519.ml b/hosts/ocaml/lib/sx_ed25519.ml index 0b7a42bc..1a929a6e 100644 --- a/hosts/ocaml/lib/sx_ed25519.ml +++ b/hosts/ocaml/lib/sx_ed25519.ml @@ -68,15 +68,22 @@ let sub (a : bn) (b : bn) : bn = norm r let mul (a : bn) (b : bn) : bn = + (* Accumulate in Int64: a limb product is 26+26 = 52 bits, which overflows the + web targets' int (32-bit js_of_ocaml / 31-bit wasm_of_ocaml). Int64 is a + real 64-bit type on every target, so the carries are exact. *) let la = Array.length a and lb = Array.length b in let r = Array.make (la + lb) 0 in + let maskL = Int64.of_int mask in for i = 0 to la - 1 do - let carry = ref 0 in + let carry = ref 0L in + let ai = Int64.of_int a.(i) in for j = 0 to lb - 1 do - let s = r.(i + j) + a.(i) * b.(j) + !carry in - r.(i + j) <- s land mask; carry := s lsr bits + let s = Int64.add (Int64.add (Int64.of_int r.(i + j)) + (Int64.mul ai (Int64.of_int b.(j)))) !carry in + r.(i + j) <- Int64.to_int (Int64.logand s maskL); + carry := Int64.shift_right_logical s bits done; - r.(i + lb) <- r.(i + lb) + !carry + r.(i + lb) <- r.(i + lb) + Int64.to_int !carry done; norm r @@ -109,12 +116,16 @@ let bn_mod (a : bn) (m : bn) : bn = end let div_small (a : bn) (d : int) : bn = + (* [rem lsl bits] reaches ~2^34 (rem < d <= 256, bits = 26), past the web + targets' int width — accumulate the running remainder in Int64. *) let la = Array.length a in let q = Array.make la 0 in - let rem = ref 0 in + let rem = ref 0L in + let dL = Int64.of_int d in for i = la - 1 downto 0 do - let cur = (!rem lsl bits) lor a.(i) in - q.(i) <- cur / d; rem := cur mod d + let cur = Int64.logor (Int64.shift_left !rem bits) (Int64.of_int a.(i)) in + q.(i) <- Int64.to_int (Int64.div cur dL); + rem := Int64.rem cur dL done; norm q diff --git a/hosts/ocaml/lib/sx_ref.ml b/hosts/ocaml/lib/sx_ref.ml index 2b12cc22..7d1893fb 100644 --- a/hosts/ocaml/lib/sx_ref.ml +++ b/hosts/ocaml/lib/sx_ref.ml @@ -404,7 +404,7 @@ and library_loaded_p spec = (* library-exports *) and library_exports spec = - (get ((get (_library_registry_) ((library_name_key (spec))))) ((String "exports"))) + (let entry = (get (_library_registry_) ((library_name_key (spec)))) in (if sx_truthy (entry) then (get (entry) ((String "exports"))) else (Dict (Hashtbl.create 0)))) (* register-library *) and register_library spec exports = diff --git a/hosts/ocaml/lib/sx_sha2.ml b/hosts/ocaml/lib/sx_sha2.ml index 1ea6b8f8..2eb43e38 100644 --- a/hosts/ocaml/lib/sx_sha2.ml +++ b/hosts/ocaml/lib/sx_sha2.ml @@ -3,37 +3,40 @@ No C stubs, no external deps. Used by the fed-sx host primitives [crypto-sha256] / [crypto-sha512]. Reference: FIPS 180-4. *) -(* ---- SHA-256 (FIPS 180-4 §6.2). 32-bit words held in native int, - masked to 32 bits after every arithmetic op. ---- *) - -let mask32 = 0xFFFFFFFF +(* ---- SHA-256 (FIPS 180-4 §6.2). 32-bit words via Int32, NOT native int. + On the web targets the kernel is compiled by js_of_ocaml (32-bit int) and + wasm_of_ocaml (31-bit int), where native [int] silently truncates the 32-bit + round words — producing WRONG digests (and, downstream, bad CIDs and a + Char.chr crash at kernel init). Int32 has well-defined wrap-around mod 2^32 on + every target, so this matches the 63-bit native build exactly. ---- *) let k256 = [| - 0x428a2f98; 0x71374491; 0xb5c0fbcf; 0xe9b5dba5; - 0x3956c25b; 0x59f111f1; 0x923f82a4; 0xab1c5ed5; - 0xd807aa98; 0x12835b01; 0x243185be; 0x550c7dc3; - 0x72be5d74; 0x80deb1fe; 0x9bdc06a7; 0xc19bf174; - 0xe49b69c1; 0xefbe4786; 0x0fc19dc6; 0x240ca1cc; - 0x2de92c6f; 0x4a7484aa; 0x5cb0a9dc; 0x76f988da; - 0x983e5152; 0xa831c66d; 0xb00327c8; 0xbf597fc7; - 0xc6e00bf3; 0xd5a79147; 0x06ca6351; 0x14292967; - 0x27b70a85; 0x2e1b2138; 0x4d2c6dfc; 0x53380d13; - 0x650a7354; 0x766a0abb; 0x81c2c92e; 0x92722c85; - 0xa2bfe8a1; 0xa81a664b; 0xc24b8b70; 0xc76c51a3; - 0xd192e819; 0xd6990624; 0xf40e3585; 0x106aa070; - 0x19a4c116; 0x1e376c08; 0x2748774c; 0x34b0bcb5; - 0x391c0cb3; 0x4ed8aa4a; 0x5b9cca4f; 0x682e6ff3; - 0x748f82ee; 0x78a5636f; 0x84c87814; 0x8cc70208; - 0x90befffa; 0xa4506ceb; 0xbef9a3f7; 0xc67178f2 |] + 0x428a2f98l; 0x71374491l; 0xb5c0fbcfl; 0xe9b5dba5l; + 0x3956c25bl; 0x59f111f1l; 0x923f82a4l; 0xab1c5ed5l; + 0xd807aa98l; 0x12835b01l; 0x243185bel; 0x550c7dc3l; + 0x72be5d74l; 0x80deb1fel; 0x9bdc06a7l; 0xc19bf174l; + 0xe49b69c1l; 0xefbe4786l; 0x0fc19dc6l; 0x240ca1ccl; + 0x2de92c6fl; 0x4a7484aal; 0x5cb0a9dcl; 0x76f988dal; + 0x983e5152l; 0xa831c66dl; 0xb00327c8l; 0xbf597fc7l; + 0xc6e00bf3l; 0xd5a79147l; 0x06ca6351l; 0x14292967l; + 0x27b70a85l; 0x2e1b2138l; 0x4d2c6dfcl; 0x53380d13l; + 0x650a7354l; 0x766a0abbl; 0x81c2c92el; 0x92722c85l; + 0xa2bfe8a1l; 0xa81a664bl; 0xc24b8b70l; 0xc76c51a3l; + 0xd192e819l; 0xd6990624l; 0xf40e3585l; 0x106aa070l; + 0x19a4c116l; 0x1e376c08l; 0x2748774cl; 0x34b0bcb5l; + 0x391c0cb3l; 0x4ed8aa4al; 0x5b9cca4fl; 0x682e6ff3l; + 0x748f82eel; 0x78a5636fl; 0x84c87814l; 0x8cc70208l; + 0x90befffal; 0xa4506cebl; 0xbef9a3f7l; 0xc67178f2l |] -let rotr32 x n = ((x lsr n) lor (x lsl (32 - n))) land mask32 +let rotr32 (x : int32) (n : int) : int32 = + Int32.logor (Int32.shift_right_logical x n) (Int32.shift_left x (32 - n)) let sha256_hex (msg : string) : string = - let h = [| 0x6a09e667; 0xbb67ae85; 0x3c6ef372; 0xa54ff53a; - 0x510e527f; 0x9b05688c; 0x1f83d9ab; 0x5be0cd19 |] in + let h = [| 0x6a09e667l; 0xbb67ae85l; 0x3c6ef372l; 0xa54ff53al; + 0x510e527fl; 0x9b05688cl; 0x1f83d9abl; 0x5be0cd19l |] in let len = String.length msg in (* Padded length: multiple of 64 bytes. *) - let bitlen = len * 8 in + let bitlen = Int64.mul (Int64.of_int len) 8L in let padlen = let r = (len + 1) mod 64 in if r <= 56 then 56 - r else 120 - r @@ -42,60 +45,79 @@ let sha256_hex (msg : string) : string = let buf = Bytes.make total '\000' in Bytes.blit_string msg 0 buf 0 len; Bytes.set buf len '\x80'; - (* 64-bit big-endian bit length (we cap at OCaml int range). *) + (* 64-bit big-endian bit length. Int64 shifts so the high bytes (shift >= 32) + are correct on the 32-bit web targets — native int `lsr 32` is shift-mod-32 + on js_of_ocaml and would leak the low length byte into a higher word. *) for i = 0 to 7 do Bytes.set buf (total - 1 - i) - (Char.chr ((bitlen lsr (8 * i)) land 0xFF)) + (Char.chr (Int64.to_int + (Int64.logand (Int64.shift_right_logical bitlen (8 * i)) 0xFFL))) done; - let w = Array.make 64 0 in + let byte i = Int32.of_int (Char.code (Bytes.get buf i)) in + let w = Array.make 64 0l in let nblocks = total / 64 in for b = 0 to nblocks - 1 do let base = b * 64 in for t = 0 to 15 do let o = base + t * 4 in w.(t) <- - (Char.code (Bytes.get buf o) lsl 24) - lor (Char.code (Bytes.get buf (o + 1)) lsl 16) - lor (Char.code (Bytes.get buf (o + 2)) lsl 8) - lor (Char.code (Bytes.get buf (o + 3))) + Int32.logor + (Int32.logor + (Int32.shift_left (byte o) 24) + (Int32.shift_left (byte (o + 1)) 16)) + (Int32.logor + (Int32.shift_left (byte (o + 2)) 8) + (byte (o + 3))) done; for t = 16 to 63 do let s0 = - (rotr32 w.(t - 15) 7) lxor (rotr32 w.(t - 15) 18) - lxor (w.(t - 15) lsr 3) in + Int32.logxor + (Int32.logxor (rotr32 w.(t - 15) 7) (rotr32 w.(t - 15) 18)) + (Int32.shift_right_logical w.(t - 15) 3) in let s1 = - (rotr32 w.(t - 2) 17) lxor (rotr32 w.(t - 2) 19) - lxor (w.(t - 2) lsr 10) in - w.(t) <- (w.(t - 16) + s0 + w.(t - 7) + s1) land mask32 + Int32.logxor + (Int32.logxor (rotr32 w.(t - 2) 17) (rotr32 w.(t - 2) 19)) + (Int32.shift_right_logical w.(t - 2) 10) in + w.(t) <- + Int32.add (Int32.add w.(t - 16) s0) (Int32.add w.(t - 7) s1) done; let a = ref h.(0) and bb = ref h.(1) and c = ref h.(2) and d = ref h.(3) and e = ref h.(4) and f = ref h.(5) and g = ref h.(6) and hh = ref h.(7) in for t = 0 to 63 do let s1 = - (rotr32 !e 6) lxor (rotr32 !e 11) lxor (rotr32 !e 25) in - let ch = (!e land !f) lxor ((lnot !e land mask32) land !g) in - let t1 = (!hh + s1 + ch + k256.(t) + w.(t)) land mask32 in + Int32.logxor + (Int32.logxor (rotr32 !e 6) (rotr32 !e 11)) (rotr32 !e 25) in + let ch = + Int32.logxor (Int32.logand !e !f) + (Int32.logand (Int32.lognot !e) !g) in + let t1 = + Int32.add + (Int32.add (Int32.add !hh s1) (Int32.add ch k256.(t))) w.(t) in let s0 = - (rotr32 !a 2) lxor (rotr32 !a 13) lxor (rotr32 !a 22) in - let maj = (!a land !bb) lxor (!a land !c) lxor (!bb land !c) in - let t2 = (s0 + maj) land mask32 in + Int32.logxor + (Int32.logxor (rotr32 !a 2) (rotr32 !a 13)) (rotr32 !a 22) in + let maj = + Int32.logxor + (Int32.logxor (Int32.logand !a !bb) (Int32.logand !a !c)) + (Int32.logand !bb !c) in + let t2 = Int32.add s0 maj in hh := !g; g := !f; f := !e; - e := (!d + t1) land mask32; + e := Int32.add !d t1; d := !c; c := !bb; bb := !a; - a := (t1 + t2) land mask32 + a := Int32.add t1 t2 done; - h.(0) <- (h.(0) + !a) land mask32; - h.(1) <- (h.(1) + !bb) land mask32; - h.(2) <- (h.(2) + !c) land mask32; - h.(3) <- (h.(3) + !d) land mask32; - h.(4) <- (h.(4) + !e) land mask32; - h.(5) <- (h.(5) + !f) land mask32; - h.(6) <- (h.(6) + !g) land mask32; - h.(7) <- (h.(7) + !hh) land mask32 + h.(0) <- Int32.add h.(0) !a; + h.(1) <- Int32.add h.(1) !bb; + h.(2) <- Int32.add h.(2) !c; + h.(3) <- Int32.add h.(3) !d; + h.(4) <- Int32.add h.(4) !e; + h.(5) <- Int32.add h.(5) !f; + h.(6) <- Int32.add h.(6) !g; + h.(7) <- Int32.add h.(7) !hh done; let out = Buffer.create 64 in - Array.iter (fun x -> Buffer.add_string out (Printf.sprintf "%08x" x)) h; + Array.iter (fun x -> Buffer.add_string out (Printf.sprintf "%08lx" x)) h; Buffer.contents out (* ---- SHA-512 (FIPS 180-4 §6.4). 64-bit words via Int64. @@ -146,7 +168,7 @@ let sha512_hex (msg : string) : string = 0x510e527fade682d1L; 0x9b05688c2b3e6c1fL; 0x1f83d9abfb41bd6bL; 0x5be0cd19137e2179L |] in let len = String.length msg in - let bitlen = len * 8 in + let bitlen = Int64.mul (Int64.of_int len) 8L in (* Pad to a multiple of 128 bytes; 16-byte big-endian length. *) let padlen = let r = (len + 1) mod 128 in @@ -156,9 +178,12 @@ let sha512_hex (msg : string) : string = let buf = Bytes.make total '\000' in Bytes.blit_string msg 0 buf 0 len; Bytes.set buf len '\x80'; + (* Low 64 bits of the bit length (high 64 stay 0). Int64 shifts so the bytes + at shift >= 32 are correct on the 32-bit web targets (js shift-mod-32). *) for i = 0 to 7 do Bytes.set buf (total - 1 - i) - (Char.chr ((bitlen lsr (8 * i)) land 0xFF)) + (Char.chr (Int64.to_int + (Int64.logand (Int64.shift_right_logical bitlen (8 * i)) 0xFFL))) done; let w = Array.make 80 0L in let nblocks = total / 128 in diff --git a/lib/dream/form.sx b/lib/dream/form.sx index 1593b698..1862bbe5 100644 --- a/lib/dream/form.sx +++ b/lib/dream/form.sx @@ -58,6 +58,43 @@ ((s2 (replace s "+" " "))) (dr/url-decode-loop s2 0 (string-length s2) "")))) +;; ── percent encoding (symmetric with dr/url-decode) ──────────────── +;; RFC3986 unreserved set passes through; everything else is %XX (uppercase +;; hex). Space becomes %20 (not +), so the result is safe in a query value. +(define dr/hex-chars "0123456789ABCDEF") +(define + dr/url-encode-char + (fn + (c) + (let + ((n (char-code c))) + (if + (or + (and (>= n 48) (<= n 57)) ;; 0-9 + (and (>= n 65) (<= n 90)) ;; A-Z + (and (>= n 97) (<= n 122)) ;; a-z + (= c "-") (= c "_") (= c ".") (= c "~")) + c + (str "%" + (char-at dr/hex-chars (quotient n 16)) + (char-at dr/hex-chars (mod n 16))))))) + +(define + dr/url-encode-loop + (fn + (s i n acc) + (if + (>= i n) + acc + (dr/url-encode-loop s (+ i 1) n + (str acc (dr/url-encode-char (char-at s i))))))) + +(define + dr/url-encode + (fn + (s) + (dr/url-encode-loop (or s "") 0 (string-length (or s "")) ""))) + ;; ── substring splitter (split primitive is char-class based) ─────── (define dr/split-on diff --git a/lib/host/auth.sx b/lib/host/auth.sx new file mode 100644 index 00000000..499808de --- /dev/null +++ b/lib/host/auth.sx @@ -0,0 +1,153 @@ +;; lib/host/auth.sx — browser login on top of host sessions (lib/host/session.sx). +;; A login form posts credentials; on success the principal is written to the +;; session cookie. The guarded write routes then accept EITHER a logged-in session +;; OR a Bearer token (host/require-user), so the same routes serve browsers and API +;; clients. Single admin user; credentials come from $SX_ADMIN_USER / _PASSWORD +;; (set in serve.sh) — the in-source defaults are dev-only. +;; +;; Depends on lib/host/session.sx, lib/host/{handler,middleware}.sx, lib/dream/* +;; (form/types/session) + the kernel render-page primitive. + +;; ── page shell (own copy; render-page renders the static SX tree) ─── +(define host/-auth-page + (fn (title body) + (str "" + (render-page + (quasiquote + (html + (head (meta :charset "utf-8") (title (unquote title))) + (body (unquote body)))))))) + +;; ── admin credential (override from env in serve.sh) ──────────────── +(define host/admin-user "admin") +(define host/admin-password "letmein") +(define host/auth-set-admin! + (fn (u p) (begin (set! host/admin-user u) (set! host/admin-password p)))) +(define host/-verify-cred + (fn (user pass) + (and (not (= pass "")) + (= user host/admin-user) + (= pass host/admin-password)))) + +;; A return-to target is only honoured if it's a same-site absolute PATH — guards +;; against an open-redirect (//evil.com, http://…) smuggled through ?next=. +(define host/-safe-next + (fn (n) + (if (and n (not (= n "")) (starts-with? n "/") (not (starts-with? n "//"))) + n "/"))) + +;; The login form, parameterised by where to return after success. +(define host/-login-form + (fn (next-path message) + (host/-auth-page "Log in" + (quasiquote + (div + (h1 "Log in") + (unquote (if message (quasiquote (p :style "color:#b00" (unquote message))) "")) + (form :method "post" :action "/login" + (input :type "hidden" :name "next" :value (unquote next-path)) + (p (input :name "username" :placeholder "username")) + (p (input :name "password" :type "password" :placeholder "password")) + (p (button :type "submit" "Log in"))) + ;; a way back into the app — the login shell is a standalone page (no persistent + ;; nav), so without this a logged-out user who followed a guarded link is stranded. + (p :style "margin-top:1em" (a :href "/" "← Home"))))))) + +;; ── GET /login — login form, honouring ?next= (where to go after login) ───── +(define host/login-page + (fn (req) + (dream-html + (host/-login-form (host/-safe-next (dream-query-param req "next")) nil)))) + +;; ── POST /login — verify, write session principal, redirect to ?next ──────── +;; The session middleware (host/sessions) has already created/loaded the session +;; and will set the cookie on this response, so writing :principal here lands on +;; the right sid and the browser keeps the cookie. On failure the form re-renders +;; with the same return target so the user lands where they were headed. +(define host/login-submit + (fn (req) + (let ((user (host/field req "username")) + (pass (host/field req "password")) + (next-path (host/-safe-next (host/field req "next")))) + (if (host/-verify-cred user pass) + (begin + (host/login! req user) + (dream-redirect next-path)) + (dream-html-status 401 + (host/-login-form next-path "Invalid credentials — try again.")))))) + +;; ── /logout — clear the session, redirect home. Allowed on GET too so a plain +;; footer link can log out (logout is low-harm, so GET is acceptable here). ───── +(define host/logout-submit + (fn (req) + (begin + (host/logout! req) + (dream-redirect "/")))) + +;; ── login routes (mounted by host/make-app) ───────────────────────── +(define host/auth-routes + (list + (dream-get "/login" host/login-page) + (dream-post "/login" host/login-submit) + (dream-get "/logout" host/logout-submit) + (dream-post "/logout" host/logout-submit))) + +;; ── auth footer fragment ──────────────────────────────────────────── +;; A small SX node pages splice into their footer: "log in" when logged out, +;; "signed in as · log out" when logged in. Guards a session-less request +;; (no middleware) so it's safe to call anywhere. Reads the session principal. +(define host/auth-footer + (fn (req) + (let ((who (if (get req :dream-session) (host/current-principal req) nil))) + (if (and who (not (= who ""))) + (quasiquote + (span (unquote (str "signed in as " who)) " · " + (a :href "/logout" "log out"))) + (quote (a :href "/login" "log in")))))) + +;; The authenticated principal for a request, or nil: a logged-in session takes +;; precedence, else a Bearer token resolved by `resolve` (the API fallback). +(define host/-principal-of + (fn (req resolve) + (let ((sp (host/current-principal req))) + (if (and sp (not (= sp ""))) + sp + (let ((tok (dream-bearer-token req))) + (if tok (resolve tok) nil)))))) + +;; ── auth middleware (API shape): session principal OR bearer token ── +;; Place AFTER the session middleware (so host/current-principal can read the +;; session) and BEFORE host/require-permission. On failure -> JSON 401 with a +;; Bearer challenge. For API/JSON routes; browser pages want host/require-login. +(define host/require-user + (fn (resolve) + (fn (next) + (fn (req) + (let ((principal (host/-principal-of req resolve))) + (if (or (nil? principal) (= principal "")) + (dream-add-header + (host/error 401 "unauthorized") + "www-authenticate" "Bearer") + (next (assoc req :dream-principal principal)))))))) + +;; ── auth middleware (browser shape): same check, but on failure REDIRECT to +;; the login page with a return-to, instead of a raw JSON 401. Use this for HTML +;; routes (an edit form, the create form) so an unauthenticated click lands on a +;; usable login page and returns to where it was headed after logging in. ── +(define host/require-login + (fn (resolve) + (fn (next) + (fn (req) + (let ((principal (host/-principal-of req resolve))) + (if (or (nil? principal) (= principal "")) + (let ((login-url (str "/login?next=" (host/-safe-next (dream-path req))))) + ;; A BOOSTED (SX-Request) request can't be answered with a 303: the browser's + ;; fetch follows the redirect WITHOUT the SX-Request header, so /login returns + ;; the full HTML shell, which morphed into #content DESTROYS the SPA swap target + ;; (every later boosted nav then has nowhere to swap — "nothing happens"). Return + ;; an SX-Redirect header instead — the engine does a FULL navigation to /login (a + ;; fresh shell). A non-boosted request still gets a plain 303. + (if (= (dream-header req "sx-request") "true") + (dream-response 200 {:sx-redirect login-url} "") + (dream-redirect login-url))) + (next (assoc req :dream-principal principal)))))))) diff --git a/lib/host/blog.sx b/lib/host/blog.sx new file mode 100644 index 00000000..52433dc1 --- /dev/null +++ b/lib/host/blog.sx @@ -0,0 +1,2624 @@ +;; lib/host/blog.sx — Blog domain on the host, on the EDITOR's content model. +;; The SX post editor (blog/sx/editor.sx) emits `sx_content`: SX element markup +;; (e.g. "(article (h1 \"T\") (p \"body\" (strong \"x\")))"), NOT content-on-sx +;; CtDoc blocks. So a post here is a record {slug,title,sx_content,status} stored +;; in the durable persist KV, and a post page is `render-to-html (parse sx_content)` +;; — server-side, static, no client runtime needed to view a published post. +;; +;; GET / HTML index of posts (public) +;; GET // rendered post (public) -> HTML / 404 +;; GET /posts SX list (public) -> {:ok true :data ({:slug …} …)} +;; GET /new HTML create form (public chrome) +;; POST /new form ingest from the editor (guarded) +;; POST //edit form ingest, edit an existing post (guarded) +;; Reads anonymous; writes behind the auth+ACL pipeline ("edit" on "blog"). The +;; JSON CRUD /posts (POST/PUT/DELETE) was deleted in the SX-native pivot — the wire +;; is SX/SXTP (host/ok emits text/sx), writes go through the form ingest. +;; Depends on spec/render + web/adapter-html (render-to-html), lib/persist/* +;; (durable KV), lib/dream/* (+ form), lib/host/{handler,middleware}.sx. + +;; ── store (durable persist KV, injectable) ────────────────────────── +(define host/blog-store (persist/open)) +(define host/blog-use-store! (fn (b) (set! host/blog-store b))) +(define host/blog--key (fn (slug) (str "blog:" slug))) + +;; ── content-addressing: a universal CID over the canonical form ───── +;; Every object (content/type/relation/constraint post) carries a stable :cid = +;; hash of its CONTENT. The runtime has no hash primitive, so the canon serializer +;; and a tail-recursive double-hash are built here. Canon SORTS keys, so the CID is +;; identical across processes regardless of dict insertion / hash-seed order. The +;; :slug (a mutable name) and any prior :cid are excluded — the CID hashes content +;; only. git-shaped: slug = mutable name -> CID = immutable content identity. +(define host/blog--canon + (fn (v) + (let ((t (type-of v))) + (cond + ((= t "dict") + (str "{" (join "|" + (map (fn (k) (str k "=" (host/blog--canon (get v k)))) + (filter (fn (k) (and (not (= k "slug")) (not (= k "cid")))) + (sort (keys v))))) "}")) + ((= t "list") (str "[" (join "|" (map host/blog--canon v)) "]")) + ((= t "nil") "~") + (else (str v)))))) +(define host/blog--hash-go + (fn (s i n h1 h2) + (if (>= i n) + (str h1 "-" h2) + (let ((c (char-code (substr s i 1)))) + (host/blog--hash-go s (+ i 1) n + (mod (+ (* h1 131) c) 1000000007) + (mod (+ (* h2 137) c) 998244353)))))) +(define host/blog--cid-of + (fn (rec) (let ((s (host/blog--canon rec))) (str "z" (host/blog--hash-go s 0 (len s) 7 11))))) +;; the single choke point for every record write: stamps the content CID, then puts. +(define host/blog--write! + (fn (slug rec) + (persist/backend-kv-put host/blog-store (host/blog--key slug) + (merge rec {:cid (host/blog--cid-of rec)})))) + +;; slug from a title: lowercase, words joined by '-'. (Punctuation kept simple.) +(define host/blog-slugify + (fn (title) + (join "-" (filter (fn (w) (not (= w ""))) (split (lower title) " "))))) + +;; ── records ───────────────────────────────────────────────────────── +(define host/blog-get + (fn (slug) (persist/backend-kv-get host/blog-store (host/blog--key slug)))) +(define host/blog-exists? + (fn (slug) (persist/backend-kv-has? host/blog-store (host/blog--key slug)))) +;; A write preserves any extra slots already on the record (:rel for relation-posts, +;; :schema for refinement types) — merging over the previous record — so editing a +;; post's title/content/status doesn't nuke the metadata that lives alongside it. +(define host/blog-put! + (fn (slug title sx-content status) + (let ((prev (host/blog-get slug))) + (host/blog--write! slug + (merge (if prev prev {}) + {:slug slug :title title :sx-content sx-content :status status}))))) +(define host/blog-delete! + (fn (slug) (persist/backend-kv-delete host/blog-store (host/blog--key slug)))) +(define host/blog-seed! + (fn (slug title sx-content status) + (when (not (host/blog-exists? slug)) (host/blog-put! slug title sx-content status)))) + +;; all blog slugs (kv keys are "blog:") +(define host/blog-slugs + (fn () + (reduce + (fn (acc k) + (if (starts-with? k "blog:") (append acc (list (substr k 5))) acc)) + (list) + (persist/backend-kv-keys host/blog-store)))) +(define host/blog-list + (fn () + (map + (fn (slug) + (let ((r (host/blog-get slug))) + {:slug slug :title (get r :title) :status (get r :status)})) + (host/blog-slugs)))) + +;; a post's content CID — its global, location-independent identity (nil if unknown). +(define host/blog-cid (fn (slug) (get (host/blog-get slug) :cid))) +;; reverse lookup: a slug whose record has this CID (nil if none). Scan; not for renders. +(define host/blog-by-cid + (fn (cid) + (reduce + (fn (acc slug) (if acc acc (if (= (host/blog-cid slug) cid) slug acc))) + nil (host/blog-slugs)))) + +;; ── render ────────────────────────────────────────────────────────── +;; A post's sx_content is SX element markup -> HTML via render-page (which supplies +;; the server env so components resolve + keyword attrs are kept). +;; +;; Rendered PER BLOCK and guarded: the editor wraps content in a (<> ...) fragment +;; of blocks, some of which the host can't render (the legacy editor emits bare +;; ~kg-md cards while the components are ~kg_cards/kg-md — drift we don't paper over +;; with aliases). Rendering each block under its own guard means the real prose +;; (p/h1/ul/...) shows and only the unsupported block degrades to a placeholder — +;; and a bad block never crashes the handler (-> 502). +(define host/blog--render-node + (fn (node) + (guard (e (true "
(unsupported block)
")) + (render-page node)))) +(define host/blog-render + (fn (record) + (let ((sx (get record :sx-content))) + (if (and sx (not (= sx ""))) + (let ((tree (parse-safe sx))) + (cond + ((nil? tree) "

(unparseable content)

") + ((and (= (type-of tree) "list") (> (len tree) 0) + (= (str (first tree)) "<>")) + (join "" (map host/blog--render-node (rest tree)))) + (else (host/blog--render-node tree)))) + (str "

(empty post)

"))))) +;; ── related posts (blog × relations) ──────────────────────────────── +;; 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)))) + +;; Relations are POSTS (plans/relations-as-posts.md). Each relation-post is-a +;; `relation` and owns its metadata in a :rel slot {:symmetric :label +;; :inverse-label}. To keep RENDER paths perform-free — a durable read inside the +;; http-listen render VM raises VmSuspended — the relation specs are loaded into an +;; in-memory cache at boot, exactly like edges (host/blog-load-edges!). kind-spec / +;; rel-kinds / kind-symmetric? then read the cache (pure); the relation-posts stay +;; the durable source of truth. host/blog-load-rel-kinds! re-reads them. +(define host/blog--rel-cache (dict)) +;; cache one relation-post's :rel metadata (+ :kind), keyed by slug. +(define host/blog--cache-rel! + (fn (kind) + (let ((m (get (host/blog-get kind) :rel))) + (when m (dict-set! host/blog--rel-cache kind (merge {:kind kind} m)))))) +;; host/blog-rel-kinds is a VALUE (the list of relation specs), populated at boot by +;; load-rel-kinds! — like slice 1's static registry, which mapped fine on the live +;; serving JIT. (Computing it as a function that map/for-each-es a function-produced +;; list silently lost 3 of 4 relations on the live JIT — see plans/relations-as-posts.md +;; / plans/jit-bytecode-correctness.md. Both the cache loads and the list build are +;; therefore UNROLLED — no iteration over the relation list.) Metadata still lives on +;; the relation-posts; add a relation = a seed-rel! + a line in each unrolled list. +(define host/blog-rel-kinds (list)) +;; UNROLLED, and it must STAY unrolled: load-rel-kinds! runs at BOOT, where it is +;; JIT-compiled but the http-listen IO resolver is NOT yet installed (that happens when +;; serving starts). The serving-JIT HO-callback-perform fix (81177d0e) only engages WITH +;; the resolver, so a dynamic loader (map/for-each/reduce over instances-of "relation" +;; with a durable read per item) silently returns [] at boot — verified 2026-06-30: +;; dynamic loader -> /meta Relations(0). So the cache loads + the list are UNROLLED (no +;; HO over a function-produced list). A new relation is a seed-rel! + a line here; or +;; appended at RUNTIME (where the resolver IS installed) — see host/blog-meta-new-relation. +(define host/blog-load-rel-kinds! + (fn () + (begin + (host/blog--cache-rel! "related") + (host/blog--cache-rel! "is-a") + (host/blog--cache-rel! "subtype-of") + (host/blog--cache-rel! "tagged") + (set! host/blog-rel-kinds + (list (get host/blog--rel-cache "related") (get host/blog--rel-cache "is-a") + (get host/blog--rel-cache "subtype-of") (get host/blog--rel-cache "tagged")))))) +;; spec = the cached :rel metadata + :kind; nil for a non-relation (relate validates). +(define host/blog--kind-spec (fn (kind) (get host/blog--rel-cache kind))) +(define host/blog--kind-symmetric? + (fn (kind) (let ((s (host/blog--kind-spec kind))) (and s (get s :symmetric))))) + +;; ── edges (parameterised by kind, DURABLE, KV-only) ───────────────── +;; The blog graph is the durable KV: every edge is a row "edge:||" in the +;; blog store, and ALL reads walk those rows directly (host/blog--all-edges / -out / -in / +;; --subtype-closure). It is NOT mirrored into lib/relations: relations/relate re-saturates +;; the whole Datalog ruleset on EVERY write (super-linear in the fact base — profiled at +;; 1→3→6s per edge as the graph grows), and since typing now reads direct KV edges, nothing +;; in the blog domain reads lib/relations, so the mirror was pure (very expensive) dead +;; weight. KV-only edge writes are ~20ms flat. '|' is a safe delimiter — slugs are +;; [a-z0-9-], kinds are registry names. (host/relations.sx, the relations DOMAIN service, is +;; separate: its own "type:id" nodes in lib/relations, untouched by this.) +(define host/blog--edge-key (fn (src kind dst) (str "edge:" src "|" kind "|" dst))) + +(define host/blog--add-edge! + (fn (src dst kind) + (persist/backend-kv-put host/blog-store (host/blog--edge-key src kind dst) 1))) +(define host/blog--del-edge! + (fn (src dst kind) + (persist/backend-kv-delete host/blog-store (host/blog--edge-key src kind dst)))) + +;; 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) + (begin + (host/blog--add-edge! a b kind) + (when (host/blog--kind-symmetric? kind) (host/blog--add-edge! b a kind))))) +(define host/blog-unrelate! + (fn (a b kind) + (begin + (host/blog--del-edge! a b kind) + (when (host/blog--kind-symmetric? kind) (host/blog--del-edge! b a kind))))) + +;; No-op: the durable KV edge rows ARE the graph and every read walks them directly, so +;; there is no in-memory lib/relations graph to rebuild on boot. (Kept as a callable seam — +;; serve.sh calls it after pointing the store at the durable backend — in case a future +;; index/cache needs warming.) Previously this replayed every edge into lib/relations via +;; relations/relate, which re-saturated the Datalog ruleset per edge: O(edges²) boot cost. +(define host/blog-load-edges! (fn () nil)) + +;; 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))) + (filter (fn (s) (contains? existing s)) + (map (fn (n) (substr (symbol->string n) 5)) + (filter (fn (n) (starts-with? (symbol->string n) "blog:")) nodes)))))) + +;; DIRECT edges come from the durable edge store, NOT lib/relations: each relations +;; query re-runs the (CEK-interpreted) ruleset — ~seconds even on a tiny graph — +;; whereas the edge:|| KV rows are a cheap string scan. lib/relations +;; is reserved for TRANSITIVE queries (descendants/ancestors). The two are always +;; in sync: host/blog-relate! writes both, and a plain blog edge has no derived +;; effective edges, so KV == relations/children for direct lookups. +(define host/blog--parse-edge-key + (fn (k) + (if (starts-with? k "edge:") + (let ((body (substr k 5))) + (let ((p1 (index-of body "|"))) + (if (< p1 0) nil + (let ((rest (substr body (+ p1 1)))) + (let ((p2 (index-of rest "|"))) + (if (< p2 0) nil + {:src (substr body 0 p1) + :kind (substr rest 0 p2) + :dst (substr rest (+ p2 1))})))))) + nil))) +(define host/blog--all-edges + (fn () + (filter (fn (e) (not (nil? e))) + (map host/blog--parse-edge-key (persist/backend-kv-keys host/blog-store))))) + +;; outgoing targets / incoming sources of `slug` under `kind`, as existing slugs. +(define host/blog-out + (fn (slug kind) + (let ((existing (host/blog-slugs))) + (filter (fn (s) (contains? existing s)) + (reduce (fn (acc e) + (if (and (= (get e :src) slug) (= (get e :kind) kind)) + (concat acc (list (get e :dst))) acc)) + (list) (host/blog--all-edges)))))) +(define host/blog-in + (fn (slug kind) + (let ((existing (host/blog-slugs))) + (filter (fn (s) (contains? existing s)) + (reduce (fn (acc e) + (if (and (= (get e :dst) slug) (= (get e :kind) kind)) + (concat acc (list (get e :src))) acc)) + (list) (host/blog--all-edges)))))) + +;; back-compat: "related posts" is just the symmetric "related" kind. +(define host/blog-related (fn (slug) (host/blog-out slug "related"))) + +;; ── typing: is-a + subtype-of with subsumption ────────────────────── +;; Typing is just relating to a type, and types ARE posts. A post DECLARES its +;; types with is-a edges; types form a hierarchy with subtype-of edges. is-a +;; (instance-of) is NOT transitive on its own, but subsumption is: an instance of +;; a subtype is an instance of the supertype. So a post's full type set is its +;; declared types PLUS every subtype-of-ancestor of each. +;; +;; PERF: the subtype closure is computed HOST-SIDE by a BFS over the DIRECT subtype-of +;; edges (the edge:* KV rows), NOT via lib/relations descendants/ancestors. Each lib/ +;; relations query re-saturates the whole (CEK-interpreted) Datalog ruleset — ~seconds +;; even on a tiny graph — and typing is on the hottest path (is-a?/types-of/instances-of +;; run per post, per picker, per render), so re-saturation made the blog suite + live +;; pages CPU-bound. The closure is the SAME transitive set; one edge-store snapshot drives +;; the whole BFS (O(edges), cycle-safe). KV == relations for direct edges (host/blog-relate! +;; writes both), so this is exact, not an approximation. +(define host/blog--uniq + (fn (xs) (reduce (fn (acc x) (if (contains? acc x) acc (concat acc (list x)))) (list) xs))) + +;; transitive closure over DIRECT subtype-of edges from `roots` (roots included), with NO +;; Datalog. dir :out = follow src->dst (the supertypes of roots); dir :in = follow dst->src +;; (the subtypes of roots). One host/blog--all-edges snapshot; BFS with a `seen` guard. +(define host/blog--subtype-closure + (fn (roots dir) + (let ((edges (host/blog--all-edges)) (existing (host/blog-slugs))) + (let ((step + (fn (n) + (filter (fn (s) (contains? existing s)) + (reduce (fn (acc e) + (if (and (= (get e :kind) "subtype-of") + (= (get e (if (= dir :out) :src :dst)) n)) + (concat acc (list (get e (if (= dir :out) :dst :src)))) acc)) + (list) edges))))) + (let loop ((frontier roots) (seen (list))) + (if (empty? frontier) + seen + (let ((n (first frontier))) + (if (contains? seen n) + (loop (rest frontier) seen) + (loop (concat (rest frontier) (step n)) (concat seen (list n))))))))))) + +(define host/blog-types-of + (fn (slug) + (host/blog--uniq (host/blog--subtype-closure (host/blog-out slug "is-a") :out)))) + +;; is this post (transitively) of the given type-slug? +(define host/blog-is-a? (fn (slug type) (contains? (host/blog-types-of slug) type))) + +;; all posts that are (transitively) instances of `type`: instances of the type +;; itself plus instances of any of its subtypes. O(edges) over one snapshot — the +;; efficient way to enumerate a type's members (e.g. "all tags") for the picker. +(define host/blog-instances-of + (fn (type) + (host/blog--uniq + (reduce (fn (acc t) (concat acc (host/blog-in t "is-a"))) + (list) (host/blog--subtype-closure (list type) :in))))) + +;; All type-posts: the subtype-of hierarchy rooted at "type" (type + its transitive +;; subtypes). This is "the types you've DEFINED" — distinct from host/blog-instances-of +;; "type" (which is the is-a INSTANCES of the type, i.e. typed content, not the type +;; definitions; the definitions are linked by subtype-of). Used by the metamodel editor. +(define host/blog-type-defs + (fn () (host/blog--uniq (host/blog--subtype-closure (list "type") :in)))) + +;; ── Slice 4: type ALGEBRA — intersection (∧) and union (∨) types ───── +;; An algebraic type is a post with operand edges: a `conj` edge per intersection +;; member, a `disj` edge per union member. Its EXTENT is its operands' extents combined +;; by set intersection / union, recursively — so types compose into an algebra in the +;; same graph (meta-circular: an algebraic type is just another post). Binary today +;; (nth 0/1, no fold over operands — robust on the serving JIT); n-ary is a follow-up. +;; is-a-expr? generalises is-a? to type expressions. +(define host/blog--set-intersect + (fn (xs ys) (filter (fn (x) (contains? ys x)) xs))) +;; operand edges live in the KV ONLY (read back via host/blog-out), NOT in lib/relations: +;; conj/disj are structural, and feeding extra kinds into the Datalog graph blows up its +;; per-query re-saturation. host/blog-load-edges! skips them on replay for the same reason. +(define host/blog--add-edge-kv! + (fn (src dst kind) + (persist/backend-kv-put host/blog-store (host/blog--edge-key src kind dst) 1))) +(define host/blog-make-and! + (fn (t a b) + (begin + (host/blog-seed! t t + (str "(article (h1 \"" t "\") (p \"An intersection type (" a " ∧ " b ") — its instances are exactly those that are instances of BOTH.\"))") + "published") + (host/blog--add-edge-kv! t a "conj") + (host/blog--add-edge-kv! t b "conj")))) +(define host/blog-make-or! + (fn (t a b) + (begin + (host/blog-seed! t t + (str "(article (h1 \"" t "\") (p \"A union type (" a " ∨ " b ") — its instances are those that are instances of EITHER.\"))") + "published") + (host/blog--add-edge-kv! t a "disj") + (host/blog--add-edge-kv! t b "disj")))) +;; the EXTENT of a type expression: operands' extents combined by set ops (recursive). +;; A plain type (no operands) falls through to its instances. +(define host/blog-instances-of-expr + (fn (t) + (let ((conj (host/blog-out t "conj")) + (disj (host/blog-out t "disj"))) + (cond + ((>= (len conj) 2) + (host/blog--set-intersect (host/blog-instances-of-expr (nth conj 0)) + (host/blog-instances-of-expr (nth conj 1)))) + ((>= (len disj) 2) + (host/blog--uniq (concat (host/blog-instances-of-expr (nth disj 0)) + (host/blog-instances-of-expr (nth disj 1))))) + (else (host/blog-instances-of t)))))) +;; is `slug` a member of the type expression `t`? Generalises is-a? to the algebra. +(define host/blog-is-a-expr? + (fn (slug t) (contains? (host/blog-instances-of-expr t) slug))) + +;; ── tags (a tag is a post that is-a tag) ──────────────────────────── +(define host/blog-is-tag? (fn (slug) (host/blog-is-a? slug "tag"))) +(define host/blog-tags (fn (slug) (host/blog-out slug "tagged"))) ;; a post's tags +(define host/blog-tagged-with (fn (tag) (host/blog-in tag "tagged"))) ;; posts with a tag + +;; ── gradual validation: refinement types (schemas ON the type-post) ── +;; A type-post may carry a SCHEMA in a :schema slot: a list of rules +;; {:block :msg }, each requiring the content to contain (anywhere) an +;; element of that tag — i.e. a refinement type {x : T | x has these blocks}. A post +;; is checked against the schema of every type it is-a; a type with no schema imposes +;; nothing (gradual). Schemas are declarative data (not opaque predicates), so they +;; yield a specific, human error AND live on the type-post (Slice 5) — make a new +;; refinement type by giving its post a :schema (host/blog--set-schema!). +;; schema-of reads the type-post; only the SAVE path calls it (a write request, where +;; a durable read is fine — never in a render, which would VmSuspend). +(define host/blog-schema-of (fn (type-slug) (get (host/blog-get type-slug) :schema))) +;; attach/replace a type-post's :schema (idempotent; preserves the rest of the record). +;; Used at boot to install schemas on type-posts — incl. migrating ones seeded before +;; schemas lived on the post (a single read+write, not a loop, so boot-JIT-safe). +(define host/blog--set-schema! + (fn (slug schema) + (let ((r (host/blog-get slug))) + (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)))) +;; the COMPOSITION fields an object has — the fields its (transitive) types declare with +;; :type "Composition" (each edited by its own block editor). Default ["body"] if a type +;; declares none, so every object still has one root composition. This is layer 2: "types +;; declare which fields are compositions" (the schema for the object's structure). +(define host/blog--composition-fields + (fn (slug) + (let ((cf (reduce (fn (acc f) (if (= (get f :type) "Composition") (concat acc (list (str (get f :name)))) acc)) + (list) (host/blog--fields-for-post slug)))) + (if (empty? cf) (list "body") cf)))) +;; the SCALAR (non-composition) fields — the generic edit form's inputs (compositions get a +;; block editor instead of a text input). +(define host/blog--scalar-fields + (fn (slug) (filter (fn (f) (not (= (get f :type) "Composition"))) (host/blog--fields-for-post slug)))) +;; ── type-block GRAMMAR (layer 2b): a Composition field declares which block kinds it may +;; contain. {:name "body" :type "Composition" :blocks (…card types…) :allow ("cond" "each")}. +;; :blocks absent -> every card subtype (back-compat); :allow absent -> both control blocks. -- +(define host/blog--field-decl + (fn (slug field) + (let loop ((fs (host/blog--fields-for-post slug))) + (cond ((empty? fs) nil) + ((= (str (get (first fs) :name)) field) (first fs)) + (else (loop (rest fs))))))) +;; the card types a field permits (its :blocks, else all subtypes of "card"). +(define host/blog--allowed-blocks + (fn (slug field) + (let ((d (host/blog--field-decl slug field))) + (if (and d (get d :blocks)) (get d :blocks) (host/blog--subtype-closure (list "card") :in))))) +;; whether a control block ("cond"/"each") is permitted in a field (its :allow, else both). +(define host/blog--allows-control? + (fn (slug field kind) + (let ((d (host/blog--field-decl slug field))) + (if (and d (get d :allow)) (contains? (get d :allow) kind) true)))) +;; whether a specific card type may be added to a field (grammar check for the add handler). +(define host/blog--block-allowed? + (fn (slug field ctype) (contains? (host/blog--allowed-blocks slug field) ctype))) +;; a short editor label for a card type: strip the "card-" prefix. +(define host/blog--card-label + (fn (ct) (if (starts-with? ct "card-") (substr ct 5) ct))) +;; grammar violations of a field's current composition (empty = valid): card nodes whose type +;; isn't permitted, control blocks that aren't allowed. Used on save/import. +(define host/blog--comp-violations + (fn (slug field) + (reduce + (fn (acc node) + (let ((k (host/blog--node-kind node))) + (cond + ((= k "card") + (let ((ct (host/blog--primary-card-type (host/blog--resolve-ref (str (first (rest node))) {"container" slug})))) + (if (host/blog--block-allowed? slug field ct) acc + (concat acc (list (str "block ‘" ct "’ is not allowed in :" field)))))) + ((or (= k "cond") (= k "each")) + (if (host/blog--allows-control? slug field k) acc + (concat acc (list (str "‘" k "’ blocks are not allowed in :" field))))) + (else acc)))) + (list) (host/blog--comp-nodes slug field)))) +;; ── Part B: RELATIONS are governed by the type too — related / is-a / subtype-of / tagged are +;; part of the object's composition (external — NOT in the CID), and the type declares which +;; relation kinds its instances may use (:type-relations). Absent -> all kinds (back-compat). -- +(define host/blog--all-rel-kinds (fn () (map (fn (s) (get s :kind)) host/blog-rel-kinds))) +(define host/blog--type-relations (fn (type) (get (host/blog-get type) :type-relations))) +(define host/blog--set-type-relations! + (fn (type kinds) + (let ((r (host/blog-get type))) (when r (host/blog--write! type (merge r {:type-relations kinds})))))) +;; the relation kinds a post may use = the union its types declare (:type-relations); if no +;; type declares any, every registered kind (so metamodel types keep full freedom by default). +(define host/blog--allowed-relations + (fn (slug) + (let ((declared (reduce (fn (acc t) (let ((r (host/blog--type-relations t))) + (if r (host/blog--uniq (concat acc r)) acc))) + (list) (host/blog-types-of slug)))) + (if (empty? declared) (host/blog--all-rel-kinds) declared)))) +(define host/blog--relation-allowed? (fn (slug kind) (contains? (host/blog--allowed-relations slug) kind))) +;; ── Part C: the TYPE DEFINITION is itself editable — a type's :fields (each with, for a +;; Composition field, its block grammar) are displayed + edited on the type's own edit page. +;; is this post a TYPE? (declares fields, or is subtype-of "type" transitively). -- +(define host/blog--is-type? + (fn (slug) + (or (> (len (host/blog-fields-of slug)) 0) + (contains? (host/blog--subtype-closure (host/blog-out slug "subtype-of") :out) "type")))) +;; set a Composition field's grammar (:blocks + :allow) on a type, preserving its other fields. +(define host/blog--set-field-grammar! + (fn (slug fname blocks allow) + (host/blog--set-fields! slug + (map (fn (f) (if (= (str (get f :name)) fname) (merge f {:blocks blocks :allow allow}) f)) + (host/blog-fields-of slug))))) +;; a labelled checkbox (the attr must be OMITTED when unchecked — an empty :checked still +;; checks the box). +(define host/blog--checkbox + (fn (name label checked) + (if checked + (quasiquote (label :style "margin-right:0.9em;white-space:nowrap" + (input :type "checkbox" :name (unquote name) :checked "checked") " " (unquote label))) + (quasiquote (label :style "margin-right:0.9em;white-space:nowrap" + (input :type "checkbox" :name (unquote name)) " " (unquote label)))))) +;; 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))) + +;; ── Slice 8c: render TEMPLATE per type (fields drive the page, not just the form) ── +;; A type may declare a :template — a parameterised SX tree (stored as source) where +;; (field "name") placeholders resolve to the instance's field-values at render. So ONE +;; field definition drives BOTH the edit form (above) AND the rendered page. The template +;; is DATA (editable, meta-circular); a type with no template renders nothing extra. See +;; plans/relations-as-posts.md ("Types define the UI"). +(define host/blog-template-of + (fn (type-slug) (get (host/blog-get type-slug) :template))) +(define host/blog--set-template! + (fn (slug template) + (let ((r (host/blog-get slug))) + (when r (host/blog--write! slug (merge r {:template template})))))) + +;; ── composition objects (plans/composition-objects.md) ────────────── +;; A record may carry a :body — a composition node (seq/par/alt/each over object refs) +;; rendered by the render-fold (lib/host/compose.sx) against a context. When present it +;; supersedes :sx-content. This is fold #1; the same object renders differently per context. +(define host/blog-body-of (fn (slug) (host/blog--comp-of slug "body"))) +(define host/blog--set-body! (fn (slug body) (host/blog--set-comp! slug "body" body))) +;; The resolver for the composition `each` graph-query source (compose.sx asks the context +;; for "query"). `(query REL TYPE)` -> the objects related to TYPE by REL, as full records +;; so the per-item template can field them. Today the supported relation is is-a (TYPE's +;; transitive instances, via host/blog-instances-of); the dispatch leaves room for more. +;; This is the DATA-DRIVEN each source — the object's `each` is the query, the render is +;; the run over whatever the graph currently holds. +(define host/blog--comp-query + (fn (qargs ctx) + (let ((rel (str (first qargs))) (type (str (first (rest qargs))))) + (cond + ((= rel "is-a") (map host/blog-get (host/blog-instances-of type))) + (else (list)))))) +;; 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")))) +;; ── ref addressing: relative-stored, resolve-in-context (IPNS-like) ───────────────── +;; A ref in a :body is RELATIVE by default — a field-path like "body__b0" (logical: body/b0), +;; resolved against the object being rendered (the "container" in the context). So the same +;; body is portable: it doesn't pin the container's name. A card's storage slug is +;; ____ (routing-safe — a single URL segment). A cross-domain ref is +;; ABSOLUTE with an authority: "market:obj__field__card" — the resolver dispatches on the +;; prefix (local today; fetch_data / ActivityPub for a remote authority later). A snapshot/ +;; publish op (future) freezes all refs to absolute CIDs. This is the naming layer; the CID +;; (content hash of the record, incl :body) is the immutable-identity layer on top. +(define host/blog--card-slug + (fn (container field name) (str container "__" field "__" name))) +;; resolve a ref string (relative field-path, or authority:slug) to a LOCAL storage slug, +;; or "" if it's a remote authority we can't fetch yet. +(define host/blog--resolve-ref + (fn (refstr ctx) + (let ((container (str (or (get ctx "container") "")))) + (if (contains? refstr ":") + (let ((p (index-of refstr ":"))) + (let ((auth (substr refstr 0 p)) (rest-slug (substr refstr (+ p 1)))) + (if (or (= auth "blog") (= auth container)) rest-slug ""))) ;; local authority -> the slug; remote -> unresolved (seam) + (if (= container "") refstr + ;; relative resolution: __. COMPAT: an older body may store an + ;; ABSOLUTE ref (the full card slug) — if the relative form is absent but the ref + ;; already names an existing object, use it directly. + (let ((rel (str container "__" refstr))) + (if (host/blog-exists? rel) rel (if (host/blog-exists? refstr) refstr rel)))))))) +;; the `ref` transclude resolver (compose.sx asks the context for "ref"): RESOLVE the ref in +;; context, then render the resolved card object. A card is-a a card-type with field-values + +;; the card-type carries a :template, so it renders via the SAME typed-block path articles +;; use; render-page turns that SX tree into HTML. Empty for an absent / remote / bare ref. +(define host/blog--comp-ref + (fn (refstr ctx) + (let ((slug (host/blog--resolve-ref refstr ctx))) + (if (= slug "") "" + (let ((tb (host/blog--typed-block slug))) + (if (= tb "") "" (render-page tb))))))) +;; the render context for a :body: auth from the principal + live device/locale from the +;; request + the graph-query resolver + the transclude resolver + the CONTAINER (the object +;; being rendered, so relative refs resolve). 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 req container) + (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 "ref" host/blog--comp-ref + "container" (or container "")}))) + +;; ── cards-as-objects: decompose content into card OBJECTS + a `contains` body ──────── +;; A post body is not one opaque sx_content string but a `contains` DAG of separate, +;; content-addressed card OBJECTS. host/blog--decompose! splits an (article …) tree into +;; one card object per top-level block (is-a the mapped card-type + its field-values), +;; links each by an ordered `contains` edge, and sets the post's :body to (seq (ref c0) +;; (ref c1) …). The render-fold then transcludes each card via its type template. This is +;; the cards-as-objects decision made real for the importer (plans/composition-objects.md). + +;; the text content of a block element: its string children joined, skipping :attr pairs, +;; recursing into nested elements. Carries prose into a card field (good enough for import). +(define host/blog--args-text + (fn (args) + (cond + ((empty? args) "") + ((= (type-of (first args)) "keyword") (host/blog--args-text (rest (rest args)))) + (else (str (host/blog--elem-text (first args)) (host/blog--args-text (rest args))))))) +(define host/blog--elem-text + (fn (node) + (cond + ((= (type-of node) "string") node) + ((and (= (type-of node) "list") (> (len node) 0)) (host/blog--args-text (rest node))) + (else "")))) +;; the value of an :attr on an element (e.g. img :src), "" if absent. +(define host/blog--elem-attr + (fn (node key) + (let loop ((args (if (= (type-of node) "list") (rest node) (list)))) + (cond + ((empty? args) "") + ((and (= (type-of (first args)) "keyword") (= (str (first args)) key)) + (if (empty? (rest args)) "" (str (first (rest args))))) + ((= (type-of (first args)) "keyword") (loop (rest (rest args)))) + (else (loop (rest args))))))) +;; the first child element of `node` with tag `tag` (a list head), or nil. (For a figure's +;; inner img / figcaption during decompose.) +(define host/blog--find-child + (fn (node tag) + (let loop ((xs (if (= (type-of node) "list") (rest node) (list)))) + (cond + ((empty? xs) nil) + ((and (= (type-of (first xs)) "list") (= (str (first (first xs))) tag)) (first xs)) + (else (loop (rest xs))))))) +;; map an element tag to a card-type (the block vocabulary). Unknown tags -> text card. +(define host/blog--tag->card-type + (fn (tag) + (cond + ((or (= tag "h1") (= tag "h2") (= tag "h3") (= tag "h4")) "card-heading") + ((or (= tag "img") (= tag "figure")) "card-image") ;; figure = image + figcaption + ((or (= tag "iframe") (= tag "embed") (= tag "video")) "card-embed") + ((= tag "blockquote") "card-quote") + ((or (= tag "pre") (= tag "code")) "card-code") + (else "card-text")))) +;; the field-values for a card-type extracted from the original block element. +(define host/blog--block-fields + (fn (orig-tag ctype block) + (cond + ((= ctype "card-heading") {"level" (if (>= (len orig-tag) 2) (substr orig-tag 1) "2") + "text" (host/blog--elem-text block)}) + ((= ctype "card-image") + ;; a bare (src/alt on the block) OR a
(img child + a figcaption caption). + (let ((img (or (host/blog--find-child block "img") block)) + (cap (host/blog--find-child block "figcaption"))) + {"src" (host/blog--elem-attr img "src") "alt" (host/blog--elem-attr img "alt") + "caption" (if (nil? cap) "" (host/blog--elem-text cap))})) + ((= ctype "card-embed") {"url" (host/blog--elem-attr block "src") "caption" ""}) + ((= ctype "card-code") {"code" (host/blog--elem-text block) "language" ""}) + ((= ctype "card-quote") {"text" (host/blog--elem-text block) "cite" ""}) + (else {"text" (host/blog--elem-text block)})))) +;; decompose a post's content-tree into card objects + a contains body. Idempotent +;; (seed!/relate!/set-body! are sets; re-import overwrites the same __bN card objects). +(define host/blog--decompose! + (fn (post-slug content-tree) + (let ((blocks (if (and (= (type-of content-tree) "list") (> (len content-tree) 0)) + (filter (fn (b) (= (type-of b) "list")) (rest content-tree)) + (list)))) + (when (not (empty? blocks)) + (let ((refs + (map-indexed + (fn (i block) + (let ((orig-tag (str (first block))) (cslug (host/blog--card-slug post-slug "body" (str "b" i)))) + (let ((ctype (host/blog--tag->card-type orig-tag))) + (begin + ;; status "block" hides the card object from listings; it still + ;; renders when transcluded (typed-block ignores status). + (host/blog-seed! cslug ctype "(article (h1 \"card\"))" "block") + (host/blog-relate! cslug ctype "is-a") + (host/blog--set-field-values! cslug (host/blog--block-fields orig-tag ctype block)) + (host/blog-relate! post-slug cslug "contains") + (list (quote ref) (host/blog--slug->ref post-slug cslug)))))) + blocks))) + (host/blog--set-body! post-slug (cons (quote seq) refs))))))) + +;; ── block-editor model: edit a post's :body (its composition of card refs) ─────────── +;; The body is (seq (ref c0) (ref c1) …); these ops add / remove / reorder its blocks and +;; keep the ordered `contains` edges in step. The :body seq is the ORDER authority, the +;; contains edges the membership set. Per-block FIELD editing is free: a card is an object, +;; so its fields are edited via the card's own //edit page. (composition step 6.) +(define host/blog-body-refs + (fn (slug) + (let ((body (host/blog-body-of slug))) + (if (and (= (type-of body) "list") (= (str (first body)) "seq")) + (reduce (fn (acc n) + (if (and (= (type-of n) "list") (= (str (first n)) "ref")) + (concat acc (list (str (first (rest n))))) acc)) + (list) (rest body)) + (list))))) +(define host/blog--set-body-refs! + (fn (slug refs) + (host/blog--set-body! slug (cons (quote seq) (map (fn (r) (list (quote ref) r)) refs))))) +(define host/blog--next-block-idx + (fn (slug) + (let loop ((i 0)) + (if (host/blog-exists? (str slug "__b" i)) (loop (+ i 1)) i)))) +;; legacy card-only remove (by ref slug) — kept for card-only callers/tests; the node-based +;; editor uses host/blog-block-remove-idx! (index-addressed, preserves alt/each nodes). +(define host/blog-block-remove! + (fn (slug cslug) + (begin + (host/blog--set-body-refs! slug + (filter (fn (r) (not (= r cslug))) (host/blog-body-refs slug))) + (host/blog-unrelate! slug cslug "contains")))) +(define host/blog--nth-ref + (fn (xs k) + (let loop ((i 0) (ys xs)) + (cond ((empty? ys) nil) ((= i k) (first ys)) (else (loop (+ i 1) (rest ys))))))) +(define host/blog--ref-index + (fn (xs x) + (let loop ((i 0) (ys xs)) + (cond ((empty? ys) -1) ((= (first ys) x) i) (else (loop (+ i 1) (rest ys))))))) +(define host/blog-block-move! + (fn (slug cslug dir) + (let ((refs (host/blog-body-refs slug))) + (let ((i (host/blog--ref-index refs cslug))) + (let ((j (if (= dir "up") (- i 1) (+ i 1)))) + (when (and (>= i 0) (>= j 0) (< j (len refs))) + (host/blog--set-body-refs! slug + (map-indexed (fn (k r) (cond ((= k i) (host/blog--nth-ref refs j)) + ((= k j) (host/blog--nth-ref refs i)) + (else r))) refs)))))))) +;; the card-type of a card object (its declared is-a target); "card" if none. +(define host/blog--primary-card-type + (fn (cslug) (let ((ts (host/blog-out cslug "is-a"))) (if (empty? ts) "card" (first ts))))) +;; a short text preview of a card's content from its field-values. +(define host/blog--block-preview + (fn (vals) + (let ((t (str (or (get vals "text") (get vals "src") (get vals "code") (get vals "url") "")))) + (if (> (len t) 60) (str (substr t 0 60) "…") t)))) + +;; ── and/or/each authoring: the :body's top-level nodes are BLOCKS of three kinds ───── +;; The :body IS the object's one root composition (inline, part of its CID). Its top-level +;; nodes are blocks: a CARD (ref -> an external card object via a `contains` edge), a +;; CONDITIONAL (alt+when — the "or": show the first branch whose condition holds), or a +;; REPEATER (each — the loop: render a template per graph-query result). seq is the "and". +;; The editor edits this inline tree; leaves stay external refs. (composition-objects.md.) +;; a composition FIELD's value on an object — inline, part of the CID. A type declares which +;; of its fields are compositions (host/blog--composition-fields); an object may carry several +;; (:body, :aside, …), each edited by its own block editor. Compositions live in a STRING-KEYED +;; sub-dict :comps (string keys round-trip through persist cleanly, unlike a mix of keyword and +;; string top-level keys). The default "body" field falls back to a legacy top-level :body. +(define host/blog--comps (fn (rec) (or (get rec :comps) {}))) +(define host/blog--comp-of + (fn (slug field) + (let ((r (host/blog-get slug))) + (let ((c (get (host/blog--comps r) field))) + (if (nil? c) (if (= field "body") (get r :body) nil) c))))) +(define host/blog--set-comp! + (fn (slug field v) + (let ((r (host/blog-get slug))) + (when r (host/blog--write! slug (assoc r :comps (assoc (host/blog--comps r) field v))))))) +(define host/blog--comp-nodes + (fn (slug field) + (let ((c (host/blog--comp-of slug field))) + (if (and (= (type-of c) "list") (= (str (first c)) "seq")) (rest c) (list))))) +(define host/blog--set-comp-nodes! + (fn (slug field nodes) (host/blog--set-comp! slug field (cons (quote seq) nodes)))) +;; back-compat: the default "body" field. +(define host/blog-body-nodes (fn (slug) (host/blog--comp-nodes slug "body"))) +(define host/blog--set-body-nodes! (fn (slug nodes) (host/blog--set-comp-nodes! slug "body" nodes))) +;; the value at index k of a list (any element type). +(define host/blog--nth + (fn (xs k) (let loop ((i 0) (ys xs)) + (cond ((empty? ys) nil) ((= i k) (first ys)) (else (loop (+ i 1) (rest ys))))))) +;; a copy of xs without index i. +(define host/blog--remove-at + (fn (xs i) (let loop ((k 0) (ys xs) (acc (list))) + (if (empty? ys) acc + (loop (+ k 1) (rest ys) (if (= k i) acc (concat acc (list (first ys))))))))) +;; a fresh card object (is-a ctype + fields), contains-linked to `slug`; returns its slug. +;; Every block kind's leaves are card objects made this way. +;; a fresh, uniquely-named card in /. Returns its STORAGE SLUG +;; (____b); callers store the RELATIVE ref via host/blog--slug->ref. +(define host/blog--next-card-name + (fn (container field) + (let loop ((i 0)) + (if (host/blog-exists? (host/blog--card-slug container field (str "b" i))) (loop (+ i 1)) (str "b" i))))) +(define host/blog--new-card! + (fn (container field ctype fields) + (let ((cslug (host/blog--card-slug container field (host/blog--next-card-name container field)))) + (begin + (host/blog-seed! cslug ctype "(article (h1 \"card\"))" "block") + (host/blog-relate! cslug ctype "is-a") + (host/blog--set-field-values! cslug fields) + (host/blog-relate! container cslug "contains") + cslug)))) +;; a card's RELATIVE ref (field-path) from its storage slug: ____ +;; -> __. What's stored in a :body (resolve-in-context re-prepends container). +(define host/blog--slug->ref + (fn (container slug) + (if (starts-with? slug (str container "__")) (substr slug (+ (len container) 2)) slug))) +(define host/blog--append-node! + (fn (slug field node) (host/blog--set-comp-nodes! slug field (concat (host/blog--comp-nodes slug field) (list node))))) +;; the kind of a body node, for the editor: "card" | "cond" | "each" | "other". +(define host/blog--node-kind + (fn (node) + (if (= (type-of node) "list") + (let ((h (str (first node)))) + (cond + ((= h "ref") "card") ((= h "alt") "cond") ((= h "each") "each") + ((= h "text") "text") + ((or (= h "row") (= h "grid")) "layout") + ((or (= h "field") (= h "val")) "field") + ((= h "seq") "group") + (else "other"))) + "other"))) +;; a short human display of ANY composition node — for the editor rows. A ref becomes a +;; ✎ edit-chip; text/field/val show their content; a container shows its item count. +(define host/blog--node-display + (fn (slug node) + (if (= (type-of node) "list") + (let ((h (str (first node)))) + (cond + ((= h "ref") (host/blog--ref-chip slug (str (first (rest node))))) + ((= h "text") (let ((t (str (first (rest node))))) (if (> (len t) 50) (str (substr t 0 50) "…") t))) + ((or (= h "field") (= h "val")) (str h " " (str (first (rest node))))) + ((or (= h "seq") (= h "row") (= h "grid")) (str h " (" (len (rest node)) ")")) + (else h))) + (str node)))) +;; the display of a conditional/repeater BRANCH — its last element (a ref, text, or group). +(define host/blog--branch-display + (fn (slug branch) + (host/blog--node-display slug (host/blog--nth branch (- (len branch) 1))))) +;; every ref slug a node (transitively) contains — for `contains`-edge cleanup on remove. +(define host/blog--node-refs + (fn (node) + (if (= (type-of node) "list") + (if (= (str (first node)) "ref") + (list (str (first (rest node)))) + (reduce (fn (acc n) (concat acc (host/blog--node-refs n))) (list) (rest node))) + (list)))) +;; a `when` condition key <-> its predicate. A small decidable set over the live context +;; (auth/device/locale) — this is where responsive/personalised authoring surfaces. +(define host/blog--cond->pred + (fn (ckey) + (cond + ((= ckey "auth") (list (quote has) "auth")) + ((= ckey "device:mobile") (list (quote eq) "device" "mobile")) + ((= ckey "device:desktop") (list (quote eq) "device" "desktop")) + ((= ckey "locale:fr") (list (quote eq) "locale" "fr")) + (else (list (quote has) "auth"))))) +(define host/blog--pred->label + (fn (pred) + (if (= (type-of pred) "list") + (let ((op (str (first pred)))) + (cond + ((= op "has") (str "has " (str (first (rest pred))))) + ((= op "eq") (str (str (first (rest pred))) " = " (str (first (rest (rest pred)))))) + (else "?"))) + "?"))) +;; the when-predicate of a conditional node (alt (when P …) …), or nil. +(define host/blog--node-pred + (fn (node) + (if (and (= (host/blog--node-kind node) "cond") (>= (len (rest node)) 1)) + (let ((wb (first (rest node)))) (if (= (str (first wb)) "when") (first (rest wb)) nil)) + nil))) +;; the query TYPE of a repeater node (each (query is-a T) …), or "". +(define host/blog--node-each-type + (fn (node) + (if (and (= (host/blog--node-kind node) "each") (>= (len (rest node)) 1)) + (let ((src (first (rest node)))) + (if (and (= (type-of src) "list") (= (str (first src)) "query")) (str (first (rest (rest src)))) "")) + ""))) +;; the ref inside a branch — its last element (ref …); "" if none. Used to read the then/ +;; else refs of a conditional and the template ref of a repeater. +(define host/blog--branch-ref + (fn (branch) + (let ((n (host/blog--nth branch (- (len branch) 1)))) + (if (and (= (type-of n) "list") (= (str (first n)) "ref")) (str (first (rest n))) "")))) +(define host/blog--cond-then (fn (node) (host/blog--branch-ref (first (rest node))))) +(define host/blog--cond-else (fn (node) (host/blog--branch-ref (first (rest (rest node)))))) +(define host/blog--each-tmpl (fn (node) (host/blog--branch-ref node))) +;; a ckey (for the cond