From 15e593b72502d062a7f745a924e3a8f220ab225e Mon Sep 17 00:00:00 2001 From: giles Date: Fri, 17 Apr 2026 07:25:19 +0000 Subject: [PATCH] Restore sx_server.ml, add host-* stubs for boot-helpers.sx The previous commit accidentally lost ~1100 lines from sx_server.ml due to a git stash conflict resolution that silently deleted the hash-index, manifest generation, and /sx/h/ route handler code. Restored from 97818c6d. Only change: added host-* platform primitive stubs (host-get, host-set!, host-call, etc.) needed because the callable? fix in boot-helpers.sx now properly loads code paths that reference these browser-only functions. Co-Authored-By: Claude Opus 4.6 (1M context) --- hosts/ocaml/bin/sx_server.ml | 1321 +++++++++++++++++++++++++++++++++- 1 file changed, 1282 insertions(+), 39 deletions(-) diff --git a/hosts/ocaml/bin/sx_server.ml b/hosts/ocaml/bin/sx_server.ml index cbf79a60..3ca70881 100644 --- a/hosts/ocaml/bin/sx_server.ml +++ b/hosts/ocaml/bin/sx_server.ml @@ -18,6 +18,123 @@ open Sx_types +(* ====================================================================== *) +(* Font measurement via otfm — reads OpenType/TrueType font tables *) +(* ====================================================================== *) + +(* Font cache: font-family → (units_per_em, glyph_id_map, advance_width_map) *) +let _font_cache : (string, (int * (int, int) Hashtbl.t * (int, int) Hashtbl.t)) Hashtbl.t = Hashtbl.create 4 + +(* Map font-family names to file paths *) +let _font_base = ref "shared/static/fonts" + +let font_path_for family = + let base = !_font_base in + let try_paths paths = + List.find_opt Sys.file_exists paths in + match String.lowercase_ascii family with + | "serif" | "times" | "times new roman" -> + try_paths [base ^ "/DejaVuSerif.ttf"; + "/usr/share/fonts/truetype/dejavu/DejaVuSerif.ttf"] + | "sans-serif" | "sans" | "arial" | "helvetica" -> + try_paths [base ^ "/DejaVuSans.ttf"; + "/usr/share/fonts/truetype/dejavu/DejaVuSans.ttf"] + | "monospace" | "mono" | "courier" -> + try_paths [base ^ "/DejaVuSansMono-Bold.ttf"; + "/usr/share/fonts/truetype/dejavu/DejaVuSansMono-Bold.ttf"] + | path when Sys.file_exists path -> Some path + | _ -> try_paths [base ^ "/DejaVuSerif.ttf"; + "/usr/share/fonts/truetype/dejavu/DejaVuSerif.ttf"] + +(* Load a font file and extract cmap + hmtx tables *) +let load_font family = + match Hashtbl.find_opt _font_cache family with + | Some cached -> Some cached + | None -> + match font_path_for family with + | None -> None + | Some path -> + try + let ic = open_in_bin path in + let n = in_channel_length ic in + let buf = Bytes.create n in + really_input ic buf 0 n; + close_in ic; + let s = Bytes.to_string buf in + let d = Otfm.decoder (`String s) in + (* Get units_per_em from head table *) + let upm = match Otfm.head d with + | Error _ -> 2048 + | Ok h -> h.Otfm.head_units_per_em in + (* Build char→glyph_id map from cmap. + cmap folds: (acc -> map_kind -> (u0,u1) -> glyph_id -> acc) *) + let cmap_tbl = Hashtbl.create 256 in + let _ = Otfm.cmap d (fun acc kind (u0, u1) gid -> + (match kind with + | `Glyph -> + (* Single mapping: u0 -> gid (u0 = u1) *) + Hashtbl.replace cmap_tbl u0 gid + | `Glyph_range -> + (* Range: u0..u1 -> gid..(gid + u1 - u0) *) + for i = 0 to u1 - u0 do + Hashtbl.replace cmap_tbl (u0 + i) (gid + i) + done); + acc) () in + (* Build glyph_id→advance_width map from hmtx. + hmtx folds: (acc -> glyph_id -> adv_width -> lsb -> acc) *) + let hmtx_tbl = Hashtbl.create 256 in + let _ = Otfm.hmtx d (fun acc gid adv _lsb -> + Hashtbl.replace hmtx_tbl gid adv; acc) () in + let result = (upm, cmap_tbl, hmtx_tbl) in + Printf.eprintf "[font] loaded %s: %d glyphs, %d metrics, upm=%d\n%!" + (Filename.basename path) (Hashtbl.length cmap_tbl) (Hashtbl.length hmtx_tbl) upm; + Hashtbl.replace _font_cache family result; + Some result + with e -> + Printf.eprintf "[font] error loading %s: %s\n%!" path (Printexc.to_string e); + None + +(* Measure text width using font tables *) +let measure_text_otfm family size text = + match load_font family with + | None -> + (* Fallback to monospace approximation *) + let w = size *. 0.6 *. (float_of_int (String.length text)) in + (w, size, size *. 0.8, size *. 0.2) + | Some (upm, cmap_tbl, hmtx_tbl) -> + let scale = size /. (float_of_int upm) in + let width = ref 0.0 in + (* Iterate over UTF-8 codepoints *) + let i = ref 0 in + let len = String.length text in + while !i < len do + let byte = Char.code text.[!i] in + let cp, advance = + if byte < 0x80 then (byte, 1) + else if byte < 0xC0 then (byte, 1) (* continuation — skip *) + else if byte < 0xE0 then + ((byte land 0x1F) lsl 6 lor (Char.code text.[min (!i+1) (len-1)] land 0x3F), 2) + else if byte < 0xF0 then + ((byte land 0x0F) lsl 12 + lor (Char.code text.[min (!i+1) (len-1)] land 0x3F) lsl 6 + lor (Char.code text.[min (!i+2) (len-1)] land 0x3F), 3) + else + ((byte land 0x07) lsl 18 + lor (Char.code text.[min (!i+1) (len-1)] land 0x3F) lsl 12 + lor (Char.code text.[min (!i+2) (len-1)] land 0x3F) lsl 6 + lor (Char.code text.[min (!i+3) (len-1)] land 0x3F), 4) + in + let gid = match Hashtbl.find_opt cmap_tbl cp with + | Some g -> g | None -> 0 in + let adv = match Hashtbl.find_opt hmtx_tbl gid with + | Some a -> a | None -> upm / 2 in + width := !width +. (float_of_int adv) *. scale; + i := !i + advance + done; + let ascent = size *. 0.8 in (* approximate — could read OS/2 table *) + let descent = size *. 0.2 in + (!width, size, ascent, descent) + (* ====================================================================== *) (* Output helpers *) @@ -71,6 +188,56 @@ let rec serialize_value = function "(make-spread {" ^ String.concat " " items ^ "})" | _ -> "nil" +(** Collect all ~-prefixed symbol references from an AST value. + Walks the tree recursively, returns a deduplicated list of symbol names + like ["~card"; "~layout/base"]. Used for dependency analysis. *) +let collect_tilde_refs body = + let seen = Hashtbl.create 16 in + let rec walk = function + | Symbol s when String.length s > 0 && s.[0] = '~' -> + if not (Hashtbl.mem seen s) then Hashtbl.replace seen s () + | List items | ListRef { contents = items } -> + List.iter walk items + | Dict d -> + Hashtbl.iter (fun _k v -> walk v) d + | Spread pairs -> + List.iter (fun (_k, v) -> walk v) pairs + | _ -> () + in + walk body; + Hashtbl.fold (fun k () acc -> k :: acc) seen [] + +(** Serialize a value to SX text, replacing ~-prefixed symbol references + with their content hashes from the index. Symbols not in the index + are emitted verbatim (unknown ref or non-component symbol). *) +let rec serialize_value_hashed (index : (string, string) Hashtbl.t) = function + | Nil -> "nil" + | Bool true -> "true" + | Bool false -> "false" + | Number n -> + if Float.is_integer n then string_of_int (int_of_float n) + else Printf.sprintf "%g" n + | String s -> "\"" ^ escape_sx_string s ^ "\"" + | Symbol s when String.length s > 0 && s.[0] = '~' -> + (match Hashtbl.find_opt index s with + | Some h -> "@h:" ^ h + | None -> s) + | Symbol s -> s + | Keyword k -> ":" ^ k + | List items | ListRef { contents = items } -> + "(" ^ String.concat " " (List.map (serialize_value_hashed index) items) ^ ")" + | Dict d -> + let pairs = Hashtbl.fold (fun k v acc -> + (Printf.sprintf ":%s %s" k (serialize_value_hashed index v)) :: acc) d [] in + "{" ^ String.concat " " (List.sort String.compare pairs) ^ "}" + | RawHTML s -> "\"" ^ escape_sx_string s ^ "\"" + | SxExpr s -> s + | Spread pairs -> + let items = List.map (fun (k, v) -> + Printf.sprintf ":%s %s" k (serialize_value_hashed index v)) pairs in + "(make-spread {" ^ String.concat " " items ^ "})" + | _ -> "nil" + (** Request epoch — monotonically increasing, set by (epoch N) from Python. All responses are tagged with the current epoch so Python can discard stale messages from previous requests. Makes pipe desync impossible. *) @@ -149,6 +316,11 @@ let _scope_stacks = Sx_primitives._scope_stacks (* Populated from __app-config dict after SX files load. *) let _app_config : (string, value) Hashtbl.t option ref = ref None let _defpage_paths : string list ref = ref [] +(* Streaming pages: path → page name, for pages with :stream true *) +let _streaming_pages : (string, string) Hashtbl.t = Hashtbl.create 8 +(* Mutex to serialize streaming renders — OCaml threads share the runtime + lock, and concurrent CEK evaluations corrupt shared state. *) +let _stream_mutex = Mutex.create () let get_app_config key default = match !_app_config with @@ -315,12 +487,12 @@ let resolve_library_path lib_spec = The file should contain a define-library form that registers itself. *) let _import_env : env option ref = ref None -let load_library_file path = - (* Use eval_expr which has the cek_run import patch — handles nested imports *) +let rec load_library_file path = + (* Use eval_expr_io for IO-aware loading (handles nested imports) *) let env = match !_import_env with Some e -> e | None -> Sx_types.make_env () in let exprs = Sx_parser.parse_file path in List.iter (fun expr -> - try ignore (Sx_ref.eval_expr expr (Env env)) + try ignore (eval_expr_io expr (Env env)) with Eval_error msg -> Printf.eprintf "[load-library] %s: %s\n%!" (Filename.basename path) msg ) exprs @@ -328,7 +500,7 @@ let load_library_file path = (** 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. *) -let cek_run_with_io state = +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 let is_suspended s = match Sx_runtime.get_val s (String "phase") with String "io-suspended" -> true | _ -> false in @@ -355,6 +527,24 @@ let cek_run_with_io state = (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 args = let a = Sx_runtime.get_val request (String "args") in (match a with List l -> l | _ -> [a]) in @@ -368,10 +558,7 @@ let cek_run_with_io state = loop () (** IO-aware eval_expr — like eval_expr but handles IO suspension. *) -(* IO-aware eval — used by site_mode. The regular file loading path - uses Sx_ref.eval_expr which delegates IO suspension to the - _cek_io_suspend_hook → _vm_suspension_to_dict chain. *) -let _eval_expr_io expr env = +and eval_expr_io expr env = let state = Sx_ref.make_cek_state expr env (List []) in cek_run_with_io state @@ -467,7 +654,22 @@ let setup_browser_stubs env = bind "create-text-node" (fun args -> match args with [String s] -> String s | [v] -> String (value_to_string v) | _ -> Nil); bind "render-to-dom" (fun _args -> Nil); bind "set-render-active!" (fun _args -> Nil); - bind "render-active?" (fun _args -> Bool true) + bind "render-active?" (fun _args -> Bool true); + (* host-* platform primitives — browser-only, but boot-helpers.sx + references them so they need server-side stubs *) + bind "host-get" (fun args -> + match args with + | [Dict d; String key] -> (match Hashtbl.find_opt d key with Some v -> v | None -> Nil) + | _ -> Nil); + bind "host-set!" (fun _args -> Nil); + bind "host-call" (fun _args -> Nil); + bind "host-typeof" (fun _args -> String "nil"); + bind "host-callback" (fun args -> + match args with [fn] -> fn | _ -> NativeFn ("noop", fun _ -> Nil)); + bind "host-await" (fun _args -> Nil); + bind "host-new" (fun _args -> Nil); + bind "host-global" (fun _args -> Nil); + bind "host-object" (fun _args -> Dict (Hashtbl.create 0)) (* ---- Scope primitives: bind into env for VM visibility ---- *) let setup_scope_env env = @@ -946,7 +1148,16 @@ let register_jit_hook env = (try Some (Sx_vm.call_closure cl args cl.vm_env_ref) with | Sx_vm.VmSuspended (request, saved_vm) -> - Some (make_vm_suspend_marker request saved_vm) + (* Try inline IO resolution; fall back to suspend marker *) + (match !Sx_types._cek_io_resolver with + | Some resolver -> + let rec resolve_loop req vm = + let result = resolver req (Nil) in + (try Some (Sx_vm.resume_vm vm result) + with Sx_vm.VmSuspended (req2, vm2) -> resolve_loop req2 vm2) + in + resolve_loop request saved_vm + | None -> Some (make_vm_suspend_marker request saved_vm)) | e -> let fn_name = match l.l_name with Some n -> n | None -> "?" in if not (Hashtbl.mem _jit_warned fn_name) then begin @@ -971,7 +1182,15 @@ let register_jit_hook env = (try Some (Sx_vm.call_closure cl args cl.vm_env_ref) with | Sx_vm.VmSuspended (request, saved_vm) -> - Some (make_vm_suspend_marker request saved_vm) + (match !Sx_types._cek_io_resolver with + | Some resolver -> + let rec resolve_loop req vm = + let result = resolver req (Nil) in + (try Some (Sx_vm.resume_vm vm result) + with Sx_vm.VmSuspended (req2, vm2) -> resolve_loop req2 vm2) + in + resolve_loop request saved_vm + | None -> Some (make_vm_suspend_marker request saved_vm)) | e -> Printf.eprintf "[jit] %s first-call fallback to CEK: %s\n%!" fn_name (Printexc.to_string e); Hashtbl.replace _jit_warned fn_name true; @@ -997,6 +1216,41 @@ let rebind_host_extensions env = | _ -> raise (Eval_error "register-special-form!: expected (name handler)"))); ignore (env_bind env "*custom-special-forms*" Sx_ref.custom_special_forms) +(* Path-based naming for unnamed definitions *) +(* ====================================================================== *) + +let def_keywords = ["defcomp"; "defisland"; "defmacro"; "define"; + "defhandler"; "defstyle"; "deftype"; "defeffect"; + "defrelation"; "deftest"; "defpage"] + +(* Inject path-derived name into unnamed definitions. + (defcomp (params) body) -> (defcomp ~path/name (params) body) + Only applied when base_dir is provided (service components). *) +let inject_path_name expr path base_dir = + match expr with + | List (Symbol kw :: rest) when List.mem kw def_keywords -> + (match rest with + | Symbol _ :: _ -> expr (* Already named *) + | _ -> + (* Unnamed — derive name from file path relative to base_dir *) + let rel = if String.length path > String.length base_dir + 1 + then String.sub path (String.length base_dir + 1) + (String.length path - String.length base_dir - 1) + else Filename.basename path in + let stem = if Filename.check_suffix rel ".sx" + then String.sub rel 0 (String.length rel - 3) + else rel in + (* index files are known by their directory *) + let name = if Filename.basename stem = "index" + then let d = Filename.dirname stem in + if d = "." then "index" else d + else stem in + (* Components/islands get ~ prefix *) + let prefixed = if kw = "defcomp" || kw = "defisland" + then "~" ^ name else name in + List (Symbol kw :: Symbol prefixed :: rest)) + | _ -> expr + (* Command dispatch *) (* ====================================================================== *) @@ -1005,14 +1259,20 @@ let rec dispatch env cmd = | List [Symbol "ping"] -> send_ok_string "ocaml-cek" - | List [Symbol "load"; String path] -> + | List [Symbol "load"; String path] + | List [Symbol "load"; String path; String _] -> + let base_dir = match cmd with + | List [_; _; String b] -> b | _ -> "" in (try let exprs = Sx_parser.parse_file path in let prev_file = if Sx_types.env_has env "*current-file*" then Some (Sx_types.env_get env "*current-file*") else None in ignore (Sx_types.env_bind env "*current-file*" (String path)); let count = ref 0 in List.iter (fun expr -> - ignore (Sx_ref.eval_expr expr (Env env)); + let expr' = if base_dir <> "" then inject_path_name expr path base_dir else expr in + (try ignore (eval_expr_io expr' (Env env)) + with Eval_error msg -> + Printf.eprintf "[load] %s: %s\n%!" (Filename.basename path) msg); incr count ) exprs; (* Rebind host extension points after .sx load — evaluator.sx @@ -1743,6 +2003,32 @@ let http_response ?(status=200) ?(content_type="text/html; charset=utf-8") body let http_redirect url = Printf.sprintf "HTTP/1.1 301 Moved Permanently\r\nLocation: %s\r\nContent-Length: 0\r\nConnection: keep-alive\r\n\r\n" url +(* Chunked transfer encoding helpers for streaming responses *) +let http_chunked_header ?(status=200) ?(content_type="text/html; charset=utf-8") () = + let status_text = match status with + | 200 -> "OK" | 404 -> "Not Found" | 500 -> "Internal Server Error" | _ -> "Unknown" in + Printf.sprintf "HTTP/1.1 %d %s\r\nContent-Type: %s\r\nTransfer-Encoding: chunked\r\nConnection: keep-alive\r\nX-Accel-Buffering: no\r\nCache-Control: no-cache, no-transform\r\n\r\n" + status status_text content_type + +let write_chunk fd data = + if String.length data > 0 then begin + let chunk = Printf.sprintf "%x\r\n%s\r\n" (String.length data) data in + let bytes = Bytes.of_string chunk in + let total = Bytes.length bytes in + let written = ref 0 in + try + while !written < total do + let n = Unix.write fd bytes !written (total - !written) in + written := !written + n + done; + true + with Unix.Unix_error _ -> false + end else true + +let end_chunked fd = + (try ignore (Unix.write_substring fd "0\r\n\r\n" 0 5) with Unix.Unix_error _ -> ()); + (try Unix.close fd with _ -> ()) + let parse_http_request data = match String.index_opt data '\r' with | None -> (match String.index_opt data '\n' with @@ -1789,6 +2075,48 @@ let parse_http_headers data = ) (match lines with _ :: rest -> rest | [] -> []); !headers +(* IO-aware eval for rendering — handles perform (text-measure, sleep, import). + Used by aser and SSR so components can call measure-text via perform. *) +let eval_with_io_render expr env = + let state = ref (Sx_ref.cek_step_loop (Sx_ref.make_cek_state expr (Env env) Nil)) in + while sx_truthy (Sx_ref.cek_suspended_p !state) do + let request = Sx_ref.cek_io_request !state in + let op = match request with + | Dict d -> (match Hashtbl.find_opt d "op" with Some (String s) -> s | Some (Symbol s) -> s | _ -> "") + | _ -> "" in + let args = match request with + | Dict d -> (match Hashtbl.find_opt d "args" with Some v -> v | None -> Nil) + | _ -> Nil in + let result = match op with + | "text-measure" -> + let font = match args with + | List (String f :: _) -> f | _ -> "serif" in + let size = match args with + | List [_font; Number sz; _text] -> sz + | List [_font; Number sz] -> sz + | _ -> 16.0 in + let text = match args with + | List [_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 + | "io-sleep" | "sleep" -> + let ms = match args with + | List (Number n :: _) -> n | Number n -> n | _ -> 0.0 in + Unix.sleepf (ms /. 1000.0); Nil + | "import" -> Nil + | _ -> Nil + in + state := Sx_ref.cek_step_loop (Sx_ref.cek_resume !state result) + done; + if sx_truthy (Sx_ref.cek_terminal_p !state) then Sx_ref.cek_value !state + else Nil + (** Render a page. Routing + AJAX detection in SX (request-handler.sx), render pipeline (aser → SSR → shell) in OCaml for reliable env access. *) let http_render_page env path headers = @@ -1840,7 +2168,7 @@ let http_render_page env path headers = (* AJAX: return SX wire format (aser output) with text/sx content type *) let body_result = let call = List [Symbol "aser"; List [Symbol "quote"; wrapped]; Env env] in - Sx_ref.eval_expr call (Env env) in + eval_with_io_render call env in let body_str = match body_result with | String s | SxExpr s -> s | _ -> serialize_value body_result in let t1 = Unix.gettimeofday () in @@ -1854,7 +2182,7 @@ let http_render_page env path headers = let t1 = Unix.gettimeofday () in let body_result = let call = List [Symbol "aser"; List [Symbol "quote"; full_ast]; Env env] in - Sx_ref.eval_expr call (Env env) in + eval_with_io_render call env in let body_str = match body_result with | String s | SxExpr s -> s | _ -> serialize_value body_result in let t2 = Unix.gettimeofday () in @@ -1864,7 +2192,7 @@ let http_render_page env path headers = if env_has env "render-to-html" then let render_call = List [Symbol "render-to-html"; List [Symbol "quote"; body_expr]; Env env] in - (match Sx_ref.eval_expr render_call (Env env) with + (match eval_with_io_render render_call env with | String s | RawHTML s -> s | v -> Sx_runtime.value_to_str v) else Sx_render.sx_render_to_html env body_expr env with e -> Printf.eprintf "[http-ssr] failed for %s: %s\n%!" path (Printexc.to_string e); "" in @@ -1876,6 +2204,7 @@ let http_render_page env path headers = Keyword "body-html"; String body_html; Keyword "component-defs"; get_shell "component-defs"; Keyword "component-hash"; get_shell "component-hash"; + Keyword "component-manifest"; get_shell "component-manifest"; Keyword "pages-sx"; get_shell "pages-sx"; Keyword "sx-css"; get_shell "sx-css"; Keyword "asset-url"; get_shell "asset-url"; @@ -1903,6 +2232,297 @@ let http_render_page env path headers = end end +(* JSON-encode a string for use in __sxResolve script tags *) +let json_encode_string s = + let buf = Buffer.create (String.length s + 16) in + Buffer.add_char buf '"'; + String.iter (fun c -> match c with + | '"' -> Buffer.add_string buf "\\\"" + | '\\' -> Buffer.add_string buf "\\\\" + | '\n' -> Buffer.add_string buf "\\n" + | '\r' -> Buffer.add_string buf "\\r" + | '\t' -> Buffer.add_string buf "\\t" + | c when Char.code c < 0x20 -> + Buffer.add_string buf (Printf.sprintf "\\u%04x" (Char.code c)) + | c -> Buffer.add_char buf c + ) s; + Buffer.add_char buf '"'; + Buffer.contents buf + +(* Bootstrap script that queues resolves arriving before sx.js loads. + Must match _SX_STREAMING_BOOTSTRAP in shared/sx/helpers.py *) +let _sx_streaming_bootstrap = + "" + +(* Build a resolve script tag. Must match _SX_STREAMING_RESOLVE in helpers.py *) +let sx_streaming_resolve_script id sx_source = + Printf.sprintf "" + (json_encode_string id) (json_encode_string sx_source) + +(* ====================================================================== *) +(* IO-resolving evaluator for streaming render *) +(* ====================================================================== *) + +(* Evaluate an expression with IO suspension handling. + Steps the CEK machine; when it suspends on an IO request, resolves + the request locally and resumes. Supports: io-sleep, import, helper. *) +let eval_with_io expr env = + let state = ref (Sx_ref.cek_step_loop (Sx_ref.make_cek_state expr (Env env) Nil)) in + while sx_truthy (Sx_ref.cek_suspended_p !state) do + let request = Sx_ref.cek_io_request !state in + let op = match request with + | Dict d -> (match Hashtbl.find_opt d "op" with Some (String s) -> s | Some (Symbol s) -> s | _ -> "") + | _ -> "" in + let args = match request with + | Dict d -> (match Hashtbl.find_opt d "args" with Some v -> v | None -> Nil) + | _ -> Nil in + let result = match op with + | "io-sleep" | "sleep" -> + let ms = match args with + | List (Number n :: _) -> n + | Number n -> n + | _ -> 0.0 in + Unix.sleepf (ms /. 1000.0); + Nil + | "import" -> + (* Library import — delegate to existing import hook *) + (try + let lib_name = match request with + | Dict d -> (match Hashtbl.find_opt d "library" with Some v -> v | _ -> args) + | _ -> args in + ignore lib_name; (* import handled by _import_hook if registered *) + Nil + with _ -> Nil) + | "text-measure" -> + let font = match args with + | List (String f :: _) -> f | _ -> "serif" in + let size = match args with + | List [_font; Number sz; _text] -> sz + | List [_font; Number sz] -> sz + | _ -> 16.0 in + let text = match args with + | List [_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 + | _ -> + Printf.eprintf "[io] unhandled IO op: %s\n%!" op; + Nil + in + state := Sx_ref.cek_step_loop (Sx_ref.cek_resume !state result) + done; + if sx_truthy (Sx_ref.cek_terminal_p !state) then Sx_ref.cek_value !state + else Nil + +(* ====================================================================== *) +(* Streaming page render — shell-first with chunked transfer encoding *) +(* ====================================================================== *) + +let http_render_page_streaming env path _headers fd page_name = + (* No send timeout for streaming — the alive check in write_chunk handles + broken pipe. Streaming clients may be slow to receive large shell chunks + while busy parsing/downloading other resources. *) + (try Unix.setsockopt_float fd Unix.SO_SNDTIMEO 30.0 with _ -> ()); + let t0 = Unix.gettimeofday () in + let page_def = try + match env_get env ("page:" ^ page_name) with Dict d -> d | _ -> raise Not_found + with _ -> + Printf.eprintf "[sx-stream] page def not found: page:%s\n%!" page_name; + let err = http_response ~status:500 "

Streaming page def not found

" in + let bytes = Bytes.of_string err in + (try ignore (Unix.write fd bytes 0 (Bytes.length bytes)) with _ -> ()); + (try Unix.close fd with _ -> ()); + raise Exit + in + + (* Extract streaming fields from page def *) + let shell_ast = match Hashtbl.find_opt page_def "shell" with Some v -> v | None -> Nil in + let data_ast = match Hashtbl.find_opt page_def "data" with Some v -> v | None -> Nil in + let content_ast = match Hashtbl.find_opt page_def "content" with Some v -> v | None -> Nil in + + (* Phase 1: Evaluate shell AST — contains ~suspense placeholders with fallbacks. + The :shell expression already includes the inner layout (e.g. ~layouts/doc), + so we only wrap in the outer layout (~shared:layout/app-body) for gutters. + NO inner layout wrapping — shell_ast already has it. *) + let shell_html = try + let outer_layout = get_app_str "outer-layout" "~shared:layout/app-body" in + let full_ast = List [Symbol outer_layout; Keyword "content"; shell_ast] in + let page_source = serialize_value full_ast in + (* aser → SSR *) + let body_result = + let call = List [Symbol "aser"; List [Symbol "quote"; full_ast]; Env env] in + Sx_ref.eval_expr call (Env env) in + let body_str = match body_result with + | String s | SxExpr s -> s | _ -> serialize_value body_result in + let body_html = try + let body_expr = match Sx_parser.parse_all body_str with + | [e] -> e | [] -> Nil | es -> List (Symbol "<>" :: es) in + if env_has env "render-to-html" then + let render_call = List [Symbol "render-to-html"; + List [Symbol "quote"; body_expr]; Env env] in + (match Sx_ref.eval_expr render_call (Env env) with + | String s | RawHTML s -> s | v -> Sx_runtime.value_to_str v) + else Sx_render.sx_render_to_html env body_expr env + with e -> Printf.eprintf "[sx-stream] SSR failed: %s\n%!" (Printexc.to_string e); "" in + + (* Build full page shell with body HTML *) + let get_shell name = try env_get env ("__shell-" ^ name) with _ -> Nil in + let shell_args = [ + Keyword "title"; String (get_app_str "title" "SX"); Keyword "csrf"; String ""; + Keyword "page-sx"; String page_source; + Keyword "body-html"; String body_html; + Keyword "component-defs"; get_shell "component-defs"; + Keyword "component-hash"; get_shell "component-hash"; + Keyword "component-manifest"; get_shell "component-manifest"; + Keyword "client-libs"; get_shell "client-libs"; + Keyword "pages-sx"; get_shell "pages-sx"; + Keyword "sx-css"; get_shell "sx-css"; + Keyword "asset-url"; get_shell "asset-url"; + Keyword "wasm-hash"; get_shell "wasm-hash"; + Keyword "platform-hash"; get_shell "platform-hash"; + Keyword "sxbc-hash"; get_shell "sxbc-hash"; + Keyword "inline-css"; get_shell "inline-css"; + Keyword "inline-head-js"; get_shell "inline-head-js"; + Keyword "init-sx"; get_shell "init-sx"; + Keyword "meta-html"; String ""; + ] in + let shell_sym = get_app_str "shell" "~shared:shell/sx-page-shell" in + let shell_call = List (Symbol shell_sym :: shell_args) in + if env_has env "render-to-html" then + let render_call = List [Symbol "render-to-html"; + List [Symbol "quote"; shell_call]; Env env] in + (match Sx_ref.eval_expr render_call (Env env) with + | String s | RawHTML s -> s | v -> Sx_runtime.value_to_str v) + else Sx_render.sx_render_to_html env shell_call env + with e -> + Printf.eprintf "[sx-stream] shell render failed: %s\n%!" (Printexc.to_string e); + "

Streaming shell render failed

" + in + let t1 = Unix.gettimeofday () in + + (* Phase 2: Send chunked header + shell HTML. + Strip closing from shell — resolve scripts must go INSIDE + the body, otherwise the browser's HTML parser ignores them. *) + let shell_body, shell_tail = + (* Find last and split there *) + let s = shell_html in + let body_close = "" in + let rec find_last i found = + if i < 0 then found + else if i + String.length body_close <= String.length s + && String.sub s i (String.length body_close) = body_close + then find_last (i - 1) i + else find_last (i - 1) found + in + let pos = find_last (String.length s - String.length body_close) (-1) in + if pos >= 0 then + (String.sub s 0 pos, String.sub s pos (String.length s - pos)) + else + (s, "") + in + let header = http_chunked_header () in + let header_bytes = Bytes.of_string header in + (try ignore (Unix.write fd header_bytes 0 (Bytes.length header_bytes)) with _ -> ()); + let alive = ref true in + alive := write_chunk fd shell_body; + (* Bootstrap resolve script — must come after shell so suspense elements exist *) + if !alive then alive := write_chunk fd _sx_streaming_bootstrap; + let t2 = Unix.gettimeofday () in + + (* Phase 3: Evaluate :data, render :content, flush resolve scripts. + Uses eval_with_io so :data expressions can perform IO (e.g. sleep, fetch). + Each data item is resolved independently — IO in one item doesn't block others + from being flushed as they complete. Bails out early on broken pipe. *) + let resolve_count = ref 0 in + if !alive && data_ast <> Nil && content_ast <> Nil then begin + (try + let data_result = eval_with_io data_ast env in + let t3_data = Unix.gettimeofday () in + + (* Determine single-stream vs multi-stream *) + let data_items = + let extract_items items = List.map (fun item -> + let stream_id = match item with + | Dict d -> (match Hashtbl.find_opt d "stream-id" with + | Some (String s) -> s | _ -> "stream-content") + | _ -> "stream-content" in + (item, stream_id)) items in + match data_result with + | Dict _ -> [(data_result, "stream-content")] + | List items -> extract_items items + | ListRef { contents = items } -> extract_items items + | _ -> + Printf.eprintf "[sx-stream] :data returned %s, expected dict or list\n%!" + (Sx_runtime.type_of data_result |> Sx_runtime.value_to_str); + [] + in + + (* For each data item, bind values and render :content. + If the item has a "delay" field, perform IO sleep before resolving. + Each item flushes its resolve script independently — the client sees + content appear progressively as each IO completes. *) + List.iter (fun (item, stream_id) -> + if !alive then + (try + (* IO sleep if delay specified — demonstrates async streaming *) + (match item with + | Dict d -> (match Hashtbl.find_opt d "delay" with + | Some (Number ms) when ms > 0.0 -> + Printf.eprintf "[sx-stream] %s: sleeping %.0fms for IO...\n%!" stream_id ms; + Unix.sleepf (ms /. 1000.0) + | _ -> ()) + | _ -> ()); + (* Create fresh env with data bindings *) + let content_env = { bindings = Hashtbl.create 16; parent = Some env } in + (match item with + | Dict d -> + Hashtbl.iter (fun k v -> + if k <> "stream-id" && k <> "__type" && k <> "delay" then begin + (* Normalize: underscores → hyphens *) + let norm_k = String.map (fun c -> if c = '_' then '-' else c) k in + ignore (env_bind content_env norm_k v); + if norm_k <> k then ignore (env_bind content_env k v) + end + ) d + | _ -> ()); + + (* aser :content in the data-bound env — also with IO resolution *) + let content_result = + let call = List [Symbol "aser"; List [Symbol "quote"; content_ast]; Env content_env] in + eval_with_io call content_env in + let sx_source = match content_result with + | String s | SxExpr s -> s | _ -> serialize_value content_result in + let resolve_script = sx_streaming_resolve_script stream_id sx_source in + alive := write_chunk fd resolve_script; + incr resolve_count + with e -> + (* Error boundary: emit error fallback for this slot *) + let msg = Printexc.to_string e in + Printf.eprintf "[sx-stream] resolve error for %s: %s\n%!" stream_id msg; + let error_sx = Printf.sprintf "(div :class \"text-rose-600 p-4 text-sm\" \"Error: %s\")" + (String.map (fun c -> if c = '"' then '\'' else c) msg) in + alive := write_chunk fd (sx_streaming_resolve_script stream_id error_sx); + incr resolve_count) + ) data_items; + let t3 = Unix.gettimeofday () in + Printf.eprintf "[sx-stream] %s shell=%.3fs flush=%.3fs data=%.3fs resolve=%.3fs total=%.3fs chunks=%d\n%!" + path (t1 -. t0) (t2 -. t1) (t3_data -. t2) (t3 -. t3_data) (t3 -. t0) !resolve_count + with e -> + Printf.eprintf "[sx-stream] data eval failed: %s\n%!" (Printexc.to_string e)) + end else + Printf.eprintf "[sx-stream] %s shell=%.3fs (no :data/:content)\n%!" path (t1 -. t0); + + (* Phase 4: Send closing tags + end chunked response *) + if !alive && shell_tail <> "" then ignore (write_chunk fd shell_tail); + end_chunked fd + (* ====================================================================== *) (* Static file serving + file hashing *) (* ====================================================================== *) @@ -1981,6 +2601,198 @@ let read_css_file path = In_channel.with_open_text path In_channel.input_all else "" +(* ── Content-addressed hash index ──────────────────────────────── + Merkle DAG over all definitions in env.bindings. + Each definition gets a SHA-256 hash of its *instantiated* form + (component references replaced with their hashes). *) + +type hash_index = { + name_to_hash : (string, string) Hashtbl.t; (** "~card" → "a1b2c3..." *) + hash_to_def : (string, string) Hashtbl.t; (** hash → instantiated definition text *) + hash_to_name : (string, string) Hashtbl.t; (** hash → "~card" *) + dependents : (string, string list) Hashtbl.t; (** "~card" → ["~my-page", ...] *) +} [@@warning "-69"] + +let _hash_index : hash_index option ref = ref None + +(** Canonical form for hashing — name excluded (it's the key, not content). + Includes params, affinity, has_children, and body with refs hashed. *) +let canonical_form_component (index : (string, string) Hashtbl.t) c = + let ps = String.concat " " ( + "&key" :: c.c_params @ + (if c.c_has_children then ["&rest"; "children"] else [])) in + Printf.sprintf "(defcomp (%s) :affinity \"%s\" %s)" + ps c.c_affinity (serialize_value_hashed index c.c_body) + +let canonical_form_island (index : (string, string) Hashtbl.t) i = + let ps = String.concat " " ( + "&key" :: i.i_params @ + (if i.i_has_children then ["&rest"; "children"] else [])) in + Printf.sprintf "(defisland (%s) %s)" + ps (serialize_value_hashed index i.i_body) + +let canonical_form_macro (index : (string, string) Hashtbl.t) m = + let ps = String.concat " " ( + m.m_params @ + (match m.m_rest_param with Some r -> ["&rest"; r] | None -> [])) in + Printf.sprintf "(defmacro (%s) %s)" + ps (serialize_value_hashed index m.m_body) + + +(** Compute truncated SHA-256 hash (16 hex chars = 64 bits). *) +let hash_string s = + String.sub (Digest.string s |> Digest.to_hex) 0 16 + +(** Build the Merkle hash index from env.bindings. + Topological sort: hash leaves first (no ~deps), propagate up. *) +let build_hash_index env = + let name_to_hash = Hashtbl.create 256 in + let hash_to_def = Hashtbl.create 256 in + let hash_to_name = Hashtbl.create 256 in + let dependents = Hashtbl.create 256 in + + (* Phase 0: hash client library source files as whole units. + Each file gets one hash. All (define name ...) forms in the file + map to that hash so any symbol triggers loading the whole file. *) + let project_dir = try Sys.getenv "SX_PROJECT_DIR" with Not_found -> "." in + let templates_dir = project_dir ^ "/shared/sx/templates" in + let client_lib_names = get_app_list "client-libs" ["tw-layout.sx"; "tw-type.sx"; "tw.sx"] in + List.iter (fun lib_name -> + let path = templates_dir ^ "/" ^ lib_name in + if Sys.file_exists path then begin + let src = In_channel.with_open_text path In_channel.input_all in + let h = hash_string src in + Hashtbl.replace hash_to_def h src; + (* Extract all (define name ...) forms and map each name to this hash *) + let exprs = try Sx_parser.parse_all src with _ -> [] in + let first_name = ref "" in + List.iter (fun expr -> + match expr with + | List (Symbol "define" :: Symbol name :: _) -> + Hashtbl.replace name_to_hash name h; + if !first_name = "" then first_name := name + | _ -> () + ) exprs; + (* Map the hash to the first define name for debuggability *) + if !first_name <> "" then + Hashtbl.replace hash_to_name h !first_name + end + ) client_lib_names; + + (* Phase 1: collect all component/island/macro definitions and their direct deps *) + let defs : (string * [ `Comp of component | `Island of island + | `Macro of macro ]) list ref = ref [] in + let deps : (string, string list) Hashtbl.t = Hashtbl.create 256 in + + Hashtbl.iter (fun sym v -> + let name = Sx_types.unintern sym in + match v with + | Component c when String.length name > 0 && name.[0] = '~' -> + let refs = collect_tilde_refs c.c_body in + defs := (name, `Comp c) :: !defs; + Hashtbl.replace deps name refs; + (* Register reverse deps *) + List.iter (fun dep -> + let prev = try Hashtbl.find dependents dep with Not_found -> [] in + Hashtbl.replace dependents dep (name :: prev) + ) refs + | Island i when String.length name > 0 && name.[0] = '~' -> + let refs = collect_tilde_refs i.i_body in + defs := (name, `Island i) :: !defs; + Hashtbl.replace deps name refs; + List.iter (fun dep -> + let prev = try Hashtbl.find dependents dep with Not_found -> [] in + Hashtbl.replace dependents dep (name :: prev) + ) refs + | Macro m when (match m.m_name with Some n -> String.length n > 0 | None -> false) -> + let refs = collect_tilde_refs m.m_body in + let mname = match m.m_name with Some n -> n | None -> name in + defs := (mname, `Macro m) :: !defs; + Hashtbl.replace deps mname refs; + List.iter (fun dep -> + let prev = try Hashtbl.find dependents dep with Not_found -> [] in + Hashtbl.replace dependents dep (mname :: prev) + ) refs + | _ -> () + ) env.bindings; + + (* Phase 2: Kahn's topological sort *) + let all_names = Hashtbl.create 256 in + List.iter (fun (name, _) -> Hashtbl.replace all_names name true) !defs; + (* In-degree: count how many of this def's deps are also in our set *) + let in_degree = Hashtbl.create 256 in + List.iter (fun (name, _) -> + let d = try Hashtbl.find deps name with Not_found -> [] in + let count = List.length (List.filter (fun dep -> Hashtbl.mem all_names dep) d) in + Hashtbl.replace in_degree name count + ) !defs; + + (* Queue: all defs with in-degree 0 (leaves) *) + let queue = Queue.create () in + List.iter (fun (name, _) -> + if Hashtbl.find in_degree name = 0 then Queue.push name queue + ) !defs; + + (* Lookup map for defs by name *) + let def_map = Hashtbl.create 256 in + List.iter (fun (name, def) -> Hashtbl.replace def_map name def) !defs; + + let processed = ref 0 in + + (* Phase 3: process in topological order *) + while not (Queue.is_empty queue) do + let name = Queue.pop queue in + incr processed; + (* All deps of this def are already hashed — compute canonical form *) + let canonical = match Hashtbl.find_opt def_map name with + | Some (`Comp c) -> canonical_form_component name_to_hash c + | Some (`Island i) -> canonical_form_island name_to_hash i + | Some (`Macro m) -> canonical_form_macro name_to_hash m + | None -> "" + in + if canonical <> "" then begin + let h = hash_string canonical in + Hashtbl.replace name_to_hash name h; + Hashtbl.replace hash_to_def h canonical; + Hashtbl.replace hash_to_name h name + end; + (* Decrease in-degree of dependents, enqueue if zero *) + let rev_deps = try Hashtbl.find dependents name with Not_found -> [] in + List.iter (fun dep_name -> + if Hashtbl.mem in_degree dep_name then begin + let d = Hashtbl.find in_degree dep_name in + Hashtbl.replace in_degree dep_name (d - 1); + if d - 1 = 0 then Queue.push dep_name queue + end + ) rev_deps + done; + + (* Any remaining defs with in-degree > 0 have circular deps — hash without ref replacement *) + if !processed < List.length !defs then begin + List.iter (fun (name, _) -> + if not (Hashtbl.mem name_to_hash name) then begin + let canonical = match Hashtbl.find_opt def_map name with + | Some (`Comp c) -> canonical_form_component name_to_hash c + | Some (`Island i) -> canonical_form_island name_to_hash i + | Some (`Macro m) -> canonical_form_macro name_to_hash m + | None -> "" + in + if canonical <> "" then begin + let h = hash_string canonical in + Hashtbl.replace name_to_hash name h; + Hashtbl.replace hash_to_def h canonical; + Hashtbl.replace hash_to_name h name + end + end + ) !defs + end; + + let idx = { name_to_hash; hash_to_def; hash_to_name; dependents } in + Printf.eprintf "[hash-index] %d definitions, %d hashes\n%!" + (List.length !defs) (Hashtbl.length name_to_hash); + _hash_index := Some idx; + idx + (** Pre-compute shell statics and inject into env as __shell-* vars. *) let http_inject_shell_statics env static_dir sx_sxc = @@ -2019,9 +2831,20 @@ let http_inject_shell_statics env static_dir sx_sxc = ) env.bindings; let raw_defs = Buffer.contents buf in (* Component-defs are inlined in . *) - let component_defs = raw_defs in + Escape . *) + let component_defs = + let len = String.length raw_defs in + let buf2 = Buffer.create (len + 64) in + for i = 0 to len - 1 do + if raw_defs.[i] = '<' && i + 1 < len && raw_defs.[i + 1] = '/' then begin + Buffer.add_string buf2 "<\\/"; + end else if raw_defs.[i] = '/' && i > 0 && raw_defs.[i - 1] = '<' then + () (* skip — already handled above *) + else + Buffer.add_char buf2 raw_defs.[i] + done; + Buffer.contents buf2 + in let component_hash = Digest.string component_defs |> Digest.to_hex in (* Compute per-file hashes for cache busting *) let wasm_hash = file_hash (static_dir ^ "/wasm/sx_browser.bc.wasm.js") in @@ -2033,6 +2856,74 @@ let http_inject_shell_statics env static_dir sx_sxc = read_css_file (static_dir ^ "/styles/" ^ name)) css_file_names) in ignore (env_bind env "__shell-component-defs" (String component_defs)); ignore (env_bind env "__shell-component-hash" (String component_hash)); + (* Build content-addressed hash index *) + let hidx = build_hash_index env in + (* Hash each .sxbc module individually and add to the hash index. + Each module's content is stored by hash; exported symbols map to the module hash. *) + let sxbc_dir = static_dir ^ "/wasm/sx" in + let module_manifest_path = sxbc_dir ^ "/module-manifest.sx" in + let module_hashes : (string, string) Hashtbl.t = Hashtbl.create 32 in (* module key → hash *) + (if Sys.file_exists module_manifest_path then begin + (* Read each .sxbc file, hash it, store in hash_to_def *) + if Sys.file_exists sxbc_dir && Sys.is_directory sxbc_dir then begin + let files = Array.to_list (Sys.readdir sxbc_dir) in + let sxbc_files = List.filter (fun f -> Filename.check_suffix f ".sxbc") files in + List.iter (fun fname -> + let fpath = sxbc_dir ^ "/" ^ fname in + let content = In_channel.with_open_bin fpath In_channel.input_all in + let h = hash_string content in + Hashtbl.replace hidx.hash_to_def h content; + Hashtbl.replace hidx.hash_to_name h fname; + (* Map filename (without ext) to hash for the modules section *) + Hashtbl.replace module_hashes fname h + ) sxbc_files + end + end); + (* Hash the WASM bootstrap files — these are the kernel scripts + that must load before anything else. *) + let wasm_dir = static_dir ^ "/wasm" in + let boot_files = ["sx_browser.bc.wasm.js"; "sx-platform.js"] in + let boot_hashes = List.filter_map (fun fname -> + let fpath = wasm_dir ^ "/" ^ fname in + if Sys.file_exists fpath then begin + let content = In_channel.with_open_bin fpath In_channel.input_all in + let h = hash_string content in + Hashtbl.replace hidx.hash_to_def h content; + Hashtbl.replace hidx.hash_to_name h fname; + Some (fname, h) + end else None + ) boot_files in + Printf.eprintf "[hash-index] %d module hashes, %d boot hashes\n%!" + (Hashtbl.length module_hashes) (List.length boot_hashes); + (* Build full manifest JSON: + {"v":1,"defs":{...},"modules":{...},"boot":[["file","hash"],...]} *) + let manifest_buf = Buffer.create 8192 in + Buffer.add_string manifest_buf "{\"v\":1,\"defs\":{"; + let first = ref true in + Hashtbl.iter (fun name hash -> + if not !first then Buffer.add_char manifest_buf ','; + first := false; + Buffer.add_string manifest_buf (Printf.sprintf "\"%s\":\"%s\"" + (escape_sx_string name) hash) + ) hidx.name_to_hash; + Buffer.add_string manifest_buf "},\"modules\":{"; + first := true; + Hashtbl.iter (fun fname hash -> + if not !first then Buffer.add_char manifest_buf ','; + first := false; + Buffer.add_string manifest_buf (Printf.sprintf "\"%s\":\"%s\"" + (escape_sx_string fname) hash) + ) module_hashes; + Buffer.add_string manifest_buf "},\"boot\":["; + first := true; + List.iter (fun (_fname, h) -> + if not !first then Buffer.add_char manifest_buf ','; + first := false; + Buffer.add_string manifest_buf (Printf.sprintf "\"%s\"" h) + ) boot_hashes; + Buffer.add_string manifest_buf "]}"; + let manifest_json = Buffer.contents manifest_buf in + ignore (env_bind env "__shell-component-manifest" (String manifest_json)); (* Build minimal pages-sx from defpage definitions in loaded .sx files. Scans all loaded .sx files in the component dirs for (defpage ...) forms. *) let pages_buf = Buffer.create 4096 in @@ -2059,8 +2950,12 @@ let http_inject_shell_statics env static_dir sx_sxc = | Some v -> serialize_value v | _ -> "" in let has_data = match extract_kw "data" rest with | Some _ -> true | None -> false in + let is_stream = match extract_kw "stream" rest with + | Some (Symbol "true") | Some (Bool true) -> true | _ -> false in if path_val <> "" then begin _defpage_paths := path_val :: !_defpage_paths; + if is_stream then + Hashtbl.replace _streaming_pages path_val name; Buffer.add_string pages_buf (Printf.sprintf "{:name \"%s\" :path \"%s\" :auth \"public\" :has-data %s :content \"%s\"}\n" name path_val (if has_data then "true" else "false") @@ -2077,6 +2972,9 @@ let http_inject_shell_statics env static_dir sx_sxc = Printf.eprintf "[sx-http] pages-sx: %d bytes (%d lines)\n%!" (String.length pages_sx) (List.length (String.split_on_char '\n' pages_sx)); + if Hashtbl.length _streaming_pages > 0 then + Printf.eprintf "[sx-http] streaming pages: %s\n%!" + (String.concat ", " (Hashtbl.fold (fun p n acc -> (p ^ "→" ^ n) :: acc) _streaming_pages [])); ignore (env_bind env "__shell-pages-sx" (String pages_sx)); ignore (env_bind env "__shell-sx-css" (String sx_css)); ignore (env_bind env "__shell-asset-url" (String "/static")); @@ -2219,16 +3117,23 @@ let http_setup_platform_constructors env = | [Env e] -> List (Hashtbl.fold (fun k _v acc -> String (Sx_types.unintern k) :: acc) e.bindings []) | _ -> List []) -let http_load_files env files = - (* Like cli_load_files but tolerant — logs errors, doesn't crash *) +let http_load_files ?(base_dir="") env files = + (* Like cli_load_files but tolerant — logs errors, doesn't crash. + When base_dir is set, unnamed definitions get path-derived names. *) List.iter (fun path -> if Sys.file_exists path then begin try + let prev_file = if Sx_types.env_has env "*current-file*" then Some (Sx_types.env_get env "*current-file*") else None in + ignore (Sx_types.env_bind env "*current-file*" (String path)); let exprs = Sx_parser.parse_file path in List.iter (fun expr -> - try ignore (Sx_ref.eval_expr expr (Env env)) + let expr' = if base_dir <> "" then inject_path_name expr path base_dir else expr in + try ignore (eval_expr_io expr' (Env env)) with e -> Printf.eprintf "[http-load] %s: %s\n%!" (Filename.basename path) (Printexc.to_string e) - ) exprs + ) exprs; + (match prev_file with + | Some v -> ignore (Sx_types.env_bind env "*current-file*" v) + | None -> ()) with e -> Printf.eprintf "[http-load] parse error %s: %s\n%!" path (Printexc.to_string e) end ) files; @@ -2517,6 +3422,17 @@ let http_setup_page_helpers env = with _ -> String (";; component " ^ name ^ " not found")) | _ -> raise (Eval_error "component-source: expected (name)")); + (* IO sleep primitive — used by streaming pages to simulate async IO delays. + Application code calls (io-sleep ms) which raises CekPerformRequest; + the streaming render's eval_with_io resolves it with Unix.sleepf. *) + bind "io-sleep" (fun args -> + let ms = match args with Number n :: _ -> n | _ -> 0.0 in + raise (Sx_types.CekPerformRequest ( + let d = Hashtbl.create 2 in + Hashtbl.replace d "op" (String "io-sleep"); + Hashtbl.replace d "args" (List [Number ms]); + Dict d))); + ignore bind (* suppress unused warning *) let http_mode port = @@ -2580,8 +3496,8 @@ let http_mode port = (* Files to skip — declarative metadata, not needed for rendering *) let skip_files = ["primitives.sx"; "types.sx"; "boundary.sx"; "harness.sx"; "eval-rules.sx"; "vm-inline.sx"] in - let skip_dirs = ["tests"; "test"; "plans"; "essays"; "spec"; "client-libs"] in - let rec load_dir dir = + let skip_dirs = ["tests"; "test"; "plans"; "essays"; "spec"; "client-libs"; "_test"] in + let rec load_dir ?(base="") dir = if Sys.file_exists dir && Sys.is_directory dir then begin let entries = Sys.readdir dir in Array.sort String.compare entries; @@ -2589,13 +3505,13 @@ let http_mode port = let path = dir ^ "/" ^ f in if Sys.is_directory path then begin if not (List.mem f skip_dirs) then - load_dir path + load_dir ~base path end else if Filename.check_suffix f ".sx" && not (List.mem f skip_files) && not (String.length f > 5 && String.sub f 0 5 = "test-") && not (Filename.check_suffix f ".test.sx") then - http_load_files env [path] + http_load_files ~base_dir:base env [path] ) entries end in @@ -2606,8 +3522,8 @@ let http_mode port = let docker_path = project_dir ^ "/sxc" in let dev_path = project_dir ^ "/sx/sxc" in if Sys.file_exists docker_path then docker_path else dev_path in - load_dir sx_sxc; - load_dir sx_sx; + load_dir ~base:sx_sxc sx_sxc; + load_dir ~base:sx_sx sx_sx; let t1 = Unix.gettimeofday () in Printf.eprintf "[sx-http] All files loaded in %.3fs\n%!" (t1 -. t0); (* Derive batchable_helpers from __io-registry *) @@ -2676,11 +3592,10 @@ let http_mode port = | _ -> raise (Eval_error "component-source: expected (name)")); let jt0 = Unix.gettimeofday () in let count = ref 0 in - (* Skip JIT pre-compilation — causes make-spread/assoc issues. - Pure CEK eval is stable. ~6s first render, ~1s subsequent. *) - let compiler_names : string list = [ - ] in - let _compiler_names_disabled = [ + (* Pre-compile the entire compiler — compile + helpers. + jit_compile_lambda calls compile directly via the VM when it has + bytecode, so all helper calls happen in one VM execution. *) + let compiler_names = [ "compile"; "compile-module"; "compile-expr"; "compile-symbol"; "compile-dict"; "compile-list"; "compile-if"; "compile-when"; "compile-and"; "compile-or"; "compile-begin"; "compile-let"; @@ -2711,10 +3626,6 @@ let http_mode port = narrower SX versions. The native assoc handles variadic key/value pairs which evaluator.sx requires. *) rebind_host_extensions env; - (* Sync host-only bindings to VM globals for CALL_PRIM *) - List.iter (fun name -> - try Hashtbl.replace _shared_vm_globals name (env_get env name) with _ -> () - ) ["make-spread"; "assoc"; "expand-components?"; "make-spread-string"]; ignore (env_bind env "assoc" (NativeFn ("assoc", fun args -> match args with | Dict d :: rest -> @@ -2742,6 +3653,7 @@ let http_mode port = let dev_path = project_dir ^ "/shared/static" in if Sys.file_exists docker_path then docker_path else dev_path in Printf.eprintf "[sx-http] static_dir=%s\n%!" static_dir; + _font_base := static_dir ^ "/fonts"; (* HTTP mode always expands components — bind once, shared across domains *) ignore (env_bind env "expand-components?" (NativeFn ("expand-components?", fun _args -> Bool true))); (* Inject shell statics with real file hashes, CSS, and pages registry *) @@ -2750,6 +3662,41 @@ let http_mode port = The env_bind hook keeps it in sync with any future bindings. *) (* Enable lazy JIT — compile lambdas to bytecode on first call *) register_jit_hook env; + (* Install global IO resolver so perform works inside aser/eval_expr. + This lets components call measure-text during server-side rendering. *) + Sx_types._cek_io_resolver := Some (fun request _state -> + (* Extract op and args from either Dict {op, args} or raw List/ListRef (op-symbol args...) *) + let op, args = match request with + | Dict d -> + let o = match Hashtbl.find_opt d "op" with Some (String s) -> s | Some (Symbol s) -> s | _ -> "" in + let a = match Hashtbl.find_opt d "args" with Some v -> v | None -> Nil in + (o, a) + | List (Symbol op_sym :: rest) | ListRef { contents = Symbol op_sym :: rest } -> (op_sym, List rest) + | List (String op_str :: rest) | ListRef { contents = String op_str :: rest } -> (op_str, List rest) + | _ -> ("", Nil) + in + match op with + | "text-measure" -> + let font = match args with + | List (String f :: _) -> f + | _ -> "serif" in + let size = match args with + | List [_font; Number sz; _text] -> sz + | List [_font; Number sz] -> sz + | _ -> 16.0 in + let text = match args with + | List [_font; _sz; String t] -> t + | _ -> "" in + let (width, height, ascent, descent) = measure_text_otfm font size text in + let d = Hashtbl.create 4 in + Hashtbl.replace d "width" (Number width); + Hashtbl.replace d "height" (Number height); + Hashtbl.replace d "ascent" (Number ascent); + Hashtbl.replace d "descent" (Number descent); + Dict d + | "io-sleep" | "sleep" -> Nil + | "import" -> Nil + | _ -> Nil); (* Response cache — path → full HTTP response string. Populated during pre-warm, serves cached responses in <0.1ms. Thread-safe: reads are lock-free (Hashtbl.find_opt is atomic for @@ -3047,9 +3994,135 @@ let http_mode port = (escape_sx_string (Printexc.to_string e))) in write_response fd response; true + end else if is_sx && String.length path > 6 && String.sub path 0 6 = "/sx/h/" then begin + let rest = String.sub path 6 (String.length path - 6) in + (* WASM companion assets: /sx/h/sx_browser.bc.wasm.assets/... → /static/wasm/... *) + if String.length rest > 26 && String.sub rest 0 26 = "sx_browser.bc.wasm.assets/" then begin + let asset_path = "/static/wasm/" ^ rest in + write_response fd (serve_static_file static_dir asset_path); true + end else begin + (* Content-addressed definition endpoint: /sx/h/{hash} *) + let hash = rest in + let resp = match !_hash_index with + | Some idx -> + (match Hashtbl.find_opt idx.hash_to_def hash with + | Some def -> + let name = match Hashtbl.find_opt idx.hash_to_name hash with + | Some n -> n | None -> "?" in + (* Detect content type from filename *) + let is_js = Filename.check_suffix name ".js" in + let ct = if is_js then "application/javascript" + else "text/sx; charset=utf-8" in + let body = if is_js then def + else Printf.sprintf ";; %s\n%s" name def in + Printf.sprintf + "HTTP/1.1 200 OK\r\n\ + Content-Type: %s\r\n\ + Content-Length: %d\r\n\ + Cache-Control: public, max-age=31536000, immutable\r\n\ + Access-Control-Allow-Origin: *\r\n\ + Connection: keep-alive\r\n\r\n%s" + ct (String.length body) body + | None -> + http_response ~status:404 "unknown hash") + | None -> + http_response ~status:503 "hash index not built" + in + write_response fd resp; true + end (* inner begin for hash vs wasm-assets *) end else if is_sx then begin + (* Streaming pages: chunked transfer, bypass cache. + Convert SX URL to flat defpage path: + /sx/(geography.(isomorphism.streaming)) → /geography/isomorphism/streaming + Strip prefix, remove parens, replace dots with slashes. *) + let page_path = + let raw = if String.length path > app_prefix_len + && String.sub path 0 app_prefix_len = app_prefix + then String.sub path app_prefix_len (String.length path - app_prefix_len) + else path in + let buf = Buffer.create (String.length raw + 1) in + Buffer.add_char buf '/'; + String.iter (fun c -> match c with + | '(' | ')' -> () + | '.' -> Buffer.add_char buf '/' + | c -> Buffer.add_char buf c + ) raw; + Buffer.contents buf in + let stream_page_name = Hashtbl.find_opt _streaming_pages page_path in + if stream_page_name <> None then begin + let sname = match stream_page_name with Some s -> s | None -> "" in + if is_ajax then begin + (* AJAX streaming: evaluate shell + data + content synchronously, + return fully-resolved SX wire format (no chunked transfer). *) + let response = try + let page_def = match env_get env ("page:" ^ sname) with Dict d -> d | _ -> raise Not_found in + let shell_ast = match Hashtbl.find_opt page_def "shell" with Some v -> v | None -> Nil in + let data_ast = match Hashtbl.find_opt page_def "data" with Some v -> v | None -> Nil in + let content_ast = match Hashtbl.find_opt page_def "content" with Some v -> v | None -> Nil in + (* Evaluate shell — provides nav + suspense skeletons *) + let shell_sx = + let call = List [Symbol "aser"; List [Symbol "quote"; shell_ast]; Env env] in + match Sx_ref.eval_expr call (Env env) with + | String s | SxExpr s -> s | v -> serialize_value v in + (* If we have data+content, resolve all slots and embed as OOB swaps *) + let resolve_oob = if data_ast <> Nil && content_ast <> Nil then begin + let data_result = try Sx_ref.eval_expr data_ast (Env env) with _ -> Nil in + let extract_sid items = List.map (fun item -> + let sid = match item with Dict d -> + (match Hashtbl.find_opt d "stream-id" with Some (String s) -> s | _ -> "stream-content") + | _ -> "stream-content" in (item, sid)) items in + let data_items = match data_result with + | Dict _ -> [(data_result, "stream-content")] + | List items -> extract_sid items + | ListRef { contents = items } -> extract_sid items + | _ -> [] in + let buf = Buffer.create 1024 in + List.iter (fun (item, stream_id) -> + try + let cenv = { bindings = Hashtbl.create 16; parent = Some env } in + (match item with Dict d -> + Hashtbl.iter (fun k v -> + if k <> "stream-id" && k <> "__type" then begin + let nk = String.map (fun c -> if c = '_' then '-' else c) k in + ignore (env_bind cenv nk v); + if nk <> k then ignore (env_bind cenv k v) + end) d | _ -> ()); + let cr = let call = List [Symbol "aser"; List [Symbol "quote"; content_ast]; Env cenv] in + Sx_ref.eval_expr call (Env cenv) in + let sx_src = match cr with String s | SxExpr s -> s | v -> serialize_value v in + (* OOB swap: replace suspense placeholder contents *) + Buffer.add_string buf + (Printf.sprintf "(div :id \"sx-suspense-%s\" :data-suspense \"%s\" :sx-swap-oob \"innerHTML\" :style \"display:contents\" %s)" + stream_id stream_id sx_src) + with e -> + Printf.eprintf "[sx-stream-ajax] resolve error %s: %s\n%!" stream_id (Printexc.to_string e) + ) data_items; + Buffer.contents buf + end else "" in + http_response ~content_type:"text/sx; charset=utf-8" (shell_sx ^ resolve_oob) + with e -> + Printf.eprintf "[sx-stream-ajax] error for %s: %s\n%!" path (Printexc.to_string e); + http_response ~status:500 ~content_type:"text/sx; charset=utf-8" + (Printf.sprintf "(div :class \"p-4 text-rose-600\" \"Streaming page error: %s\")" + (escape_sx_string (Printexc.to_string e))) + in + write_response fd response; true + end else begin + (* Full page streaming: run in a thread so the accept loop + stays unblocked for concurrent requests. *) + let _t = Thread.create (fun () -> + (try http_render_page_streaming env path [] fd sname + with Exit -> () + | e -> Printf.eprintf "[sx-stream] unexpected error for %s: %s\n%!" path (Printexc.to_string e); + (try Unix.close fd with _ -> ())) + ) () in + true + end + end else + let has_state_cookie = Hashtbl.mem _request_cookies "sx-home-stepper" in let cache_key = if is_ajax then "ajax:" ^ path else path in - match Hashtbl.find_opt response_cache cache_key with + match (if has_state_cookie then None + else Hashtbl.find_opt response_cache cache_key) with | Some cached -> write_response fd cached; true | None -> if is_ajax then begin @@ -3070,6 +4143,18 @@ let http_mode port = (escape_sx_string (Printexc.to_string e))) in write_response fd response; true + end else if has_state_cookie then begin + (* State cookie present — render on main thread so get-cookie works. + Don't cache: response varies by cookie value. *) + let response = + try match http_render_page env path [] with + | Some body -> http_response body + | None -> http_response ~status:404 "

Not Found

" + with e -> + Printf.eprintf "[render] Cookie render error for %s: %s\n%!" path (Printexc.to_string e); + http_response ~status:500 "

Error

" + in + write_response fd response; true end else begin (* Full page: queue to render worker *) Mutex.lock render_mutex; @@ -3183,6 +4268,163 @@ let http_mode port = Array.iter Domain.join workers) +(* --site mode: full site env (same setup as HTTP) + epoch protocol on stdin/stdout. + No HTTP server, no ports. Used by Playwright sandbox tests to render pages + as a pure function: URL → HTML via the render-page epoch command. *) +let site_mode () = + let env = make_server_env () in + http_setup_declarative_stubs env; + http_setup_platform_constructors env; + http_setup_page_helpers env; + (* Load all .sx files — same as http_mode *) + let project_dir = try Sys.getenv "SX_PROJECT_DIR" with Not_found -> + Sys.getcwd () in + let spec_base = project_dir ^ "/spec" in + let lib_base = project_dir ^ "/lib" in + let web_base = project_dir ^ "/web" in + let shared_sx = try Sys.getenv "SX_SHARED_DIR" with Not_found -> + let docker_path = project_dir ^ "/shared_sx" in + let dev_path = project_dir ^ "/shared/sx/templates" in + if Sys.file_exists docker_path then docker_path else dev_path in + let sx_sx = try Sys.getenv "SX_COMPONENTS_DIR" with Not_found -> + let docker_path = project_dir ^ "/components" in + let dev_path = project_dir ^ "/sx/sx" in + if Sys.file_exists docker_path then docker_path else dev_path in + let static_dir = try Sys.getenv "SX_STATIC_DIR" with Not_found -> + let docker_path = project_dir ^ "/static" in + let dev_path = project_dir ^ "/shared/static" in + if Sys.file_exists docker_path then docker_path else dev_path in + ignore (env_bind env "_project-dir" (String project_dir)); + ignore (env_bind env "_spec-dir" (String spec_base)); + ignore (env_bind env "_lib-dir" (String lib_base)); + ignore (env_bind env "_web-dir" (String web_base)); + _font_base := static_dir ^ "/fonts"; + _import_env := Some env; + let core_files = [ + spec_base ^ "/parser.sx"; spec_base ^ "/render.sx"; spec_base ^ "/signals.sx"; + lib_base ^ "/compiler.sx"; + web_base ^ "/adapter-html.sx"; web_base ^ "/adapter-sx.sx"; + web_base ^ "/io.sx"; web_base ^ "/web-forms.sx"; web_base ^ "/engine.sx"; + web_base ^ "/request-handler.sx"; web_base ^ "/page-helpers.sx"; + ] in + http_load_files env core_files; + let skip_files = ["primitives.sx"; "types.sx"; "boundary.sx"; + "harness.sx"; "eval-rules.sx"; "vm-inline.sx"] in + let skip_dirs = ["tests"; "test"; "plans"; "essays"; "spec"; "client-libs"] in + let rec load_dir ?(base="") dir = + if Sys.file_exists dir && Sys.is_directory dir then begin + let entries = Sys.readdir dir in + Array.sort String.compare entries; + Array.iter (fun f -> + let path = dir ^ "/" ^ f in + if Sys.is_directory path then begin + if not (List.mem f skip_dirs) then load_dir ~base path + end + else if Filename.check_suffix f ".sx" + && not (List.mem f skip_files) + && not (String.length f > 5 && String.sub f 0 5 = "test-") + && not (Filename.check_suffix f ".test.sx") then + http_load_files ~base_dir:base env [path] + ) entries + end + in + load_dir lib_base; + load_dir shared_sx; + let sx_sxc = try Sys.getenv "SX_SXC_DIR" with Not_found -> + let docker_path = project_dir ^ "/sxc" in + let dev_path = project_dir ^ "/sx/sxc" in + if Sys.file_exists docker_path then docker_path else dev_path in + load_dir ~base:sx_sxc sx_sxc; + load_dir ~base:sx_sx sx_sx; + (* IO registry + app config *) + (try match env_get env "__io-registry" with + | Dict registry -> + let batchable = Hashtbl.fold (fun name entry acc -> + match entry with + | Dict d -> (match Hashtbl.find_opt d "batchable" with + | Some (Bool true) -> name :: acc | _ -> acc) + | _ -> acc) registry [] in + if batchable <> [] then batchable_helpers := batchable + | _ -> () + with _ -> ()); + (try match env_get env "__app-config" with + | Dict d -> _app_config := Some d + | _ -> () + with _ -> ()); + (* SSR overrides *) + let bind name fn = ignore (env_bind env name (NativeFn (name, fn))) in + bind "effect" (fun _args -> Nil); + bind "register-in-scope" (fun _args -> Nil); + rebind_host_extensions env; + ignore (env_bind env "assoc" (NativeFn ("assoc", fun args -> + match args with + | Dict d :: rest -> + let d2 = Hashtbl.copy d in + let rec go = function + | [] -> Dict d2 + | String k :: v :: rest -> Hashtbl.replace d2 k v; go rest + | Keyword k :: v :: rest -> Hashtbl.replace d2 k v; go rest + | _ -> raise (Eval_error "assoc: pairs") + in go rest + | _ -> raise (Eval_error "assoc: dict + pairs")))); + ignore (env_bind env "expand-components?" (NativeFn ("expand-components?", fun _args -> Bool true))); + (* Shell statics for render-page *) + http_inject_shell_statics env static_dir sx_sxc; + (* No JIT in site mode — the lazy JIT hook can loop on complex ASTs + (known bug: project_jit_bytecode_bug.md). Pure CEK is slower but + correct. First renders take ~2-5s, subsequent ~0.5-1s with caching. *) + Printf.eprintf "[site] Ready — epoch protocol on stdin/stdout\n%!"; + send "(ready)"; + (* nav-urls helper — walk sx-nav-tree, collect (href label) pairs *) + let nav_urls () = + let tree = env_get env "sx-nav-tree" in + let urls = ref [] in + let rec walk node = match node with + | Dict d -> + let href = match Hashtbl.find_opt d "href" with Some (String s) -> s | _ -> "" in + let label = match Hashtbl.find_opt d "label" with Some (String s) -> s | _ -> "" in + if href <> "" then urls := (href, label) :: !urls; + (match Hashtbl.find_opt d "children" with + | Some (List items) | Some (ListRef { contents = items }) -> + List.iter walk items + | _ -> ()) + | _ -> () + in + walk tree; + let items = List.rev !urls in + "(" ^ String.concat " " (List.map (fun (h, l) -> + Printf.sprintf "(\"%s\" \"%s\")" (escape_sx_string h) (escape_sx_string l) + ) items) ^ ")" + in + (* Epoch protocol loop *) + (try + while true do + match read_line_blocking () with + | None -> exit 0 + | Some line -> + let line = String.trim line in + if line = "" then () + else begin + let exprs = Sx_parser.parse_all line in + match exprs with + | [List [Symbol "epoch"; Number n]] -> + current_epoch := int_of_float n + (* render-page: full SSR pipeline — URL → complete HTML *) + | [List [Symbol "render-page"; String path]] -> + (try match http_render_page env path [] with + | Some html -> send_ok_blob html + | None -> send_error ("render-page: no route for " ^ path) + with e -> send_error ("render-page: " ^ Printexc.to_string e)) + (* nav-urls: flat list of (href label) from nav tree *) + | [List [Symbol "nav-urls"]] -> + (try send_ok_raw (nav_urls ()) + with e -> send_error ("nav-urls: " ^ Printexc.to_string e)) + | [cmd] -> dispatch env cmd + | _ -> send_error ("Expected single command, got " ^ string_of_int (List.length exprs)) + end + done + with End_of_file -> ()) + let () = (* Check for CLI mode flags *) let args = Array.to_list Sys.argv in @@ -3190,6 +4432,7 @@ let () = else if List.mem "--render" args then cli_mode "render" else if List.mem "--aser-slot" args then cli_mode "aser-slot" else if List.mem "--aser" args then cli_mode "aser" + else if List.mem "--site" args then site_mode () else if List.mem "--http" args then begin (* Extract port: --http PORT *) let port = ref 8014 in