giles
ac65666f6f
- inject_path_name: strip _islands/ convention dirs from path-derived names - page-functions.sx: fix geography (→ ~geography) and isomorphism (→ ~etc/plan/isomorphic) - request-handler.sx: rewrite sx-eval-page to call page functions explicitly via env-get+apply, avoiding provide special form intercepting (provide) calls - sx_server.ml: set expand-components? on AJAX aser paths so server-side components expand for the browser (islands stay unexpanded for hydration) - Rename 19 component references in geography/spreads, geography/provide, geography/scopes to use path-qualified names matching inject_path_name output Co-Authored-By: Claude Opus 4.6 (1M context) <noreply@anthropic.com>
4523 lines
205 KiB
OCaml
4523 lines
205 KiB
OCaml
(** SX coroutine subprocess server.
|
|
|
|
Persistent process that accepts commands on stdin and writes
|
|
responses on stdout. All messages are single-line SX expressions,
|
|
newline-delimited.
|
|
|
|
Protocol:
|
|
Python → OCaml: (ping), (load path), (load-source src),
|
|
(eval src), (render src), (reset),
|
|
(io-response value)
|
|
OCaml → Python: (ready), (ok), (ok value), (error msg),
|
|
(io-request name args...)
|
|
|
|
IO primitives (query, action, request-arg, request-method, ctx)
|
|
yield (io-request ...) and block on stdin for (io-response ...). *)
|
|
|
|
(* Modules accessed directly — library is unwrapped *)
|
|
|
|
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 *)
|
|
(* ====================================================================== *)
|
|
|
|
(** Escape a string for embedding in an SX string literal. *)
|
|
let escape_sx_string s =
|
|
let len = String.length s in
|
|
let buf = Buffer.create (len + 16) in
|
|
for i = 0 to len - 1 do
|
|
match s.[i] 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"
|
|
| '<' when i + 7 < len && s.[i + 1] = '/' &&
|
|
(s.[i + 2] = 's' || s.[i + 2] = 'S') &&
|
|
String.lowercase_ascii (String.sub s (i + 2) 6) = "script" ->
|
|
(* Escape </script as <\\/script to prevent HTML parser closing the tag *)
|
|
Buffer.add_string buf "<\\\\/"
|
|
| c -> Buffer.add_char buf c
|
|
done;
|
|
Buffer.contents buf
|
|
|
|
(** Serialize a value to SX text (for io-request args). *)
|
|
let rec serialize_value = 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 -> s
|
|
| Keyword k -> ":" ^ k
|
|
| List items | ListRef { contents = items } ->
|
|
(* All lists: (items...) — no (list ...) wrapper.
|
|
Matches Python serialize() exactly. The SX source code itself uses
|
|
(list ...) where data lists are needed; the serializer preserves AST. *)
|
|
"(" ^ String.concat " " (List.map serialize_value items) ^ ")"
|
|
| Dict d ->
|
|
let pairs = Hashtbl.fold (fun k v acc ->
|
|
(Printf.sprintf ":%s %s" k (serialize_value v)) :: acc) d [] in
|
|
"{" ^ String.concat " " 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 v)) pairs in
|
|
"(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. *)
|
|
let current_epoch = ref 0
|
|
|
|
let send line =
|
|
print_string line;
|
|
print_char '\n';
|
|
flush stdout
|
|
|
|
let send_ok () = send (Printf.sprintf "(ok %d)" !current_epoch)
|
|
let send_ok_value v = send (Printf.sprintf "(ok %d %s)" !current_epoch (serialize_value v))
|
|
let send_error msg = send (Printf.sprintf "(error %d \"%s\")" !current_epoch (escape_sx_string msg))
|
|
|
|
(** Length-prefixed binary send — handles any content without escaping.
|
|
Sends: (ok-len EPOCH N)\n followed by exactly N bytes of raw data, then \n.
|
|
Python reads the length line, then reads exactly N bytes. *)
|
|
let send_ok_blob s =
|
|
let n = String.length s in
|
|
Printf.printf "(ok-len %d %d)\n" !current_epoch n;
|
|
print_string s;
|
|
print_char '\n';
|
|
flush stdout
|
|
|
|
(** Send a string value — use blob for anything that might contain
|
|
newlines, quotes, or be large. *)
|
|
let send_ok_string s = send_ok_blob s
|
|
|
|
(** Send raw SX wire format — may contain newlines in string literals. *)
|
|
let send_ok_raw s = send_ok_blob s
|
|
|
|
|
|
(* ====================================================================== *)
|
|
(* IO bridge — primitives that yield to Python *)
|
|
(* ====================================================================== *)
|
|
|
|
(** Read a line from stdin (blocking). *)
|
|
let read_line_blocking () =
|
|
try Some (input_line stdin)
|
|
with End_of_file -> None
|
|
|
|
(** Read exactly N bytes from stdin (blocking). *)
|
|
let read_exact_bytes n =
|
|
let buf = Bytes.create n in
|
|
really_input stdin buf 0 n;
|
|
Bytes.to_string buf
|
|
|
|
(** Read a length-prefixed blob from stdin.
|
|
Expects the next line to be "(blob N)" where N is byte count,
|
|
followed by exactly N bytes of raw data, then a newline. *)
|
|
let read_blob () =
|
|
match read_line_blocking () with
|
|
| None -> raise (Eval_error "read_blob: stdin closed")
|
|
| Some line ->
|
|
let line = String.trim line in
|
|
match Sx_parser.parse_all line with
|
|
| [List [Symbol "blob"; Number n]] ->
|
|
let len = int_of_float n in
|
|
let data = read_exact_bytes len in
|
|
(* consume trailing newline *)
|
|
(try ignore (input_line stdin) with End_of_file -> ());
|
|
data
|
|
| _ -> raise (Eval_error ("read_blob: expected (blob N), got: " ^ line))
|
|
|
|
(** Batch IO mode — collect requests during aser-slot, resolve after. *)
|
|
let io_batch_mode = ref false
|
|
let io_queue : (int * string * value list) list ref = ref []
|
|
let io_counter = ref 0
|
|
|
|
(* Scope stacks and cookies — primitives registered in sx_primitives.ml.
|
|
We reference the shared state for the IO bridge. *)
|
|
let _request_cookies = Sx_primitives._request_cookies
|
|
let _scope_stacks = Sx_primitives._scope_stacks
|
|
|
|
(* ── App config ─────────────────────────────────────────────────────── *)
|
|
(* 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
|
|
| Some d -> (match Hashtbl.find_opt d key with Some v -> v | None -> default)
|
|
| None -> default
|
|
|
|
let get_app_str key default =
|
|
match get_app_config key (String default) with String s -> s | _ -> default
|
|
|
|
let get_app_list key default =
|
|
match get_app_config key Nil with
|
|
| List l | ListRef { contents = l } ->
|
|
List.filter_map (function String s -> Some s | _ -> None) l
|
|
| _ -> default
|
|
|
|
(** Helpers safe to defer — pure functions whose results are only used
|
|
as rendering output (inlined into SX wire format), not in control flow. *)
|
|
let batchable_helpers = ref [
|
|
"highlight"; "component-source"
|
|
]
|
|
|
|
let is_batchable name args =
|
|
name = "helper" &&
|
|
match args with
|
|
| String h :: _ -> List.mem h !batchable_helpers
|
|
| _ -> false
|
|
|
|
(** Read an io-response from stdin, discarding stale messages from old epochs. *)
|
|
let rec read_io_response () =
|
|
match read_line_blocking () with
|
|
| None -> raise (Eval_error "IO bridge: stdin closed while waiting for io-response")
|
|
| Some line ->
|
|
let exprs = Sx_parser.parse_all line in
|
|
match exprs with
|
|
(* Epoch-tagged: (io-response EPOCH value) *)
|
|
| [List [Symbol "io-response"; Number n; value]]
|
|
when int_of_float n = !current_epoch -> value
|
|
| [List (Symbol "io-response" :: Number n :: values)]
|
|
when int_of_float n = !current_epoch ->
|
|
(match values with [v] -> v | _ -> List values)
|
|
(* Legacy untagged: (io-response value) — accept for backwards compat *)
|
|
| [List [Symbol "io-response"; value]] -> value
|
|
| [List (Symbol "io-response" :: values)] ->
|
|
(match values with [v] -> v | _ -> List values)
|
|
(* Stale epoch or unexpected — discard and retry *)
|
|
| _ ->
|
|
Printf.eprintf "[io] discarding stale message (%d chars, epoch=%d)\n%!"
|
|
(String.length line) !current_epoch;
|
|
read_io_response ()
|
|
|
|
(** Send an io-request — batch mode returns placeholder, else blocks. *)
|
|
let io_request name args =
|
|
if !io_batch_mode && is_batchable name args then begin
|
|
incr io_counter;
|
|
let id = !io_counter in
|
|
io_queue := (id, name, args) :: !io_queue;
|
|
(* Return SxExpr so serialize/inspect passes it through unquoted *)
|
|
SxExpr (Printf.sprintf "(\xc2\xabIO:%d\xc2\xbb)" id)
|
|
end else begin
|
|
let args_str = String.concat " " (List.map serialize_value args) in
|
|
send (Printf.sprintf "(io-request %d \"%s\" %s)" !current_epoch name args_str);
|
|
read_io_response ()
|
|
end
|
|
|
|
(** Read a batched io-response, discarding stale epoch messages. *)
|
|
let read_batched_io_response () =
|
|
let rec loop () =
|
|
match read_line_blocking () with
|
|
| None -> raise (Eval_error "IO batch: stdin closed")
|
|
| Some line ->
|
|
let exprs = Sx_parser.parse_all line in
|
|
match exprs with
|
|
(* Epoch-tagged: (io-response EPOCH value) *)
|
|
| [List [Symbol "io-response"; Number n; String s]]
|
|
when int_of_float n = !current_epoch -> s
|
|
| [List [Symbol "io-response"; Number n; SxExpr s]]
|
|
when int_of_float n = !current_epoch -> s
|
|
| [List [Symbol "io-response"; Number n; v]]
|
|
when int_of_float n = !current_epoch -> serialize_value v
|
|
(* Legacy untagged *)
|
|
| [List [Symbol "io-response"; String s]]
|
|
| [List [Symbol "io-response"; SxExpr s]] -> s
|
|
| [List [Symbol "io-response"; v]] -> serialize_value v
|
|
(* Stale — discard and retry *)
|
|
| _ ->
|
|
Printf.eprintf "[io-batch] discarding stale message (%d chars)\n%!"
|
|
(String.length line);
|
|
loop ()
|
|
in
|
|
loop ()
|
|
|
|
(** Flush batched IO: send all requests, read all responses, replace placeholders. *)
|
|
let flush_batched_io result_str =
|
|
let queue = List.rev !io_queue in
|
|
io_queue := [];
|
|
io_counter := 0;
|
|
if queue = [] then result_str
|
|
else begin
|
|
(* Send all batched requests with IDs, tagged with epoch *)
|
|
List.iter (fun (id, name, args) ->
|
|
let args_str = String.concat " " (List.map serialize_value args) in
|
|
send (Printf.sprintf "(io-request %d %d \"%s\" %s)" !current_epoch id name args_str)
|
|
) queue;
|
|
send (Printf.sprintf "(io-done %d %d)" !current_epoch (List.length queue));
|
|
(* Read all responses and replace placeholders *)
|
|
let final = ref result_str in
|
|
List.iter (fun (id, _, _) ->
|
|
let value_str = read_batched_io_response () in
|
|
let placeholder = Printf.sprintf "(\xc2\xabIO:%d\xc2\xbb)" id in
|
|
(* Replace all occurrences of this placeholder *)
|
|
let plen = String.length placeholder in
|
|
let buf = Buffer.create (String.length !final) in
|
|
let pos = ref 0 in
|
|
let s = !final in
|
|
let slen = String.length s in
|
|
while !pos <= slen - plen do
|
|
if String.sub s !pos plen = placeholder then begin
|
|
Buffer.add_string buf value_str;
|
|
pos := !pos + plen
|
|
end else begin
|
|
Buffer.add_char buf s.[!pos];
|
|
incr pos
|
|
end
|
|
done;
|
|
if !pos < slen then
|
|
Buffer.add_substring buf s !pos (slen - !pos);
|
|
final := Buffer.contents buf
|
|
) queue;
|
|
!final
|
|
end
|
|
|
|
(** Resolve a library spec to a file path.
|
|
(sx render) → spec/render.sx, (sx bytecode) → lib/bytecode.sx, etc.
|
|
Returns Some path or None if unknown. *)
|
|
let _lib_base = ref "lib"
|
|
let _spec_base = ref "spec"
|
|
let _web_base = ref "web"
|
|
|
|
let resolve_library_path lib_spec =
|
|
let parts = match lib_spec with List l | ListRef { contents = l } -> l | _ -> [] in
|
|
match List.map (fun v -> match v with Symbol s -> s | String s -> s | _ -> "") parts with
|
|
| ["sx"; name] ->
|
|
(* Check spec/ first, then lib/, then web/lib/ (dom.sx, browser.sx live there) *)
|
|
let spec_path = Filename.concat !_spec_base (name ^ ".sx") in
|
|
let lib_path = Filename.concat !_lib_base (name ^ ".sx") in
|
|
let web_lib_path = Filename.concat (Filename.concat !_web_base "lib") (name ^ ".sx") in
|
|
if Sys.file_exists spec_path then Some spec_path
|
|
else if Sys.file_exists lib_path then Some lib_path
|
|
else if Sys.file_exists web_lib_path then Some web_lib_path
|
|
else None
|
|
| ["web"; name] ->
|
|
let path = Filename.concat !_web_base (name ^ ".sx") in
|
|
let lib_path = Filename.concat (Filename.concat !_web_base "lib") (name ^ ".sx") in
|
|
if Sys.file_exists path then Some path
|
|
else if Sys.file_exists lib_path then Some lib_path
|
|
else None
|
|
| [prefix; name] ->
|
|
(* Generic: try prefix/name.sx *)
|
|
let path = Filename.concat prefix (name ^ ".sx") in
|
|
if Sys.file_exists path then Some path else None
|
|
| _ -> None
|
|
|
|
(** Load a library file — parse and evaluate all expressions in the global env.
|
|
The file should contain a define-library form that registers itself. *)
|
|
let _import_env : env option ref = ref None
|
|
|
|
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 (eval_expr_io expr (Env env))
|
|
with Eval_error msg ->
|
|
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. *)
|
|
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
|
|
let rec loop () =
|
|
while not (is_terminal !s) && not (is_suspended !s) do
|
|
s := Sx_ref.cek_step !s
|
|
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 args = let a = Sx_runtime.get_val request (String "args") in
|
|
(match a with List l -> l | _ -> [a]) in
|
|
io_request op args
|
|
in
|
|
s := Sx_ref.cek_resume !s response;
|
|
loop ()
|
|
end else
|
|
Sx_ref.cek_value !s
|
|
in
|
|
loop ()
|
|
|
|
(** IO-aware eval_expr — like eval_expr but handles IO suspension. *)
|
|
and eval_expr_io expr env =
|
|
let state = Sx_ref.make_cek_state expr env (List []) in
|
|
cek_run_with_io state
|
|
|
|
(** Bind IO primitives into the environment. *)
|
|
let setup_io_env env =
|
|
let bind name fn =
|
|
ignore (env_bind env name (NativeFn (name, fn)))
|
|
in
|
|
|
|
bind "query" (fun args ->
|
|
match args with
|
|
| service :: query_name :: rest ->
|
|
io_request "query" (service :: query_name :: rest)
|
|
| _ -> raise (Eval_error "query: expected (query service name ...)"));
|
|
|
|
bind "action" (fun args ->
|
|
match args with
|
|
| service :: action_name :: rest ->
|
|
io_request "action" (service :: action_name :: rest)
|
|
| _ -> raise (Eval_error "action: expected (action service name ...)"));
|
|
|
|
bind "request-arg" (fun args ->
|
|
match args with
|
|
| [name] -> io_request "request-arg" [name]
|
|
| [name; default] ->
|
|
let result = io_request "request-arg" [name] in
|
|
if result = Nil then default else result
|
|
| _ -> raise (Eval_error "request-arg: expected 1-2 args"));
|
|
|
|
bind "request-method" (fun _args ->
|
|
io_request "request-method" []);
|
|
|
|
bind "ctx" (fun args ->
|
|
match args with
|
|
| [key] -> io_request "ctx" [key]
|
|
| _ -> raise (Eval_error "ctx: expected 1 arg"));
|
|
|
|
bind "call-lambda" (fun args ->
|
|
(* Use cek_call instead of eval_expr to avoid re-evaluating
|
|
already-evaluated args. eval_expr copies Dict values (signals)
|
|
during evaluation, so mutations in the lambda body would affect
|
|
the copy, not the original. *)
|
|
match args with
|
|
| [fn_val; List call_args; Env _e] ->
|
|
Sx_ref.cek_call fn_val (List call_args)
|
|
| [fn_val; List call_args] ->
|
|
Sx_ref.cek_call fn_val (List call_args)
|
|
| _ -> raise (Eval_error "call-lambda: expected (fn args env?)"));
|
|
|
|
(* Register HO forms as callable NativeFn — the CEK machine handles them
|
|
as special forms, but the VM needs them as callable values in globals. *)
|
|
let ho_via_cek name =
|
|
bind name (fun args ->
|
|
Sx_ref.eval_expr (List (Symbol name :: args)) (Env env))
|
|
in
|
|
List.iter ho_via_cek [
|
|
"map"; "map-indexed"; "filter"; "reduce"; "some"; "every?"; "for-each";
|
|
];
|
|
|
|
(* Generic helper call — dispatches to Python page helpers *)
|
|
bind "helper" (fun args ->
|
|
io_request "helper" args)
|
|
|
|
|
|
(* ====================================================================== *)
|
|
(* Environment setup *)
|
|
(* ====================================================================== *)
|
|
|
|
(* ---- Browser API stubs (no-op for SSR) ---- *)
|
|
let setup_browser_stubs env =
|
|
let bind name fn = ignore (env_bind env name (NativeFn (name, fn))) in
|
|
bind "local-storage-get" (fun _args -> Nil);
|
|
bind "local-storage-set" (fun _args -> Nil);
|
|
bind "dom-listen" (fun _args -> NativeFn ("noop", fun _ -> Nil));
|
|
bind "dom-dispatch" (fun _args -> Nil);
|
|
bind "dom-set-data" (fun _args -> Nil);
|
|
bind "dom-get-data" (fun _args -> Nil);
|
|
bind "event-detail" (fun _args -> Nil);
|
|
bind "promise-then" (fun _args -> Nil);
|
|
bind "promise-delayed" (fun args ->
|
|
match args with _ :: [v] -> v | _ -> Nil);
|
|
bind "schedule-idle" (fun _args -> Nil);
|
|
bind "dom-query" (fun _args -> Nil);
|
|
bind "dom-query-all" (fun _args -> List []);
|
|
bind "dom-set-prop" (fun _args -> Nil);
|
|
bind "dom-get-attr" (fun _args -> Nil);
|
|
bind "dom-set-attr" (fun _args -> Nil);
|
|
bind "dom-text-content" (fun _args -> String "");
|
|
bind "dom-set-text-content" (fun _args -> Nil);
|
|
bind "dom-body" (fun _args -> Nil);
|
|
bind "dom-create-element" (fun _args -> Nil);
|
|
bind "dom-append" (fun _args -> Nil);
|
|
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);
|
|
(* 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 =
|
|
List.iter (fun name ->
|
|
try ignore (env_bind env name (Sx_primitives.get_primitive name))
|
|
with _ -> ()
|
|
) ["scope-push!"; "scope-pop!"; "scope-peek"; "context";
|
|
"collect!"; "collected"; "clear-collected!";
|
|
"scope-emit!"; "emit!"; "emitted"; "scope-emitted";
|
|
"scope-collected"; "scope-clear-collected!";
|
|
"provide-push!"; "provide-pop!";
|
|
"get-cookie"; "set-cookie"];
|
|
ignore (env_bind env "sx-context" (Sx_primitives.get_primitive "context"))
|
|
|
|
(* ---- CEK evaluator bridge ---- *)
|
|
let setup_evaluator_bridge env =
|
|
let bind name fn = ignore (env_bind env name (NativeFn (name, fn))) in
|
|
bind "eval-expr" (fun args ->
|
|
match args with
|
|
| [expr; e] -> Sx_ref.eval_expr expr (Env (Sx_runtime.unwrap_env e))
|
|
| [expr] -> Sx_ref.eval_expr expr (Env env)
|
|
| _ -> raise (Eval_error "eval-expr: expected (expr env?)"));
|
|
bind "trampoline" (fun args ->
|
|
match args with
|
|
| [v] ->
|
|
let rec resolve v = match v with
|
|
| Thunk (expr, env) -> resolve (Sx_ref.eval_expr expr (Env env))
|
|
| _ -> v
|
|
in resolve v
|
|
| _ -> raise (Eval_error "trampoline: expected 1 arg"));
|
|
bind "call-lambda" (fun args ->
|
|
(* Use cek_call instead of eval_expr to avoid re-evaluating
|
|
already-evaluated args. eval_expr copies Dict values (signals)
|
|
during evaluation, so mutations in the lambda body would affect
|
|
the copy, not the original. *)
|
|
match args with
|
|
| [fn_val; List call_args; Env _e] ->
|
|
Sx_ref.cek_call fn_val (List call_args)
|
|
| [fn_val; List call_args] ->
|
|
Sx_ref.cek_call fn_val (List call_args)
|
|
| _ -> raise (Eval_error "call-lambda: expected (fn args env?)"));
|
|
bind "cek-try" (fun args ->
|
|
match args with
|
|
| [thunk; handler] ->
|
|
(try Sx_ref.cek_call thunk Nil
|
|
with Eval_error msg ->
|
|
let enhanced = Sx_ref.enhance_error_with_trace msg in
|
|
Sx_ref.cek_call handler (List [String enhanced]))
|
|
| [thunk] ->
|
|
(try let r = Sx_ref.cek_call thunk Nil in
|
|
List [Symbol "ok"; r]
|
|
with Eval_error msg ->
|
|
let enhanced = Sx_ref.enhance_error_with_trace msg in
|
|
List [Symbol "error"; String enhanced])
|
|
| _ -> Nil);
|
|
bind "cek-call" (fun args ->
|
|
match args with
|
|
| [fn_val; List call_args] -> Sx_ref.cek_call fn_val (List call_args)
|
|
| [fn_val; Nil] -> Sx_ref.cek_call fn_val (List [])
|
|
| [fn_val] -> Sx_ref.cek_call fn_val (List [])
|
|
| _ -> Nil);
|
|
bind "expand-macro" (fun args ->
|
|
match args with
|
|
| [Macro m; List macro_args; Env e] ->
|
|
let body_env = { bindings = Hashtbl.create 16; parent = Some e } in
|
|
List.iteri (fun i p ->
|
|
let v = if i < List.length macro_args then List.nth macro_args i else Nil in
|
|
Hashtbl.replace body_env.bindings (Sx_types.intern p) v
|
|
) m.m_params;
|
|
Sx_ref.eval_expr m.m_body (Env body_env)
|
|
| _ -> raise (Eval_error "expand-macro: expected (macro args env)"));
|
|
bind "qq-expand-runtime" (fun args ->
|
|
match args with
|
|
| [template] -> Sx_ref.qq_expand template (Env env)
|
|
| [template; Env e] -> Sx_ref.qq_expand template (Env e)
|
|
| _ -> Nil);
|
|
bind "register-special-form!" (fun args ->
|
|
match args with
|
|
| [String name; handler] ->
|
|
ignore (Sx_ref.register_special_form (String name) handler); Nil
|
|
| _ -> raise (Eval_error "register-special-form!: expected (name handler)"));
|
|
ignore (env_bind env "*custom-special-forms*" Sx_ref.custom_special_forms);
|
|
ignore (Sx_ref.register_special_form (String "<>") (NativeFn ("<>", fun args ->
|
|
List (List.map (fun a -> Sx_ref.eval_expr a (Env env)) args))))
|
|
|
|
(* ---- Type predicates and introspection ---- *)
|
|
let setup_introspection env =
|
|
let bind name fn = ignore (env_bind env name (NativeFn (name, fn))) in
|
|
bind "thunk?" (fun args -> match args with [Thunk _] -> Bool true | _ -> Bool false);
|
|
bind "thunk-expr" (fun args -> match args with [v] -> thunk_expr v | _ -> Nil);
|
|
bind "thunk-env" (fun args -> match args with [v] -> thunk_env v | _ -> Nil);
|
|
bind "lambda?" (fun args -> match args with [Lambda _] -> Bool true | _ -> Bool false);
|
|
bind "macro?" (fun args -> match args with [Macro _] -> Bool true | _ -> Bool false);
|
|
bind "island?" (fun args -> match args with [Island _] -> Bool true | _ -> Bool false);
|
|
bind "component?" (fun args ->
|
|
match args with [Component _] | [Island _] -> Bool true | _ -> Bool false);
|
|
bind "callable?" (fun args ->
|
|
match args with [NativeFn _] | [Lambda _] | [Component _] | [Island _] -> Bool true | _ -> Bool false);
|
|
bind "spread?" (fun args -> match args with [Spread _] -> Bool true | _ -> Bool false);
|
|
bind "continuation?" (fun args ->
|
|
match args with [Continuation _] -> Bool true | [_] -> Bool false | _ -> Bool false);
|
|
bind "lambda-params" (fun args ->
|
|
match args with [Lambda l] -> List (List.map (fun s -> String s) l.l_params) | _ -> List []);
|
|
bind "lambda-body" (fun args -> match args with [Lambda l] -> l.l_body | _ -> Nil);
|
|
bind "lambda-closure" (fun args ->
|
|
match args with [Lambda l] -> Env l.l_closure | _ -> Dict (Hashtbl.create 0));
|
|
bind "component-name" (fun args ->
|
|
match args with [Component c] -> String c.c_name | [Island i] -> String i.i_name | _ -> String "");
|
|
bind "component-closure" (fun args ->
|
|
match args with [Component c] -> Env c.c_closure | [Island i] -> Env i.i_closure | _ -> Dict (Hashtbl.create 0));
|
|
bind "component-params" (fun args ->
|
|
match args with
|
|
| [Component c] -> List (List.map (fun s -> String s) c.c_params)
|
|
| [Island i] -> List (List.map (fun s -> String s) i.i_params)
|
|
| _ -> Nil);
|
|
bind "component-body" (fun args ->
|
|
match args with [Component c] -> c.c_body | [Island i] -> i.i_body | _ -> Nil);
|
|
let has_children_impl = NativeFn ("component-has-children?", fun args ->
|
|
match args with [Component c] -> Bool c.c_has_children | [Island i] -> Bool i.i_has_children | _ -> Bool false) in
|
|
ignore (env_bind env "component-has-children" has_children_impl);
|
|
ignore (env_bind env "component-has-children?" has_children_impl);
|
|
bind "component-affinity" (fun args ->
|
|
match args with [Component c] -> String c.c_affinity | [Island _] -> String "client" | _ -> String "auto");
|
|
bind "spread-attrs" (fun args ->
|
|
match args with
|
|
| [Spread pairs] ->
|
|
let d = Hashtbl.create 4 in List.iter (fun (k, v) -> Hashtbl.replace d k v) pairs; Dict d
|
|
| _ -> Dict (Hashtbl.create 0));
|
|
bind "make-spread" (fun args ->
|
|
match args with
|
|
| [Dict d] -> Spread (Hashtbl.fold (fun k v acc -> (k, v) :: acc) d [])
|
|
| _ -> Nil)
|
|
|
|
(* ---- Type operations, string/number/env helpers ---- *)
|
|
(* ---- Core runtime operations (assert, append!, apply, etc.) ---- *)
|
|
let setup_core_operations env =
|
|
let bind name fn = ignore (env_bind env name (NativeFn (name, fn))) in
|
|
bind "assert" (fun args ->
|
|
match args with
|
|
| [cond] -> if not (sx_truthy cond) then raise (Eval_error "Assertion failed"); Bool true
|
|
| [cond; String msg] -> if not (sx_truthy cond) then raise (Eval_error ("Assertion error: " ^ msg)); Bool true
|
|
| [cond; msg] -> if not (sx_truthy cond) then raise (Eval_error ("Assertion error: " ^ value_to_string msg)); Bool true
|
|
| _ -> raise (Eval_error "assert: expected 1-2 args"));
|
|
bind "append!" (fun args ->
|
|
match args with
|
|
| [ListRef r; v] -> r := !r @ [v]; ListRef r
|
|
| [List items; v] -> List (items @ [v])
|
|
| _ -> raise (Eval_error "append!: expected list and value"));
|
|
bind "make-raw-html" (fun args ->
|
|
match args with [String s] -> RawHTML s | [v] -> RawHTML (value_to_string v) | _ -> Nil);
|
|
bind "raw-html-content" (fun args ->
|
|
match args with [RawHTML s] -> String s | [String s] -> String s | _ -> String "");
|
|
bind "empty-dict?" (fun args ->
|
|
match args with [Dict d] -> Bool (Hashtbl.length d = 0) | _ -> Bool true);
|
|
bind "for-each-indexed" (fun args ->
|
|
match args with
|
|
| [fn_val; List items] | [fn_val; ListRef { contents = items }] ->
|
|
List.iteri (fun i item ->
|
|
ignore (Sx_ref.eval_expr (List [fn_val; Number (float_of_int i); item]) (Env env))
|
|
) items; Nil
|
|
| _ -> Nil);
|
|
bind "equal?" (fun args -> match args with [a; b] -> Bool (a = b) | _ -> raise (Eval_error "equal?: expected 2 args"));
|
|
bind "identical?" (fun args -> match args with [a; b] -> Bool (a == b) | _ -> raise (Eval_error "identical?: expected 2 args"));
|
|
bind "apply" (fun args ->
|
|
match args with
|
|
| f :: rest ->
|
|
let all_args = match List.rev rest with List last :: prefix -> List.rev prefix @ last | _ -> rest in
|
|
Sx_runtime.sx_call f all_args
|
|
| _ -> raise (Eval_error "apply: expected function and args"));
|
|
bind "cond-scheme?" (fun args -> match args with [clauses] -> Sx_ref.cond_scheme_p clauses | _ -> Bool false);
|
|
bind "is-else-clause?" (fun args -> match args with [test] -> Sx_ref.is_else_clause test | _ -> Bool false);
|
|
bind "primitive?" (fun args ->
|
|
match args with
|
|
| [String name] -> Bool (Sx_primitives.is_primitive name ||
|
|
(try (match env_get env name with NativeFn _ -> true | _ -> false) with _ -> false))
|
|
| _ -> Bool false);
|
|
bind "get-primitive" (fun args ->
|
|
match args with
|
|
| [String name] -> (try Sx_primitives.get_primitive name with _ -> try env_get env name with _ -> Nil)
|
|
| _ -> Nil);
|
|
bind "make-continuation" (fun args ->
|
|
match args with [f] -> Continuation ((fun v -> Sx_runtime.sx_call f [v]), None) | _ -> raise (Eval_error "make-continuation: expected 1 arg"))
|
|
|
|
(* ---- Type constructors and symbol operations ---- *)
|
|
let setup_type_constructors env =
|
|
let bind name fn = ignore (env_bind env name (NativeFn (name, fn))) in
|
|
bind "upcase" (fun args -> match args with [String s] -> String (String.uppercase_ascii s) | _ -> raise (Eval_error "upcase: expected string"));
|
|
bind "downcase" (fun args -> match args with [String s] -> String (String.lowercase_ascii s) | _ -> raise (Eval_error "downcase: expected string"));
|
|
bind "make-keyword" (fun args -> match args with [String s] -> Keyword s | _ -> raise (Eval_error "make-keyword: expected string"));
|
|
bind "keyword-name" (fun args -> match args with [Keyword k] -> String k | _ -> raise (Eval_error "keyword-name: expected keyword"));
|
|
bind "symbol-name" (fun args -> match args with [Symbol s] -> String s | _ -> raise (Eval_error "symbol-name: expected symbol"));
|
|
bind "make-symbol" (fun args -> match args with [String s] -> Symbol s | [v] -> Symbol (value_to_string v) | _ -> raise (Eval_error "make-symbol: expected 1 arg"));
|
|
bind "make-sx-expr" (fun args -> match args with [String s] -> SxExpr s | _ -> raise (Eval_error "make-sx-expr: expected string"));
|
|
bind "sx-expr-source" (fun args -> match args with [SxExpr s] -> String s | [String s] -> String s | _ -> raise (Eval_error "sx-expr-source: expected sx-expr or string"));
|
|
bind "sx-serialize" (fun args -> match args with [v] -> String (inspect v) | _ -> raise (Eval_error "sx-serialize: expected 1 arg"));
|
|
bind "is-html-tag?" (fun args -> match args with [String s] -> Bool (Sx_render.is_html_tag s) | _ -> Bool false);
|
|
bind "string-length" (fun args -> match args with [String s] -> Number (float_of_int (String.length s)) | _ -> raise (Eval_error "string-length: expected string"));
|
|
bind "dict-get" (fun args -> match args with [Dict d; String k] -> dict_get d k | [Dict d; Keyword k] -> dict_get d k | _ -> raise (Eval_error "dict-get: expected dict and key"));
|
|
bind "escape-string" (fun args ->
|
|
match args with
|
|
| [String s] ->
|
|
let buf = Buffer.create (String.length s) in
|
|
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 -> Buffer.add_char buf c) s;
|
|
String (Buffer.contents buf)
|
|
| _ -> raise (Eval_error "escape-string: expected string"));
|
|
bind "random-int" (fun args ->
|
|
match args with
|
|
| [Number lo; Number hi] ->
|
|
let lo = int_of_float lo and hi = int_of_float hi in
|
|
Number (float_of_int (lo + Random.int (max 1 (hi - lo + 1))))
|
|
| _ -> raise (Eval_error "random-int: expected (low high)"));
|
|
bind "parse" (fun args ->
|
|
match args with
|
|
| [String s] | [SxExpr s] ->
|
|
let exprs = Sx_parser.parse_all s in
|
|
(match exprs with [e] -> e | _ -> List exprs)
|
|
| [v] ->
|
|
(* Already a value — return as-is *)
|
|
v
|
|
| _ -> raise (Eval_error "parse: expected string"));
|
|
(* Native bytecode compiler — bootstrapped from lib/compiler.sx *)
|
|
bind "compile" (fun args ->
|
|
match args with [expr] -> Sx_compiler.compile expr | _ -> Nil);
|
|
bind "compile-module" (fun args ->
|
|
match args with [exprs] -> Sx_compiler.compile_module exprs | _ -> Nil);
|
|
bind "parse-int" (fun args ->
|
|
match args with
|
|
| [String s] -> (try Number (float_of_int (int_of_string s)) with _ -> Nil)
|
|
| [String s; default_val] -> (try Number (float_of_int (int_of_string s)) with _ -> default_val)
|
|
| [Number n] | [Number n; _] -> Number (Float.round n)
|
|
| [_; default_val] -> default_val | _ -> Nil);
|
|
bind "parse-number" (fun args -> match args with [String s] -> (try Number (float_of_string s) with _ -> Nil) | _ -> Nil)
|
|
|
|
(* ---- Character classification (platform primitives for spec/parser.sx) ---- *)
|
|
let setup_character_classification env =
|
|
let bind name fn = ignore (env_bind env name (NativeFn (name, fn))) in
|
|
bind "ident-start?" (fun args ->
|
|
match args with
|
|
| [String s] when String.length s = 1 ->
|
|
let c = s.[0] in
|
|
Bool (c >= 'a' && c <= 'z' || c >= 'A' && c <= 'Z' || c = '_' || c = '~'
|
|
|| c = '!' || c = '?' || c = '+' || c = '-' || c = '*' || c = '/'
|
|
|| c = '=' || c = '<' || c = '>' || c = '&' || c = '|' || c = '%'
|
|
|| c = '^' || c = '$' || c = '#')
|
|
| _ -> Bool false);
|
|
bind "ident-char?" (fun args ->
|
|
match args with
|
|
| [String s] when String.length s = 1 ->
|
|
let c = s.[0] in
|
|
Bool (c >= 'a' && c <= 'z' || c >= 'A' && c <= 'Z' || c = '_' || c = '~'
|
|
|| c = '!' || c = '?' || c = '+' || c = '-' || c = '*' || c = '/'
|
|
|| c = '=' || c = '<' || c = '>' || c = '&' || c = '|' || c = '%'
|
|
|| c = '^' || c = '$' || c = '#'
|
|
|| c >= '0' && c <= '9' || c = '.' || c = ':')
|
|
| _ -> Bool false);
|
|
bind "char-numeric?" (fun args ->
|
|
match args with [String s] when String.length s = 1 -> Bool (s.[0] >= '0' && s.[0] <= '9') | _ -> Bool false)
|
|
|
|
(* ---- Env operations (env-get, env-has?, env-bind!, etc.) ---- *)
|
|
let setup_env_operations env =
|
|
let bind name fn = ignore (env_bind env name (NativeFn (name, fn))) in
|
|
let uw = Sx_runtime.unwrap_env in
|
|
bind "env-get" (fun args -> match args with [e; String k] -> Sx_types.env_get (uw e) k | [e; Keyword k] -> Sx_types.env_get (uw e) k | _ -> raise (Eval_error "env-get: expected env and string"));
|
|
bind "env-has?" (fun args -> match args with [e; String k] -> Bool (Sx_types.env_has (uw e) k) | [e; Keyword k] -> Bool (Sx_types.env_has (uw e) k) | _ -> raise (Eval_error "env-has?: expected env and string"));
|
|
bind "env-bind!" (fun args -> match args with [e; String k; v] -> Sx_types.env_bind (uw e) k v | [e; Keyword k; v] -> Sx_types.env_bind (uw e) k v | _ -> raise (Eval_error "env-bind!: expected env, key, value"));
|
|
bind "env-set!" (fun args -> match args with [e; String k; v] -> Sx_types.env_set (uw e) k v | [e; Keyword k; v] -> Sx_types.env_set (uw e) k v | _ -> raise (Eval_error "env-set!: expected env, key, value"));
|
|
bind "env-extend" (fun args -> match args with [e] -> Env (Sx_types.env_extend (uw e)) | _ -> raise (Eval_error "env-extend: expected env"));
|
|
bind "env-merge" (fun args -> match args with [a; b] -> Sx_runtime.env_merge a b | _ -> raise (Eval_error "env-merge: expected 2 envs"))
|
|
|
|
(* ---- Strict mode (gradual type system support) ---- *)
|
|
let setup_strict_mode env =
|
|
let bind name fn = ignore (env_bind env name (NativeFn (name, fn))) in
|
|
ignore (env_bind env "*strict*" (Bool false));
|
|
ignore (env_bind env "*prim-param-types*" Nil);
|
|
bind "set-strict!" (fun args -> match args with [v] -> Sx_ref._strict_ref := v; ignore (env_set env "*strict*" v); Nil | _ -> raise (Eval_error "set-strict!: expected 1 arg"));
|
|
bind "set-prim-param-types!" (fun args -> match args with [v] -> Sx_ref._prim_param_types_ref := v; ignore (env_set env "*prim-param-types*" v); Nil | _ -> raise (Eval_error "set-prim-param-types!: expected 1 arg"));
|
|
bind "component-param-types" (fun _args -> Nil);
|
|
bind "component-set-param-types!" (fun _args -> Nil);
|
|
bind "component-file" (fun args -> match args with [v] -> component_file v | _ -> Nil);
|
|
bind "component-set-file!" (fun args -> match args with [v; f] -> component_set_file v f | _ -> Nil)
|
|
|
|
(* ---- IO helpers routed to Python bridge ---- *)
|
|
let _pending_response_status = ref 200
|
|
let setup_io_bridges env =
|
|
let bind name fn = ignore (env_bind env name (NativeFn (name, fn))) in
|
|
bind "json-encode" (fun args -> io_request "helper" (String "json-encode" :: args));
|
|
bind "into" (fun args -> io_request "helper" (String "into" :: args));
|
|
bind "sleep" (fun args -> io_request "sleep" args);
|
|
bind "set-response-status" (fun args -> match args with
|
|
| [Number n] -> _pending_response_status := int_of_float n; Nil
|
|
| _ -> Nil);
|
|
bind "set-response-header" (fun args -> io_request "set-response-header" args)
|
|
|
|
(* ---- HTML tag functions (div, span, h1, ...) ---- *)
|
|
let setup_html_tags env =
|
|
List.iter (fun tag ->
|
|
ignore (env_bind env tag
|
|
(NativeFn ("html:" ^ tag, fun args -> List (Symbol tag :: args))))
|
|
) Sx_render.html_tags
|
|
|
|
|
|
(* ====================================================================== *)
|
|
(* Compose environment *)
|
|
(* ====================================================================== *)
|
|
|
|
(** Convert int-keyed env.bindings to string-keyed Hashtbl for VM globals *)
|
|
(* Shared VM globals table — one live table, all JIT closures share
|
|
the same reference. Kept in sync via env_bind hook so late-bound
|
|
values (shell statics, page functions, defines) are always visible. *)
|
|
let _shared_vm_globals : (string, Sx_types.value) Hashtbl.t = Hashtbl.create 2048
|
|
|
|
let env_to_vm_globals _env = _shared_vm_globals
|
|
|
|
let () =
|
|
(* Hook env_bind so top-level bindings (defines, component defs, shell statics)
|
|
are mirrored to vm globals. Only sync when binding in a root env (no parent)
|
|
to avoid polluting globals with lambda parameter bindings, which would break
|
|
closure isolation for factory functions like make-page-fn. *)
|
|
Sx_types._env_bind_hook := Some (fun env name v ->
|
|
if env.parent = None then
|
|
(* Don't let SX definitions (from loaded .sx files) overwrite native
|
|
primitives in vm_globals — the native versions are authoritative. *)
|
|
if not (Sx_primitives.is_primitive name) then
|
|
Hashtbl.replace _shared_vm_globals name v)
|
|
|
|
(* Import hook — resolves (import ...) suspensions inside eval_expr/cek_run.
|
|
Loads the .sx file for the library, registers it, and returns true.
|
|
Re-entry guard prevents infinite loops from circular or failing imports. *)
|
|
let _loading_libs : (string, bool) Hashtbl.t = Hashtbl.create 8
|
|
let () =
|
|
Sx_types._import_hook := Some (fun lib_spec ->
|
|
if Sx_types.sx_truthy (Sx_ref.library_loaded_p lib_spec) then true
|
|
else
|
|
let key = Sx_types.inspect lib_spec in
|
|
if Hashtbl.mem _loading_libs key then false (* already loading — break cycle *)
|
|
else begin
|
|
Hashtbl.replace _loading_libs key true;
|
|
let result = match resolve_library_path lib_spec with
|
|
| Some path ->
|
|
(try load_library_file path;
|
|
(* Verify the library actually registered *)
|
|
Sx_types.sx_truthy (Sx_ref.library_loaded_p lib_spec)
|
|
with e ->
|
|
Printf.eprintf "[import-hook] FAIL %s from %s: %s\n%!"
|
|
key path (Printexc.to_string e);
|
|
false)
|
|
| None -> false in
|
|
(* Don't remove — keep as "attempted" guard to prevent retries *)
|
|
result
|
|
end)
|
|
|
|
let make_server_env () =
|
|
let env = make_env () in
|
|
Sx_render.setup_render_env env;
|
|
setup_browser_stubs env;
|
|
setup_scope_env env;
|
|
setup_evaluator_bridge env;
|
|
setup_introspection env;
|
|
setup_core_operations env;
|
|
setup_type_constructors env;
|
|
setup_character_classification env;
|
|
setup_env_operations env;
|
|
setup_strict_mode env;
|
|
setup_io_bridges env;
|
|
setup_html_tags env;
|
|
setup_io_env env;
|
|
(* defhandler — native special form. Called by CEK as (handler [raw-args; Env eval-env]).
|
|
Registers handler as handler:name in the eval env. *)
|
|
ignore (Sx_ref.register_special_form (String "defhandler") (NativeFn ("defhandler", fun sf_args ->
|
|
(* Custom special forms receive [List args; Env eval_env] *)
|
|
let raw_args, eval_env = match sf_args with
|
|
| [List a; Env e] | [ListRef { contents = a }; Env e] -> (a, e)
|
|
| _ -> ([], env) in
|
|
match raw_args with
|
|
| name_sym :: rest ->
|
|
let name = match name_sym with Symbol s -> s | String s -> s | _ -> Sx_types.inspect name_sym in
|
|
let rec parse_opts acc = function
|
|
| Keyword k :: v :: rest -> Hashtbl.replace acc k v; parse_opts acc rest
|
|
| rest -> (acc, rest) in
|
|
let opts = Hashtbl.create 4 in
|
|
let (_, remaining) = parse_opts opts rest in
|
|
let params, body = match remaining with
|
|
| List p :: b :: _ -> (p, b) | List p :: [] -> (p, Nil) | _ -> ([], Nil) in
|
|
let hdef = Hashtbl.create 8 in
|
|
Hashtbl.replace hdef "__type" (String "handler");
|
|
Hashtbl.replace hdef "name" (String name);
|
|
Hashtbl.replace hdef "params" (List params);
|
|
Hashtbl.replace hdef "body" body;
|
|
Hashtbl.replace hdef "closure" (Env eval_env);
|
|
Hashtbl.replace hdef "method" (match Hashtbl.find_opt opts "method" with
|
|
| Some (Keyword m) -> String m | Some v -> v | None -> String "get");
|
|
Hashtbl.replace hdef "path" (match Hashtbl.find_opt opts "path" with Some v -> v | None -> Nil);
|
|
Hashtbl.replace hdef "csrf" (match Hashtbl.find_opt opts "csrf" with Some v -> v | None -> Bool true);
|
|
Hashtbl.replace hdef "returns" (match Hashtbl.find_opt opts "returns" with Some v -> v | None -> String "element");
|
|
ignore (env_bind eval_env ("handler:" ^ name) (Dict hdef));
|
|
Dict hdef
|
|
| _ -> Nil)));
|
|
(* Initialize trampoline ref so HO primitives (map, filter, etc.)
|
|
can call SX lambdas. Must be done here because Sx_ref is only
|
|
available at the binary level, not in the library. *)
|
|
Sx_primitives._sx_trampoline_fn := (fun v ->
|
|
match v with
|
|
| Thunk (body, closure_env) -> Sx_ref.eval_expr body (Env closure_env)
|
|
| other -> other);
|
|
(* client? returns false on server — overridden in browser via K.eval *)
|
|
ignore (env_bind env "client?" (NativeFn ("client?", fun _ -> Bool false)));
|
|
(* Seed vm_globals with ALL primitives as NativeFn values.
|
|
Native primitives override SX definitions (e.g. has-key? from stdlib.sx)
|
|
because the native versions are correct and fast. HO forms (map, filter, etc.)
|
|
keep their ho_via_cek wrappers since those are set up after this seeding
|
|
via the env_bind_hook when SX files are loaded. *)
|
|
Hashtbl.iter (fun name fn ->
|
|
Hashtbl.replace _shared_vm_globals name (NativeFn (name, fn))
|
|
) Sx_primitives.primitives;
|
|
env
|
|
|
|
|
|
(* ====================================================================== *)
|
|
(* SX render-to-html — calls adapter-html.sx via CEK *)
|
|
(* ====================================================================== *)
|
|
|
|
(** Render an SX expression to HTML using the SX adapter (adapter-html.sx).
|
|
Falls back to Sx_render.sx_render_to_html if the SX adapter isn't loaded. *)
|
|
let sx_render_to_html expr env =
|
|
if env_has env "render-to-html" then
|
|
let fn = env_get env "render-to-html" in
|
|
let result = Sx_ref.cek_call fn (List [expr; Env env]) in
|
|
match result with String s -> s | _ -> Sx_runtime.value_to_str result
|
|
else
|
|
Sx_render.sx_render_to_html env expr env
|
|
|
|
|
|
(* ====================================================================== *)
|
|
(* JIT hook registration *)
|
|
(* ====================================================================== *)
|
|
|
|
(** Register the JIT call hook. Called once after the compiler is loaded
|
|
into the kernel env. The hook handles both cached execution (bytecode
|
|
already compiled) and first-call compilation (invoke compiler.sx via
|
|
CEK, cache result). cek_call checks this before CEK dispatch. *)
|
|
(* Re-entrancy guard lives in Sx_vm._jit_compiling (shared with vm_call path) *)
|
|
|
|
(* JIT compilation is lazy-only: every named lambda gets one compile
|
|
attempt on first call. Failures are sentineled (never retried). *)
|
|
|
|
let _jit_warned : (string, bool) Hashtbl.t = Hashtbl.create 16
|
|
|
|
let rec make_vm_suspend_marker request saved_vm =
|
|
let d = Hashtbl.create 3 in
|
|
Hashtbl.replace d "__vm_suspended" (Bool true);
|
|
Hashtbl.replace d "request" request;
|
|
(* Create a resume function that continues this specific VM.
|
|
May raise VmSuspended again — caller must handle. *)
|
|
Hashtbl.replace d "resume" (NativeFn ("vm-resume", fun args ->
|
|
match args with
|
|
| [result] ->
|
|
(try Sx_vm.resume_vm saved_vm result
|
|
with Sx_vm.VmSuspended (req2, vm2) ->
|
|
make_vm_suspend_marker req2 vm2)
|
|
| _ -> raise (Eval_error "vm-resume: expected 1 arg")));
|
|
Dict d
|
|
|
|
let register_jit_hook env =
|
|
Sx_runtime._jit_try_call_fn := Some (fun f args ->
|
|
match f with
|
|
| Lambda l ->
|
|
(match l.l_compiled with
|
|
| Some cl when not (Sx_vm.is_jit_failed cl) ->
|
|
(* Skip during CEK-based compilation — helpers are called inside
|
|
the VM when compile has bytecode, no need for the hook. *)
|
|
if !(Sx_vm._jit_compiling) then None
|
|
else
|
|
(try Some (Sx_vm.call_closure cl args cl.vm_env_ref)
|
|
with
|
|
| Sx_vm.VmSuspended (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
|
|
Hashtbl.replace _jit_warned fn_name true;
|
|
Printf.eprintf "[jit] %s runtime fallback to CEK: %s\n%!" fn_name (Printexc.to_string e)
|
|
end;
|
|
l.l_compiled <- Some Sx_vm.jit_failed_sentinel;
|
|
None)
|
|
| Some _ -> None
|
|
| None ->
|
|
let fn_name = match l.l_name with Some n -> n | None -> "?" in
|
|
if !(Sx_vm._jit_compiling) then None
|
|
else if Hashtbl.mem _jit_warned fn_name then None
|
|
else begin
|
|
let t0 = Unix.gettimeofday () in
|
|
let compiled = Sx_vm.jit_compile_lambda l (env_to_vm_globals env) in
|
|
let dt = Unix.gettimeofday () -. t0 in
|
|
Printf.eprintf "[jit] %s compile in %.3fs\n%!" fn_name dt;
|
|
match compiled with
|
|
| Some cl ->
|
|
l.l_compiled <- Some cl;
|
|
(try Some (Sx_vm.call_closure cl args cl.vm_env_ref)
|
|
with
|
|
| Sx_vm.VmSuspended (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;
|
|
l.l_compiled <- Some Sx_vm.jit_failed_sentinel;
|
|
None)
|
|
| None ->
|
|
l.l_compiled <- Some Sx_vm.jit_failed_sentinel;
|
|
None
|
|
end)
|
|
| _ -> None)
|
|
|
|
|
|
(* ====================================================================== *)
|
|
(* Re-assert host-provided extension points after loading .sx files.
|
|
evaluator.sx defines *custom-special-forms* and register-special-form!
|
|
which shadow the native bindings from setup_evaluator_bridge. *)
|
|
let rebind_host_extensions env =
|
|
Hashtbl.replace env.bindings (Sx_types.intern "register-special-form!")
|
|
(NativeFn ("register-special-form!", fun args ->
|
|
match args with
|
|
| [String name; handler] ->
|
|
ignore (Sx_ref.register_special_form (String name) handler); Nil
|
|
| _ -> 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
|
|
(* Strip _islands/ convention directories from the path *)
|
|
let stem = let parts = String.split_on_char '/' stem in
|
|
String.concat "/" (List.filter (fun p -> p <> "_islands") parts) 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 *)
|
|
(* ====================================================================== *)
|
|
|
|
let rec dispatch env cmd =
|
|
match cmd with
|
|
| List [Symbol "ping"] ->
|
|
send_ok_string "ocaml-cek"
|
|
|
|
| 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 ->
|
|
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
|
|
defines *custom-special-forms* which shadows the native dict *)
|
|
rebind_host_extensions env;
|
|
(match prev_file with
|
|
| Some v -> ignore (Sx_types.env_bind env "*current-file*" v)
|
|
| None -> ());
|
|
send_ok_value (Number (float_of_int !count))
|
|
with
|
|
| Eval_error msg -> send_error msg
|
|
| Sys_error msg -> send_error ("File error: " ^ msg)
|
|
| exn -> send_error (Printexc.to_string exn))
|
|
|
|
| List [Symbol "load-source"; String src] ->
|
|
(try
|
|
let exprs = Sx_parser.parse_all src in
|
|
let count = ref 0 in
|
|
List.iter (fun expr ->
|
|
ignore (Sx_ref.eval_expr expr (Env env));
|
|
incr count
|
|
) exprs;
|
|
send_ok_value (Number (float_of_int !count))
|
|
with
|
|
| Eval_error msg -> send_error msg
|
|
| exn -> send_error (Printexc.to_string exn))
|
|
|
|
| List [Symbol "eval-blob"] ->
|
|
let src = read_blob () in
|
|
dispatch env (List [Symbol "eval"; String src])
|
|
|
|
| List [Symbol "compile-blob"] ->
|
|
(* Read source as blob, parse natively in OCaml, compile via SX compile-module.
|
|
Returns the bytecode dict as SX text. Much faster than JS kernel. *)
|
|
let src = read_blob () in
|
|
(try
|
|
let exprs = Sx_parser.parse_all src in
|
|
let compile_module = env_get env "compile-module" in
|
|
let result = Sx_ref.cek_call compile_module (List [List exprs]) in
|
|
let rec raw_serialize = 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 -> s | Keyword k -> ":" ^ k
|
|
| List items | ListRef { contents = items } -> "(" ^ String.concat " " (List.map raw_serialize items) ^ ")"
|
|
| Dict d -> let pairs = Hashtbl.fold (fun k v acc -> (Printf.sprintf ":%s %s" k (raw_serialize v)) :: acc) d [] in "{" ^ String.concat " " pairs ^ "}"
|
|
| SxExpr s -> s | _ -> "nil"
|
|
in
|
|
send_ok_raw (raw_serialize result)
|
|
with
|
|
| Eval_error msg -> send_error msg
|
|
| exn -> send_error (Printexc.to_string exn))
|
|
|
|
| List [Symbol "eval"; String src] ->
|
|
(try
|
|
let exprs = Sx_parser.parse_all src in
|
|
let result = List.fold_left (fun _acc expr ->
|
|
(* Use import-aware eval — handles define-library/import locally
|
|
but does NOT send other IO to the Python bridge (would deadlock
|
|
on stdin which carries batch commands). *)
|
|
let state = Sx_ref.make_cek_state expr (Env env) (List []) in
|
|
let s = ref (Sx_ref.cek_step_loop state) in
|
|
while Sx_types.sx_truthy (Sx_ref.cek_suspended_p !s) do
|
|
let request = Sx_ref.cek_io_request !s in
|
|
let op = match request with
|
|
| Dict d -> (match Hashtbl.find_opt d "op" with Some (String o) -> o | _ -> "")
|
|
| _ -> "" 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
|
|
else begin
|
|
(match resolve_library_path lib_spec with
|
|
| Some path -> load_library_file path | None -> ());
|
|
Nil
|
|
end
|
|
end else Nil (* non-import IO: resume with nil *) in
|
|
s := Sx_ref.cek_resume !s response
|
|
done;
|
|
Sx_ref.cek_value !s
|
|
) Nil exprs in
|
|
(* Use ok-raw with natural list serialization — no (list ...) wrapping.
|
|
This preserves the SX structure for Python to parse back. *)
|
|
let rec raw_serialize = 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 -> s
|
|
| Keyword k -> ":" ^ k
|
|
| List items | ListRef { contents = items } ->
|
|
"(" ^ String.concat " " (List.map raw_serialize items) ^ ")"
|
|
| Dict d ->
|
|
let pairs = Hashtbl.fold (fun k v acc ->
|
|
(Printf.sprintf ":%s %s" k (raw_serialize v)) :: acc) d [] in
|
|
"{" ^ String.concat " " pairs ^ "}"
|
|
| Component c -> "~" ^ c.c_name
|
|
| Island i -> "~" ^ i.i_name
|
|
| SxExpr s -> s
|
|
| RawHTML s -> "\"" ^ escape_sx_string s ^ "\""
|
|
| _ -> "nil"
|
|
in
|
|
send_ok_raw (raw_serialize result)
|
|
with
|
|
| Eval_error msg -> send_error (Sx_ref.enhance_error_with_trace msg)
|
|
| exn -> send_error (Printexc.to_string exn))
|
|
|
|
| List [Symbol "vm-reset-fn"; String name] ->
|
|
(* Reset a function's JIT-compiled bytecode, forcing CEK interpretation.
|
|
Used to work around JIT compilation bugs in specific functions. *)
|
|
(match Hashtbl.find_opt env.bindings (Sx_types.intern name) with
|
|
| Some (Lambda l) ->
|
|
l.l_compiled <- Some Sx_vm.jit_failed_sentinel;
|
|
Printf.eprintf "[jit] reset %s (forced CEK)\n%!" name;
|
|
send_ok ()
|
|
| _ ->
|
|
Printf.eprintf "[jit] reset %s: not found or not lambda\n%!" name;
|
|
send_ok ())
|
|
|
|
| List [Symbol "aser-blob"] ->
|
|
(* Like aser but reads source as a binary blob. *)
|
|
let src = read_blob () in
|
|
dispatch env (List [Symbol "aser"; String src])
|
|
|
|
| List [Symbol "aser-slot-blob"] ->
|
|
(* Like aser-slot but reads source as a binary blob. *)
|
|
let src = read_blob () in
|
|
dispatch env (List [Symbol "aser-slot"; String src])
|
|
|
|
| List [Symbol "aser"; String src] ->
|
|
(* Evaluate and serialize as SX wire format.
|
|
Calls the SX-defined aser function from adapter-sx.sx.
|
|
aser is loaded into the kernel env via _ensure_components. *)
|
|
(try
|
|
let exprs = Sx_parser.parse_all src in
|
|
let expr = match exprs with
|
|
| [e] -> e
|
|
| [] -> Nil
|
|
| _ -> List (Symbol "<>" :: exprs)
|
|
in
|
|
(* Call (aser <quoted-expr> <env>) *)
|
|
let call = List [Symbol "aser";
|
|
List [Symbol "quote"; expr];
|
|
Env env] in
|
|
let result = Sx_ref.eval_expr call (Env env) in
|
|
(* Send raw SX wire format without re-escaping.
|
|
Use (ok-raw ...) so Python knows not to unescape. *)
|
|
(match result with
|
|
| String s | SxExpr s -> send_ok_raw s
|
|
| List items | ListRef { contents = items } ->
|
|
(* List of SxExprs from map/filter — join them as a fragment *)
|
|
let parts = List.filter_map (fun v -> match v with
|
|
| SxExpr s -> Some s
|
|
| String s -> Some ("\"" ^ escape_sx_string s ^ "\"")
|
|
| Nil -> None
|
|
| v -> Some (serialize_value v)) items in
|
|
if parts = [] then send_ok_raw ""
|
|
else send_ok_raw (String.concat " " parts)
|
|
| _ -> send_ok_value result)
|
|
with
|
|
| Eval_error msg -> send_error msg
|
|
| exn -> send_error (Printexc.to_string exn))
|
|
|
|
| List [Symbol "vm-compile-adapter"] ->
|
|
(* Register lazy JIT hook — all named lambdas compile on first call.
|
|
Pre-compile compiler internals so subsequent JIT compilations
|
|
run at VM speed, not CEK speed. *)
|
|
register_jit_hook env;
|
|
let t0 = Unix.gettimeofday () in
|
|
let count = ref 0 in
|
|
(* Pre-compile compiler helpers AND compile itself.
|
|
When compile has bytecode, jit_compile_lambda calls it directly via
|
|
the VM — all helper calls happen inside the same VM execution with
|
|
no per-call overhead. This is 10-100x faster than CEK dispatch. *)
|
|
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";
|
|
"compile-letrec"; "compile-lambda"; "compile-define"; "compile-set";
|
|
"compile-quote"; "compile-cond"; "compile-case"; "compile-case-clauses";
|
|
"compile-thread"; "compile-thread-step"; "compile-defcomp";
|
|
"compile-defmacro"; "compile-quasiquote"; "compile-qq-expr";
|
|
"compile-qq-list"; "compile-call";
|
|
"make-emitter"; "make-pool"; "make-scope"; "pool-add";
|
|
"scope-define-local"; "scope-resolve";
|
|
"emit-byte"; "emit-u16"; "emit-i16"; "emit-op"; "emit-const";
|
|
"current-offset"; "patch-i16";
|
|
] in
|
|
List.iter (fun name ->
|
|
match Hashtbl.find_opt env.bindings (Sx_types.intern name) with
|
|
| Some (Lambda l) when l.l_compiled = None ->
|
|
l.l_compiled <- Some Sx_vm.jit_failed_sentinel;
|
|
(match Sx_vm.jit_compile_lambda l (env_to_vm_globals env) with
|
|
| Some cl -> l.l_compiled <- Some cl; incr count
|
|
| None -> ())
|
|
| _ -> ()
|
|
) compiler_names;
|
|
let dt = Unix.gettimeofday () -. t0 in
|
|
Printf.eprintf "[jit] Pre-compiled %d compiler functions in %.3fs (lazy JIT active for all)\n%!" !count dt;
|
|
send_ok ()
|
|
|
|
| List [Symbol "jit-reset-name"; String name] ->
|
|
(* Reset a function's JIT state back to uncompiled *)
|
|
(match Hashtbl.find_opt env.bindings (Sx_types.intern name) with
|
|
| Some (Lambda l) -> l.l_compiled <- None; send_ok_raw (Printf.sprintf "reset %s" name)
|
|
| _ -> send_ok_raw (Printf.sprintf "not-found %s" name))
|
|
|
|
| List [Symbol "set-request-cookies"; Dict cookies] ->
|
|
(* Set request cookies for get-cookie primitive.
|
|
Called by Python bridge before each page render. *)
|
|
Hashtbl.clear _request_cookies;
|
|
Hashtbl.iter (fun k v ->
|
|
match v with String s -> Hashtbl.replace _request_cookies k s | _ -> ()
|
|
) cookies;
|
|
send_ok ()
|
|
|
|
| List [Symbol "aser-slot"; String src] ->
|
|
(* Expand ALL components server-side. Uses batch IO mode.
|
|
Calls aser via CEK — the JIT hook compiles it on first call. *)
|
|
(try
|
|
let exprs = Sx_parser.parse_all src in
|
|
let expr = match exprs with
|
|
| [e] -> e
|
|
| [] -> Nil
|
|
| _ -> List (Symbol "<>" :: exprs)
|
|
in
|
|
io_batch_mode := true;
|
|
io_queue := [];
|
|
io_counter := 0;
|
|
let t0 = Unix.gettimeofday () in
|
|
let expand_fn = NativeFn ("expand-components?", fun _args -> Bool true) in
|
|
ignore (env_bind env "expand-components?" expand_fn);
|
|
Printf.eprintf "[aser-slot] starting aser eval...\n%!";
|
|
let result =
|
|
let call = List [Symbol "aser";
|
|
List [Symbol "quote"; expr];
|
|
Env env] in
|
|
let r = Sx_ref.eval_expr call (Env env) in
|
|
Printf.eprintf "[aser-slot] aser eval returned\n%!";
|
|
r
|
|
in
|
|
let t1 = Unix.gettimeofday () in
|
|
io_batch_mode := false;
|
|
Hashtbl.remove env.bindings (Sx_types.intern "expand-components?");
|
|
let result_str = match result with
|
|
| String s | SxExpr s -> s
|
|
| _ -> serialize_value result
|
|
in
|
|
let n_batched = List.length !io_queue in
|
|
(* Flush batched IO: send requests, receive responses, replace placeholders *)
|
|
let final = flush_batched_io result_str in
|
|
let t2 = Unix.gettimeofday () in
|
|
Printf.eprintf "[aser-slot] eval=%.1fs io_flush=%.1fs batched=%d result=%d chars\n%!"
|
|
(t1 -. t0) (t2 -. t1) n_batched (String.length final);
|
|
send_ok_raw final
|
|
with
|
|
| Eval_error msg ->
|
|
io_batch_mode := false;
|
|
io_queue := [];
|
|
Hashtbl.remove env.bindings (Sx_types.intern "expand-components?");
|
|
send_error msg
|
|
| exn ->
|
|
io_batch_mode := false;
|
|
io_queue := [];
|
|
Hashtbl.remove env.bindings (Sx_types.intern "expand-components?");
|
|
send_error (Printexc.to_string exn))
|
|
|
|
| List (Symbol "sx-page-full-blob" :: shell_kwargs) ->
|
|
(* Like sx-page-full but reads page source as a length-prefixed blob
|
|
from the next line(s), avoiding string-escape round-trip issues. *)
|
|
let page_src = read_blob () in
|
|
dispatch env (List (Symbol "sx-page-full" :: String page_src :: shell_kwargs))
|
|
|
|
| List (Symbol "sx-page-full" :: String page_src :: shell_kwargs) ->
|
|
(* Full page render: aser-slot body + render-to-html shell in ONE call.
|
|
shell_kwargs are keyword pairs: :title "..." :csrf "..." etc.
|
|
These are passed directly to ~shared:shell/sx-page-shell. *)
|
|
(try
|
|
(* Phase 1: aser-slot the page body *)
|
|
let exprs = Sx_parser.parse_all page_src in
|
|
let expr = match exprs with
|
|
| [e] -> e | [] -> Nil | _ -> List (Symbol "<>" :: exprs)
|
|
in
|
|
io_batch_mode := true;
|
|
io_queue := [];
|
|
io_counter := 0;
|
|
let t0 = Unix.gettimeofday () in
|
|
let expand_fn = NativeFn ("expand-components?", fun _args -> Bool true) in
|
|
ignore (env_bind env "expand-components?" expand_fn);
|
|
let body_result =
|
|
let call = List [Symbol "aser";
|
|
List [Symbol "quote"; expr];
|
|
Env env] in
|
|
Sx_ref.eval_expr call (Env env)
|
|
in
|
|
let t1 = Unix.gettimeofday () in
|
|
io_batch_mode := false;
|
|
Hashtbl.remove env.bindings (Sx_types.intern "expand-components?");
|
|
let body_str = match body_result with
|
|
| String s | SxExpr s -> s
|
|
| _ -> serialize_value body_result
|
|
in
|
|
let body_final = flush_batched_io body_str in
|
|
let t2 = Unix.gettimeofday () in
|
|
(* Phase 1b: render the aser'd SX to HTML for isomorphic SSR.
|
|
The aser output is flat (all components expanded, just HTML tags),
|
|
so render-to-html is cheap — no component lookups needed. *)
|
|
let body_html =
|
|
try
|
|
let body_exprs = Sx_parser.parse_all body_final in
|
|
let body_expr = match body_exprs with
|
|
| [e] -> e | [] -> Nil | _ -> List (Symbol "<>" :: body_exprs)
|
|
in
|
|
sx_render_to_html body_expr env
|
|
with e ->
|
|
Printf.eprintf "[ssr] render-to-html failed: %s\n%!" (Printexc.to_string e);
|
|
"" (* fallback: client renders from SX source. Islands with
|
|
reactive state may fail SSR — client hydrates them. *)
|
|
in
|
|
let t2b = Unix.gettimeofday () in
|
|
(* Phase 2: render shell with body + all kwargs.
|
|
Resolve symbol references (e.g. __shell-component-defs) to their
|
|
values from the env — these were pre-injected by the bridge. *)
|
|
let resolved_kwargs = List.map (fun v ->
|
|
match v with
|
|
| Symbol s ->
|
|
(try env_get env s
|
|
with _ -> try Sx_primitives.get_primitive s with _ -> v)
|
|
| _ -> v
|
|
) shell_kwargs in
|
|
let shell_args = Keyword "page-sx" :: String body_final
|
|
:: Keyword "body-html" :: String body_html
|
|
:: resolved_kwargs in
|
|
let shell_call = List (Symbol "~shared:shell/sx-page-shell" :: shell_args) in
|
|
let html = sx_render_to_html shell_call env in
|
|
let t3 = Unix.gettimeofday () in
|
|
Printf.eprintf "[sx-page-full] aser=%.3fs io=%.3fs ssr=%.3fs shell=%.3fs total=%.3fs body=%d ssr=%d html=%d\n%!"
|
|
(t1 -. t0) (t2 -. t1) (t2b -. t2) (t3 -. t2b) (t3 -. t0)
|
|
(String.length body_final) (String.length body_html) (String.length html);
|
|
send_ok_string html
|
|
with
|
|
| Eval_error msg ->
|
|
io_batch_mode := false;
|
|
io_queue := [];
|
|
Hashtbl.remove env.bindings (Sx_types.intern "expand-components?");
|
|
send_error msg
|
|
| exn ->
|
|
io_batch_mode := false;
|
|
io_queue := [];
|
|
Hashtbl.remove env.bindings (Sx_types.intern "expand-components?");
|
|
send_error (Printexc.to_string exn))
|
|
|
|
| List [Symbol "render"; String src] ->
|
|
(try
|
|
let exprs = Sx_parser.parse_all src in
|
|
let expr = match exprs with
|
|
| [e] -> e
|
|
| [] -> Nil
|
|
| _ -> List (Symbol "do" :: exprs)
|
|
in
|
|
let html = sx_render_to_html expr env in
|
|
send_ok_string html
|
|
with
|
|
| Eval_error msg -> send_error msg
|
|
| exn -> send_error (Printexc.to_string exn))
|
|
|
|
| List [Symbol "vm-exec"; code_val] ->
|
|
(* Execute a bytecode module on the VM.
|
|
code_val is a dict with {bytecode, pool} from compiler.sx *)
|
|
(try
|
|
let code = Sx_vm.code_from_value code_val in
|
|
let globals = env_to_vm_globals env in
|
|
let result = Sx_vm_ref.execute_module code globals in
|
|
send_ok_value result
|
|
with
|
|
| Eval_error msg -> send_error msg
|
|
| exn -> send_error (Printexc.to_string exn))
|
|
|
|
| List [Symbol "vm-load-module"; code_val] ->
|
|
(* Execute a compiled module on the VM. The module's defines
|
|
are stored in the kernel env, replacing Lambda values with
|
|
NativeFn VM closures. This is how compiled code gets wired
|
|
into the CEK dispatch — the CEK calls NativeFn directly. *)
|
|
(try
|
|
let code = Sx_vm.code_from_value code_val in
|
|
(* VM uses the LIVE kernel env — defines go directly into it *)
|
|
let globals = env_to_vm_globals env in
|
|
let _result = Sx_vm_ref.execute_module code globals in
|
|
(* Copy defines back into env *)
|
|
Hashtbl.iter (fun k v -> Hashtbl.replace env.bindings (Sx_types.intern k) v) globals;
|
|
send_ok ()
|
|
with
|
|
| Eval_error msg -> send_error msg
|
|
| exn -> send_error (Printexc.to_string exn))
|
|
|
|
(* ---- Debugging / introspection commands ---- *)
|
|
|
|
| List [Symbol "jit-enable"] ->
|
|
register_jit_hook env;
|
|
send_ok_value (String "jit enabled")
|
|
|
|
| List [Symbol "vm-counters"] ->
|
|
let d = Hashtbl.create 8 in
|
|
Hashtbl.replace d "vm_insns" (Number (float_of_int !(Sx_vm._vm_insn_count)));
|
|
Hashtbl.replace d "vm_calls" (Number (float_of_int !(Sx_vm._vm_call_count)));
|
|
Hashtbl.replace d "vm_cek_fallbacks" (Number (float_of_int !(Sx_vm._vm_cek_count)));
|
|
Hashtbl.replace d "comp_jit" (Number (float_of_int !(Sx_vm._vm_comp_jit_count)));
|
|
Hashtbl.replace d "comp_cek" (Number (float_of_int !(Sx_vm._vm_comp_cek_count)));
|
|
Hashtbl.replace d "jit_hit" (Number (float_of_int !(Sx_runtime._jit_hit)));
|
|
Hashtbl.replace d "jit_miss" (Number (float_of_int !(Sx_runtime._jit_miss)));
|
|
Hashtbl.replace d "jit_skip" (Number (float_of_int !(Sx_runtime._jit_skip)));
|
|
send_ok_value (Dict d)
|
|
|
|
| List [Symbol "vm-counters-reset"] ->
|
|
Sx_vm.vm_reset_counters ();
|
|
Sx_runtime.jit_reset_counters ();
|
|
send_ok_value (String "reset")
|
|
|
|
| List [Symbol "vm-trace"; String src] ->
|
|
(* Compile and trace-execute an SX expression, returning step-by-step
|
|
trace entries with opcode names, stack snapshots, and frame depth. *)
|
|
(try
|
|
let result = Sx_vm.trace_run src (env_to_vm_globals env) in
|
|
send_ok_value result
|
|
with
|
|
| Eval_error msg -> send_error msg
|
|
| exn -> send_error (Printexc.to_string exn))
|
|
|
|
| List [Symbol "bytecode-inspect"; String name] ->
|
|
(* Disassemble a named function's compiled bytecode.
|
|
Returns a dict with arity, num_locals, constants, bytecode instructions. *)
|
|
(try
|
|
let v = try Sx_types.env_get env name
|
|
with Not_found -> raise (Eval_error ("bytecode-inspect: not found: " ^ name)) in
|
|
let code = match v with
|
|
| Lambda l ->
|
|
(match l.l_compiled with
|
|
| Some cl when not (Sx_vm.is_jit_failed cl) -> cl.vm_code
|
|
| _ -> raise (Eval_error ("bytecode-inspect: " ^ name ^ " has no compiled bytecode")))
|
|
| VmClosure cl -> cl.vm_code
|
|
| NativeFn _ -> raise (Eval_error ("bytecode-inspect: " ^ name ^ " is a native function"))
|
|
| _ -> raise (Eval_error ("bytecode-inspect: " ^ name ^ " is not a function"))
|
|
in
|
|
send_ok_value (Sx_vm.disassemble code)
|
|
with
|
|
| Eval_error msg -> send_error msg
|
|
| exn -> send_error (Printexc.to_string exn))
|
|
|
|
| List [Symbol "deps-check"; String src] ->
|
|
(* Walk parsed AST to find all symbol references and check resolution. *)
|
|
(try
|
|
let exprs = Sx_parser.parse_all src in
|
|
let special_forms = [
|
|
"if"; "when"; "cond"; "case"; "let"; "let*"; "lambda"; "fn";
|
|
"define"; "defcomp"; "defisland"; "defmacro";
|
|
"quote"; "quasiquote"; "begin"; "do"; "set!"; "->"; "and"; "or"
|
|
] in
|
|
let seen = Hashtbl.create 64 in
|
|
let rec walk = function
|
|
| Symbol s ->
|
|
if not (Hashtbl.mem seen s) then Hashtbl.replace seen s true
|
|
| List items | ListRef { contents = items } ->
|
|
List.iter walk items
|
|
| Dict d -> Hashtbl.iter (fun _ v -> walk v) d
|
|
| _ -> ()
|
|
in
|
|
List.iter walk exprs;
|
|
let resolved = ref [] in
|
|
let unresolved = ref [] in
|
|
Hashtbl.iter (fun name _ ->
|
|
if List.mem name special_forms
|
|
|| Sx_types.env_has env name
|
|
|| Hashtbl.mem Sx_primitives.primitives name
|
|
|| name = "true" || name = "false" || name = "nil"
|
|
then resolved := String name :: !resolved
|
|
else unresolved := String name :: !unresolved
|
|
) seen;
|
|
let result = Hashtbl.create 2 in
|
|
Hashtbl.replace result "resolved" (List !resolved);
|
|
Hashtbl.replace result "unresolved" (List !unresolved);
|
|
send_ok_value (Dict result)
|
|
with
|
|
| Eval_error msg -> send_error msg
|
|
| exn -> send_error (Printexc.to_string exn))
|
|
|
|
| List [Symbol "prim-check"; String name] ->
|
|
(* Scan a compiled function's bytecode for CALL_PRIM opcodes
|
|
and verify each referenced primitive exists. *)
|
|
(try
|
|
let v = try Sx_types.env_get env name
|
|
with Not_found -> raise (Eval_error ("prim-check: not found: " ^ name)) in
|
|
let code = match v with
|
|
| Lambda l ->
|
|
(match l.l_compiled with
|
|
| Some cl when not (Sx_vm.is_jit_failed cl) -> cl.vm_code
|
|
| _ -> raise (Eval_error ("prim-check: " ^ name ^ " has no compiled bytecode")))
|
|
| VmClosure cl -> cl.vm_code
|
|
| _ -> raise (Eval_error ("prim-check: " ^ name ^ " is not a compiled function"))
|
|
in
|
|
let bc = code.vc_bytecode in
|
|
let consts = code.vc_constants in
|
|
let len = Array.length bc in
|
|
let valid = ref [] in
|
|
let invalid = ref [] in
|
|
let ip = ref 0 in
|
|
while !ip < len do
|
|
let op = bc.(!ip) in
|
|
ip := !ip + 1;
|
|
if op = 52 (* OP_CALL_PRIM *) && !ip + 2 < len then begin
|
|
let lo = bc.(!ip) in let hi = bc.(!ip + 1) in
|
|
let idx = lo lor (hi lsl 8) in
|
|
let _argc = bc.(!ip + 2) in
|
|
ip := !ip + 3;
|
|
let prim_name = if idx < Array.length consts
|
|
then (match consts.(idx) with String s -> s | _ -> "?") else "?" in
|
|
if Hashtbl.mem Sx_primitives.primitives prim_name
|
|
then valid := String prim_name :: !valid
|
|
else invalid := String prim_name :: !invalid
|
|
end else begin
|
|
(* Skip operand bytes for other opcodes *)
|
|
let skip = Sx_vm.opcode_operand_size op in
|
|
ip := !ip + skip
|
|
end
|
|
done;
|
|
let result = Hashtbl.create 2 in
|
|
Hashtbl.replace result "valid" (List !valid);
|
|
Hashtbl.replace result "invalid" (List !invalid);
|
|
send_ok_value (Dict result)
|
|
with
|
|
| Eval_error msg -> send_error msg
|
|
| exn -> send_error (Printexc.to_string exn))
|
|
|
|
| List [Symbol "reset"] ->
|
|
(* Clear all bindings and rebuild env.
|
|
We can't reassign env, so clear and re-populate. *)
|
|
Hashtbl.clear env.bindings;
|
|
let fresh = make_server_env () in
|
|
Hashtbl.iter (fun k v -> Hashtbl.replace env.bindings k v) fresh.bindings;
|
|
send_ok ()
|
|
|
|
| _ ->
|
|
send_error ("Unknown command: " ^ inspect cmd)
|
|
|
|
|
|
(* ====================================================================== *)
|
|
(* Main loop *)
|
|
(* ====================================================================== *)
|
|
|
|
(* ====================================================================== *)
|
|
(* CLI mode — one-shot render/aser from stdin *)
|
|
(* ====================================================================== *)
|
|
|
|
let cli_load_files env files =
|
|
List.iter (fun path ->
|
|
if Sys.file_exists path then begin
|
|
let exprs = Sx_parser.parse_file path in
|
|
List.iter (fun expr ->
|
|
ignore (Sx_ref.eval_expr expr (Env env))
|
|
) exprs
|
|
end
|
|
) files;
|
|
(* Rebind after load in case .sx files shadowed host extension points *)
|
|
rebind_host_extensions env
|
|
|
|
let cli_mode mode =
|
|
let env = make_server_env () in
|
|
(* Load spec + adapter files for aser modes *)
|
|
let spec_base = try Sys.getenv "SX_SPEC_DIR" with Not_found -> "spec" in
|
|
let lib_base = try Sys.getenv "SX_LIB_DIR" with Not_found -> "lib" in
|
|
let web_base = try Sys.getenv "SX_WEB_DIR" with Not_found -> "web" in
|
|
let render_files = [
|
|
Filename.concat spec_base "parser.sx";
|
|
Filename.concat spec_base "render.sx";
|
|
Filename.concat web_base "adapter-html.sx";
|
|
Filename.concat web_base "adapter-sx.sx";
|
|
Filename.concat web_base "web-forms.sx";
|
|
] in
|
|
(* Load spec + adapter files for rendering CLI modes *)
|
|
(if mode = "aser" || mode = "aser-slot" || mode = "render" then
|
|
cli_load_files env render_files);
|
|
ignore lib_base; (* available for --load paths *)
|
|
(* Load any files passed via --load *)
|
|
let load_files = ref [] in
|
|
let args = Array.to_list Sys.argv in
|
|
let rec scan = function
|
|
| "--load" :: path :: rest -> load_files := path :: !load_files; scan rest
|
|
| _ :: rest -> scan rest
|
|
| [] -> ()
|
|
in scan args;
|
|
cli_load_files env (List.rev !load_files);
|
|
(* Read SX from stdin *)
|
|
let buf = Buffer.create 4096 in
|
|
(try while true do
|
|
let line = input_line stdin in
|
|
Buffer.add_string buf line;
|
|
Buffer.add_char buf '\n'
|
|
done with End_of_file -> ());
|
|
let src = String.trim (Buffer.contents buf) in
|
|
if src = "" then exit 0;
|
|
(try
|
|
match mode with
|
|
| "render" ->
|
|
let exprs = Sx_parser.parse_all src in
|
|
let expr = match exprs with
|
|
| [e] -> e | [] -> Nil | _ -> List (Symbol "do" :: exprs) in
|
|
let html = sx_render_to_html expr env in
|
|
print_string html; flush stdout
|
|
| "aser" ->
|
|
let exprs = Sx_parser.parse_all src in
|
|
let expr = match exprs with
|
|
| [e] -> e | [] -> Nil | _ -> List (Symbol "<>" :: exprs) in
|
|
let call = List [Symbol "aser";
|
|
List [Symbol "quote"; expr];
|
|
Env env] in
|
|
let result = Sx_ref.eval_expr call (Env env) in
|
|
(match result with
|
|
| String s | SxExpr s -> print_string s
|
|
| Dict d when Hashtbl.mem d "__aser_sx" ->
|
|
(match Hashtbl.find d "__aser_sx" with
|
|
| String s | SxExpr s -> print_string s
|
|
| v -> print_string (serialize_value v))
|
|
| _ -> print_string (serialize_value result));
|
|
flush stdout
|
|
| "aser-slot" ->
|
|
ignore (env_bind env "expand-components?" (NativeFn ("expand-components?", fun _args -> Bool true)));
|
|
let exprs = Sx_parser.parse_all src in
|
|
let expr = match exprs with
|
|
| [e] -> e | [] -> Nil | _ -> List (Symbol "<>" :: exprs) in
|
|
let call = List [Symbol "aser";
|
|
List [Symbol "quote"; expr];
|
|
Env env] in
|
|
let result = Sx_ref.eval_expr call (Env env) in
|
|
(match result with
|
|
| String s | SxExpr s -> print_string s
|
|
| Dict d when Hashtbl.mem d "__aser_sx" ->
|
|
(match Hashtbl.find d "__aser_sx" with
|
|
| String s | SxExpr s -> print_string s
|
|
| v -> print_string (serialize_value v))
|
|
| _ -> print_string (serialize_value result));
|
|
flush stdout
|
|
| _ ->
|
|
Printf.eprintf "Unknown CLI mode: %s\n" mode; exit 1
|
|
with
|
|
| Eval_error msg ->
|
|
Printf.eprintf "Error: %s\n" msg; exit 1
|
|
| exn ->
|
|
Printf.eprintf "Error: %s\n" (Printexc.to_string exn); exit 1)
|
|
|
|
|
|
let test_mode () =
|
|
let env = make_server_env () in
|
|
(* Load spec + lib + adapter stack *)
|
|
let spec_base = try Sys.getenv "SX_SPEC_DIR" with Not_found -> "spec" in
|
|
let lib_base = try Sys.getenv "SX_LIB_DIR" with Not_found -> "lib" in
|
|
let web_base = try Sys.getenv "SX_WEB_DIR" with Not_found -> "web" in
|
|
let files = [
|
|
Filename.concat spec_base "parser.sx";
|
|
Filename.concat spec_base "render.sx";
|
|
Filename.concat lib_base "compiler.sx";
|
|
Filename.concat spec_base "signals.sx";
|
|
Filename.concat web_base "signals.sx";
|
|
Filename.concat web_base "adapter-html.sx";
|
|
Filename.concat web_base "adapter-sx.sx";
|
|
Filename.concat web_base "web-forms.sx";
|
|
] in
|
|
cli_load_files env files;
|
|
(* Register JIT *)
|
|
register_jit_hook env;
|
|
(* Load any --load files *)
|
|
let load_files = ref [] in
|
|
let eval_exprs = ref [] in
|
|
let args = Array.to_list Sys.argv in
|
|
let rec scan = function
|
|
| "--load" :: path :: rest -> load_files := path :: !load_files; scan rest
|
|
| "--eval" :: expr :: rest -> eval_exprs := expr :: !eval_exprs; scan rest
|
|
| _ :: rest -> scan rest
|
|
| [] -> ()
|
|
in scan args;
|
|
cli_load_files env (List.rev !load_files);
|
|
if !eval_exprs <> [] then
|
|
List.iter (fun src ->
|
|
try
|
|
let exprs = Sx_parser.parse_all src in
|
|
let result = List.fold_left (fun _ e ->
|
|
Sx_ref.eval_expr e (Env env)) Nil exprs in
|
|
Printf.printf "%s\n%!" (serialize_value result)
|
|
with
|
|
| Eval_error msg -> Printf.eprintf "Error: %s\n%!" msg; exit 1
|
|
| exn -> Printf.eprintf "Error: %s\n%!" (Printexc.to_string exn); exit 1
|
|
) (List.rev !eval_exprs)
|
|
else begin
|
|
(* Read from stdin *)
|
|
let buf = Buffer.create 4096 in
|
|
(try while true do
|
|
let line = input_line stdin in
|
|
Buffer.add_string buf line; Buffer.add_char buf '\n'
|
|
done with End_of_file -> ());
|
|
let src = String.trim (Buffer.contents buf) in
|
|
if src <> "" then begin
|
|
try
|
|
let exprs = Sx_parser.parse_all src in
|
|
let result = List.fold_left (fun _ e ->
|
|
Sx_ref.eval_expr e (Env env)) Nil exprs in
|
|
Printf.printf "%s\n%!" (serialize_value result)
|
|
with
|
|
| Eval_error msg -> Printf.eprintf "Error: %s\n%!" msg; exit 1
|
|
| exn -> Printf.eprintf "Error: %s\n%!" (Printexc.to_string exn); exit 1
|
|
end
|
|
end
|
|
|
|
(* ====================================================================== *)
|
|
(* HTTP server mode (--http PORT) *)
|
|
(* ====================================================================== *)
|
|
|
|
let http_response ?(status=200) ?(content_type="text/html; charset=utf-8") body =
|
|
let status_text = match status with
|
|
| 200 -> "OK" | 301 -> "Moved Permanently" | 304 -> "Not Modified"
|
|
| 404 -> "Not Found" | 405 -> "Method Not Allowed"
|
|
| 500 -> "Internal Server Error" | _ -> "Unknown"
|
|
in
|
|
Printf.sprintf "HTTP/1.1 %d %s\r\nContent-Type: %s\r\nContent-Length: %d\r\nConnection: keep-alive\r\n\r\n%s"
|
|
status status_text content_type (String.length body) 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
|
|
| None -> None
|
|
| Some i -> let line = String.sub data 0 i in
|
|
(match String.split_on_char ' ' line with
|
|
| m :: p :: _ -> Some (m, p) | _ -> None))
|
|
| Some i -> let line = String.sub data 0 i in
|
|
(match String.split_on_char ' ' line with
|
|
| m :: p :: _ -> Some (m, p) | _ -> None)
|
|
|
|
let url_decode s =
|
|
let buf = Buffer.create (String.length s) in
|
|
let i = ref 0 in
|
|
while !i < String.length s do
|
|
if s.[!i] = '%' && !i + 2 < String.length s then begin
|
|
(try
|
|
let hex = String.sub s (!i + 1) 2 in
|
|
Buffer.add_char buf (Char.chr (int_of_string ("0x" ^ hex)))
|
|
with _ -> Buffer.add_char buf s.[!i]);
|
|
i := !i + 3
|
|
end else if s.[!i] = '+' then begin
|
|
Buffer.add_char buf ' ';
|
|
i := !i + 1
|
|
end else begin
|
|
Buffer.add_char buf s.[!i];
|
|
i := !i + 1
|
|
end
|
|
done;
|
|
Buffer.contents buf
|
|
|
|
let parse_http_headers data =
|
|
let lines = String.split_on_char '\n' data in
|
|
let headers = ref [] in
|
|
List.iter (fun line ->
|
|
let line = if String.length line > 0 && line.[String.length line - 1] = '\r'
|
|
then String.sub line 0 (String.length line - 1) else line in
|
|
match String.index_opt line ':' with
|
|
| Some i when i > 0 ->
|
|
let key = String.trim (String.sub line 0 i) in
|
|
let value = String.trim (String.sub line (i + 1) (String.length line - i - 1)) in
|
|
headers := (key, value) :: !headers
|
|
| _ -> ()
|
|
) (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 =
|
|
let t0 = Unix.gettimeofday () in
|
|
(* Phase 0: Route via SX handler — returns {:is-ajax :nav-path :page-ast} *)
|
|
let handler = try env_get env "sx-handle-request" with _ -> Nil in
|
|
if handler = Nil then (Printf.eprintf "[http] sx-handle-request not found\n%!"; None)
|
|
else
|
|
let headers_dict = Hashtbl.create 8 in
|
|
List.iter (fun (k, v) ->
|
|
Hashtbl.replace headers_dict (String.lowercase_ascii k) (String v)
|
|
) headers;
|
|
let route_result =
|
|
try Sx_ref.cek_call handler
|
|
(List [String path; Dict headers_dict; Env env; Nil])
|
|
with e ->
|
|
Printf.eprintf "[http] route error for %s: %s\n%!" path (Printexc.to_string e);
|
|
Nil
|
|
in
|
|
(* Build an error page AST that keeps the layout intact *)
|
|
let error_page_ast msg =
|
|
List [Symbol "div"; Keyword "class"; String "p-8 max-w-2xl mx-auto";
|
|
List [Symbol "h2"; Keyword "class"; String "text-xl font-semibold text-rose-600 mb-4";
|
|
String "Page Error"];
|
|
List [Symbol "p"; Keyword "class"; String "text-stone-600 mb-2"; String path];
|
|
List [Symbol "pre"; Keyword "class"; String "text-sm bg-stone-100 p-4 rounded overflow-x-auto text-stone-700";
|
|
String msg]]
|
|
in
|
|
(* Normalize route result — Nil and non-Dict become error pages *)
|
|
let is_ajax_req = List.exists (fun (k,_) -> String.lowercase_ascii k = "sx-request") headers in
|
|
let route_dict = match route_result with
|
|
| Dict d -> d
|
|
| _ ->
|
|
let d = Hashtbl.create 4 in
|
|
Hashtbl.replace d "is-ajax" (Bool is_ajax_req);
|
|
Hashtbl.replace d "nav-path" (String path);
|
|
Hashtbl.replace d "page-ast" (error_page_ast "Page not found");
|
|
d
|
|
in
|
|
let d = route_dict in
|
|
let is_ajax = match Hashtbl.find_opt d "is-ajax" with Some (Bool true) -> true | _ -> false in
|
|
let nav_path = match Hashtbl.find_opt d "nav-path" with Some (String s) -> s | _ -> path in
|
|
let page_ast = match Hashtbl.find_opt d "page-ast" with Some v -> v | _ -> Nil in
|
|
let page_ast = if page_ast = Nil then error_page_ast "Page returned empty content" else page_ast in
|
|
begin
|
|
let inner_layout = get_app_str "inner-layout" "~layouts/doc" in
|
|
let wrapped = List [Symbol inner_layout; Keyword "path"; String nav_path; page_ast] in
|
|
if is_ajax then begin
|
|
(* AJAX: return SX wire format (aser output) with text/sx content type.
|
|
Expand server-side components so the browser doesn't need their definitions.
|
|
Islands stay as (~ ...) calls — the browser hydrates those. *)
|
|
ignore (env_bind env "expand-components?" (NativeFn ("expand-components?", fun _args -> Bool true)));
|
|
let body_result =
|
|
let call = List [Symbol "aser"; List [Symbol "quote"; wrapped]; Env env] in
|
|
eval_with_io_render call env in
|
|
Hashtbl.remove env.bindings (Sx_types.intern "expand-components?");
|
|
let body_str = match body_result with
|
|
| String s | SxExpr s -> s | _ -> serialize_value body_result in
|
|
let t1 = Unix.gettimeofday () in
|
|
Printf.eprintf "[sx-http] %s (SX) aser=%.3fs body=%d\n%!" path (t1 -. t0) (String.length body_str);
|
|
Some body_str
|
|
end else begin
|
|
(* Full page: aser → SSR → shell *)
|
|
let outer_layout = get_app_str "outer-layout" "~shared:layout/app-body" in
|
|
let full_ast = List [Symbol outer_layout; Keyword "content"; wrapped] in
|
|
let page_source = serialize_value full_ast in
|
|
let t1 = Unix.gettimeofday () in
|
|
let body_result =
|
|
let call = List [Symbol "aser"; List [Symbol "quote"; full_ast]; 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
|
|
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 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
|
|
let t3 = Unix.gettimeofday () in
|
|
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 "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
|
|
let html =
|
|
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 in
|
|
let t4 = Unix.gettimeofday () in
|
|
Printf.eprintf "[sx-http] %s route=%.3fs aser=%.3fs ssr=%.3fs shell=%.3fs total=%.3fs html=%d\n%!"
|
|
path (t1 -. t0) (t2 -. t1) (t3 -. t2) (t4 -. t3) (t4 -. t0) (String.length html);
|
|
Some html
|
|
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 =
|
|
"<script>window.__sxPending=[];window.__sxResolve=function(i,s){\
|
|
if(window.Sx&&Sx.resolveSuspense){Sx.resolveSuspense(i,s)}\
|
|
else{window.__sxPending.push({id:i,sx:s})}}</script>"
|
|
|
|
(* Build a resolve script tag. Must match _SX_STREAMING_RESOLVE in helpers.py *)
|
|
let sx_streaming_resolve_script id sx_source =
|
|
Printf.sprintf "<script>window.__sxResolve&&window.__sxResolve(%s,%s)</script>"
|
|
(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 "<h1>Streaming page def not found</h1>" 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);
|
|
"<html><body><h1>Streaming shell render failed</h1></body></html>"
|
|
in
|
|
let t1 = Unix.gettimeofday () in
|
|
|
|
(* Phase 2: Send chunked header + shell HTML.
|
|
Strip closing </body></html> from shell — resolve scripts must go INSIDE
|
|
the body, otherwise the browser's HTML parser ignores them. *)
|
|
let shell_body, shell_tail =
|
|
(* Find last </body> and split there *)
|
|
let s = shell_html in
|
|
let body_close = "</body>" 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 *)
|
|
(* ====================================================================== *)
|
|
|
|
let mime_type_of path =
|
|
if Filename.check_suffix path ".css" then "text/css; charset=utf-8"
|
|
else if Filename.check_suffix path ".js" then "application/javascript; charset=utf-8"
|
|
else if Filename.check_suffix path ".wasm" then "application/wasm"
|
|
else if Filename.check_suffix path ".json" then "application/json"
|
|
else if Filename.check_suffix path ".svg" then "image/svg+xml"
|
|
else if Filename.check_suffix path ".png" then "image/png"
|
|
else if Filename.check_suffix path ".jpg" || Filename.check_suffix path ".jpeg" then "image/jpeg"
|
|
else if Filename.check_suffix path ".ico" then "image/x-icon"
|
|
else if Filename.check_suffix path ".map" then "application/json"
|
|
else if Filename.check_suffix path ".woff2" then "font/woff2"
|
|
else if Filename.check_suffix path ".woff" then "font/woff"
|
|
else if Filename.check_suffix path ".sx" then "text/sx; charset=utf-8"
|
|
else if Filename.check_suffix path ".sxbc" then "text/sx; charset=utf-8"
|
|
else "application/octet-stream"
|
|
|
|
let static_cache : (string, string) Hashtbl.t = Hashtbl.create 256
|
|
|
|
let serve_static_file static_dir url_path =
|
|
match Hashtbl.find_opt static_cache url_path with
|
|
| Some cached -> cached
|
|
| None ->
|
|
let rel = String.sub url_path 8 (String.length url_path - 8) in
|
|
let rel = match String.index_opt rel '?' with
|
|
| Some i -> String.sub rel 0 i | None -> rel in
|
|
let has_substring s sub =
|
|
let slen = String.length s and sublen = String.length sub in
|
|
if sublen > slen then false
|
|
else let rec check i = if i > slen - sublen then false
|
|
else if String.sub s i sublen = sub then true else check (i + 1)
|
|
in check 0
|
|
in
|
|
if String.contains rel '\x00' || (String.length rel > 1 && String.sub rel 0 2 = "..")
|
|
(* Block source maps but allow .wasm files from assets *)
|
|
|| Filename.check_suffix rel ".map"
|
|
|| (has_substring rel ".assets/" && not (Filename.check_suffix rel ".wasm")) then
|
|
http_response ~status:403 "Forbidden"
|
|
else
|
|
let file_path = static_dir ^ "/" ^ rel in
|
|
if Sys.file_exists file_path && not (Sys.is_directory file_path) then begin
|
|
let content_type = mime_type_of file_path in
|
|
let body = In_channel.with_open_bin file_path In_channel.input_all in
|
|
let resp = Printf.sprintf
|
|
"HTTP/1.1 200 OK\r\nContent-Type: %s\r\nContent-Length: %d\r\nCache-Control: public, max-age=31536000, immutable\r\nConnection: keep-alive\r\n\r\n%s"
|
|
content_type (String.length body) body in
|
|
Hashtbl.replace static_cache url_path resp;
|
|
resp
|
|
end else
|
|
http_response ~status:404 "Not Found"
|
|
|
|
let file_hash path =
|
|
if Sys.file_exists path then
|
|
String.sub (Digest.string (In_channel.with_open_bin path In_channel.input_all) |> Digest.to_hex) 0 12
|
|
else ""
|
|
|
|
let sxbc_combined_hash dir =
|
|
let sxbc_dir = dir ^ "/sx" in
|
|
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
|
|
let sorted = List.sort String.compare sxbc_files in
|
|
let buf = Buffer.create 65536 in
|
|
List.iter (fun f ->
|
|
let path = sxbc_dir ^ "/" ^ f in
|
|
Buffer.add_string buf (In_channel.with_open_bin path In_channel.input_all)
|
|
) sorted;
|
|
String.sub (Digest.string (Buffer.contents buf) |> Digest.to_hex) 0 12
|
|
end else ""
|
|
|
|
let read_css_file path =
|
|
if Sys.file_exists path then
|
|
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 =
|
|
(* Component definitions for client.
|
|
Client library sources FIRST (CSSX etc.) so defines are available
|
|
before defcomp/defisland bodies that reference them. *)
|
|
let buf = Buffer.create 65536 in
|
|
let project_dir = try Sys.getenv "SX_PROJECT_DIR" with Not_found ->
|
|
Filename.dirname (Filename.dirname static_dir) 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
|
|
let client_libs = List.map (fun name -> templates_dir ^ "/" ^ name) client_lib_names in
|
|
List.iter (fun path ->
|
|
if Sys.file_exists path then begin
|
|
let src = In_channel.with_open_text path In_channel.input_all in
|
|
Buffer.add_string buf src;
|
|
Buffer.add_char buf '\n'
|
|
end
|
|
) client_libs;
|
|
(* Then component/island definitions *)
|
|
Hashtbl.iter (fun _sym v ->
|
|
match v with
|
|
| Component c ->
|
|
let ps = String.concat " " (
|
|
"&key" :: c.c_params @
|
|
(if c.c_has_children then ["&rest"; "children"] else [])) in
|
|
Buffer.add_string buf (Printf.sprintf "(defcomp ~%s (%s) %s)\n"
|
|
c.c_name ps (serialize_value c.c_body))
|
|
| Island i ->
|
|
let ps = String.concat " " (
|
|
"&key" :: i.i_params @
|
|
(if i.i_has_children then ["&rest"; "children"] else [])) in
|
|
Buffer.add_string buf (Printf.sprintf "(defisland ~%s (%s) %s)\n"
|
|
i.i_name ps (serialize_value i.i_body))
|
|
| _ -> ()
|
|
) env.bindings;
|
|
let raw_defs = Buffer.contents buf in
|
|
(* Component-defs are inlined in <script type="text/sx">.
|
|
Escape </ → <\/ to prevent HTML parser from matching </script>. *)
|
|
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
|
|
let platform_hash = file_hash (static_dir ^ "/wasm/sx-platform.js") in
|
|
let sxbc_hash = sxbc_combined_hash (static_dir ^ "/wasm") in
|
|
(* Read CSS for inline injection *)
|
|
let css_file_names = get_app_list "css-files" ["basics.css"; "tw.css"] in
|
|
let sx_css = String.concat "\n" (List.map (fun name ->
|
|
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
|
|
let scan_defpages dir =
|
|
let rec scan d =
|
|
if Sys.file_exists d && Sys.is_directory d then
|
|
Array.iter (fun f ->
|
|
let path = d ^ "/" ^ f in
|
|
if Sys.is_directory path then scan path
|
|
else if Filename.check_suffix f ".sx" then
|
|
try
|
|
let src = In_channel.with_open_text path In_channel.input_all in
|
|
let exprs = Sx_parser.parse_all src in
|
|
List.iter (function
|
|
| List (Symbol "defpage" :: Symbol name :: rest) ->
|
|
let rec extract_kw key = function
|
|
| [] -> None
|
|
| Keyword k :: v :: _ when k = key -> Some v
|
|
| _ :: rest -> extract_kw key rest
|
|
in
|
|
let path_val = match extract_kw "path" rest with
|
|
| Some (String s) -> s | _ -> "" in
|
|
let content_val = match extract_kw "content" rest with
|
|
| 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")
|
|
(escape_sx_string content_val))
|
|
end
|
|
| _ -> ()
|
|
) exprs
|
|
with _ -> ()
|
|
) (Sys.readdir d)
|
|
in scan dir
|
|
in
|
|
scan_defpages sx_sxc;
|
|
let pages_sx = Buffer.contents pages_buf in
|
|
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"));
|
|
ignore (env_bind env "__shell-wasm-hash" (String wasm_hash));
|
|
ignore (env_bind env "__shell-platform-hash" (String platform_hash));
|
|
ignore (env_bind env "__shell-sxbc-hash" (String sxbc_hash));
|
|
ignore (env_bind env "__shell-inline-css" Nil);
|
|
ignore (env_bind env "__shell-inline-head-js" Nil);
|
|
(* init-sx: trigger client-side render when sx-root is empty (SSR failed). *)
|
|
let default_init_sx =
|
|
"document.addEventListener('sx:boot-done', function() { \
|
|
var root = document.getElementById('sx-root'); \
|
|
if (root && !root.innerHTML.trim() && typeof SX !== 'undefined' && SX.renderPage) { \
|
|
SX.renderPage(); \
|
|
} \
|
|
});" in
|
|
let init_sx = match get_app_config "init-script" (Keyword "default") with
|
|
| String s -> s | _ -> default_init_sx in
|
|
ignore (env_bind env "__shell-init-sx" (String init_sx));
|
|
Printf.eprintf "[sx-http] Shell statics: defs=%d hash=%s css=%d wasm=%s platform=%s sxbc=%s\n%!"
|
|
(String.length component_defs) component_hash (String.length sx_css) wasm_hash platform_hash sxbc_hash
|
|
|
|
let http_setup_declarative_stubs env =
|
|
(* Stub declarative forms that are metadata-only — no-ops at render time. *)
|
|
let noop name =
|
|
ignore (env_bind env name (NativeFn (name, fun _args -> Nil))) in
|
|
noop "define-module";
|
|
noop "define-primitive";
|
|
noop "deftype";
|
|
noop "defeffect";
|
|
noop "define-page-helper";
|
|
(* defhandler — register as native special form so it works without web-forms.sx.
|
|
Parses the handler args and stores as handler:name in the env. *)
|
|
ignore (Sx_ref.register_special_form (String "defhandler") (NativeFn ("defhandler", fun args ->
|
|
match args with
|
|
| name_sym :: rest ->
|
|
let name = match name_sym with Symbol s -> s | String s -> s | _ -> Sx_types.inspect name_sym in
|
|
(* Parse keyword opts and find params/body *)
|
|
let rec parse_opts acc = function
|
|
| Keyword k :: v :: rest -> Hashtbl.replace acc k v; parse_opts acc rest
|
|
| rest -> (acc, rest)
|
|
in
|
|
let opts = Hashtbl.create 4 in
|
|
let (_, remaining) = parse_opts opts rest in
|
|
let params, body = match remaining with
|
|
| List p :: b :: _ -> (p, b)
|
|
| List p :: [] -> (p, Nil)
|
|
| _ -> ([], Nil)
|
|
in
|
|
let hdef = Hashtbl.create 8 in
|
|
Hashtbl.replace hdef "__type" (String "handler");
|
|
Hashtbl.replace hdef "name" (String name);
|
|
Hashtbl.replace hdef "params" (List params);
|
|
Hashtbl.replace hdef "body" body;
|
|
Hashtbl.replace hdef "closure" (Env env);
|
|
Hashtbl.replace hdef "method" (match Hashtbl.find_opt opts "method" with
|
|
| Some (Keyword m) -> String m | Some v -> v | None -> String "get");
|
|
Hashtbl.replace hdef "path" (match Hashtbl.find_opt opts "path" with
|
|
| Some v -> v | None -> Nil);
|
|
Hashtbl.replace hdef "csrf" (match Hashtbl.find_opt opts "csrf" with
|
|
| Some v -> v | None -> Bool true);
|
|
Hashtbl.replace hdef "returns" (match Hashtbl.find_opt opts "returns" with
|
|
| Some v -> v | None -> String "element");
|
|
let handler_key = "handler:" ^ name in
|
|
ignore (env_bind env handler_key (Dict hdef));
|
|
Dict hdef
|
|
| _ -> Nil)));
|
|
(* Also stub defquery/defaction/defrelation/defstyle as no-ops *)
|
|
noop "defquery";
|
|
noop "defaction";
|
|
noop "defrelation";
|
|
noop "defstyle";
|
|
(* IO registry — spec-level defio populates *io-registry* in evaluator.
|
|
Alias as __io-registry for backward compat. *)
|
|
ignore (env_bind env "__io-registry" Sx_ref._io_registry_)
|
|
|
|
let http_setup_platform_constructors env =
|
|
(* Platform constructor functions expected by evaluator.sx.
|
|
The OCaml CEK evaluator handles lambda/component/etc as special forms
|
|
natively, but when evaluator.sx's SX-level code processes these forms
|
|
it calls make-lambda etc. by name. Bind them to the OCaml constructors. *)
|
|
let bind name fn = ignore (env_bind env name (NativeFn (name, fn))) in
|
|
bind "make-lambda" (fun args ->
|
|
match args with
|
|
| [params; body; env_val] -> Sx_types.make_lambda params body env_val
|
|
| _ -> raise (Eval_error "make-lambda: expected (params body env)"));
|
|
bind "make-component" (fun args ->
|
|
match args with
|
|
| [name; params; has_children; body; env_val; affinity] ->
|
|
Sx_types.make_component name params has_children body env_val affinity
|
|
| [name; params; has_children; body; env_val] ->
|
|
Sx_types.make_component name params has_children body env_val (String "auto")
|
|
| _ -> raise (Eval_error "make-component: expected (name params has-children body env [affinity])"));
|
|
bind "make-island" (fun args ->
|
|
match args with
|
|
| [name; params; has_children; body; env_val] ->
|
|
Sx_types.make_island name params has_children body env_val
|
|
| _ -> raise (Eval_error "make-island: expected (name params has-children body env)"));
|
|
bind "make-macro" (fun args ->
|
|
match args with
|
|
| [params; rest_param; body; closure; name] ->
|
|
Sx_types.make_macro params rest_param body closure name
|
|
| [params; body; Env _e] ->
|
|
(* Simplified: no rest_param, no closure needed *)
|
|
Sx_types.make_macro params Nil body Nil (String "anonymous")
|
|
| _ -> raise (Eval_error "make-macro: expected (params rest-param body closure name)"));
|
|
bind "make-thunk" (fun args ->
|
|
match args with
|
|
| [body; Env e] -> Thunk (body, e)
|
|
| _ -> raise (Eval_error "make-thunk: expected (body env)"));
|
|
bind "make-env" (fun args ->
|
|
match args with
|
|
| [] -> Env (make_env ())
|
|
| [Env parent] -> Env { bindings = Hashtbl.create 8; parent = Some parent }
|
|
| _ -> raise (Eval_error "make-env: expected () or (parent-env)"));
|
|
(* Platform accessor functions — evaluator.sx expects these *)
|
|
bind "lambda-name" (fun args -> match args with [v] -> Sx_types.lambda_name v | _ -> Nil);
|
|
bind "lambda-params" (fun args -> match args with [v] -> Sx_types.lambda_params v | _ -> Nil);
|
|
bind "lambda-body" (fun args -> match args with [v] -> Sx_types.lambda_body v | _ -> Nil);
|
|
bind "lambda-closure" (fun args -> match args with [v] -> Sx_types.lambda_closure v | _ -> Nil);
|
|
bind "set-lambda-name!" (fun args -> match args with [l; n] -> ignore (Sx_runtime.set_lambda_name l n); l | _ -> Nil);
|
|
bind "env-has?" (fun args ->
|
|
match args with [Env e; String k] | [Env e; Symbol k] -> Bool (env_has e k) | _ -> Bool false);
|
|
bind "env-get" (fun args ->
|
|
match args with [Env e; String k] | [Env e; Symbol k] -> (try env_get e k with _ -> Nil) | _ -> Nil);
|
|
bind "env-set!" (fun args ->
|
|
match args with
|
|
| [Env e; String k; v] | [Env e; Symbol k; v] -> ignore (env_bind e k v); Nil
|
|
| _ -> Nil);
|
|
bind "env-bind!" (fun args ->
|
|
match args with
|
|
| [Env e; String k; v] | [Env e; Symbol k; v] -> ignore (env_bind e k v); Nil
|
|
| _ -> Nil);
|
|
bind "env-extend" (fun args ->
|
|
match args with
|
|
| [Env parent] -> Env { bindings = Hashtbl.create 8; parent = Some parent }
|
|
| _ -> Env (make_env ()));
|
|
bind "env-keys" (fun args ->
|
|
match args with
|
|
| [Env e] -> List (Hashtbl.fold (fun k _v acc -> String (Sx_types.unintern k) :: acc) e.bindings [])
|
|
| _ -> List [])
|
|
|
|
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 ->
|
|
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;
|
|
(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;
|
|
rebind_host_extensions env
|
|
|
|
(* ====================================================================== *)
|
|
(* Request context — set per-request before rendering *)
|
|
(* ====================================================================== *)
|
|
|
|
let _req_method = ref "GET"
|
|
let _req_body = ref ""
|
|
let _req_query = ref ""
|
|
let _req_headers : (string * string) list ref = ref []
|
|
let _ephemeral_state : (string, value) Hashtbl.t = Hashtbl.create 64
|
|
|
|
let parse_urlencoded body =
|
|
if body = "" then []
|
|
else
|
|
let pairs = String.split_on_char '&' body in
|
|
List.filter_map (fun pair ->
|
|
match String.index_opt pair '=' with
|
|
| Some i ->
|
|
let k = url_decode (String.sub pair 0 i) in
|
|
let v = url_decode (String.sub pair (i + 1) (String.length pair - i - 1)) in
|
|
Some (k, v)
|
|
| None -> Some (url_decode pair, "")
|
|
) pairs
|
|
|
|
let parse_query_string path =
|
|
match String.index_opt path '?' with
|
|
| Some i -> String.sub path (i + 1) (String.length path - i - 1)
|
|
| None -> ""
|
|
|
|
let extract_body data =
|
|
(* Find double CRLF separating headers from body *)
|
|
let rec find_sep s pat pat_len i =
|
|
if i + pat_len > String.length s then -1
|
|
else if String.sub s i pat_len = pat then i
|
|
else find_sep s pat pat_len (i + 1) in
|
|
let n = find_sep data "\r\n\r\n" 4 0 in
|
|
if n >= 0 then String.sub data (n + 4) (String.length data - n - 4)
|
|
else
|
|
let n2 = find_sep data "\n\n" 2 0 in
|
|
if n2 >= 0 then String.sub data (n2 + 2) (String.length data - n2 - 2)
|
|
else ""
|
|
|
|
(* Pretty printer — AST value → formatted SX source string *)
|
|
let pp_atom = Sx_types.inspect
|
|
|
|
let rec est_width = function
|
|
| Nil -> 3 | Bool true -> 4 | Bool false -> 5
|
|
| Number n -> String.length (if Float.is_integer n then string_of_int (int_of_float n) else Printf.sprintf "%g" n)
|
|
| String s -> String.length s + 2
|
|
| Symbol s -> String.length s
|
|
| Keyword k -> String.length k + 1
|
|
| SxExpr s -> String.length s + 2
|
|
| List items | ListRef { contents = items } ->
|
|
2 + List.fold_left (fun acc x -> acc + est_width x + 1) 0 items
|
|
| _ -> 10
|
|
|
|
let pretty_print_value ?(max_width=80) v =
|
|
let buf = Buffer.create 4096 in
|
|
let rec pp indent v =
|
|
match v with
|
|
| List items | ListRef { contents = items } when items <> [] ->
|
|
if est_width v <= max_width - indent then
|
|
Buffer.add_string buf (pp_atom v)
|
|
else begin
|
|
Buffer.add_char buf '(';
|
|
let head = List.hd items in
|
|
Buffer.add_string buf (pp_atom head);
|
|
let child_indent = indent + 2 in
|
|
let rest = List.tl items in
|
|
let rec emit = function
|
|
| [] -> ()
|
|
| Keyword k :: v :: rest ->
|
|
Buffer.add_char buf '\n';
|
|
Buffer.add_string buf (String.make child_indent ' ');
|
|
Buffer.add_char buf ':';
|
|
Buffer.add_string buf k;
|
|
Buffer.add_char buf ' ';
|
|
pp child_indent v;
|
|
emit rest
|
|
| item :: rest ->
|
|
Buffer.add_char buf '\n';
|
|
Buffer.add_string buf (String.make child_indent ' ');
|
|
pp child_indent item;
|
|
emit rest
|
|
in
|
|
emit rest;
|
|
Buffer.add_char buf ')'
|
|
end
|
|
| _ -> Buffer.add_string buf (pp_atom v)
|
|
in
|
|
pp 0 v;
|
|
Buffer.contents buf
|
|
|
|
let http_setup_page_helpers env =
|
|
let bind name fn = ignore (env_bind env name (NativeFn (name, fn))) in
|
|
|
|
(* Request primitives — use thread-local _req_* context *)
|
|
bind "now" (fun args ->
|
|
let open Unix in
|
|
let t = gettimeofday () in
|
|
let tm = localtime t in
|
|
let fmt = match args with String f :: _ -> f | _ -> "%Y-%m-%d %H:%M:%S" in
|
|
let result = Printf.sprintf "%04d-%02d-%02d %02d:%02d:%02d"
|
|
(tm.tm_year + 1900) (tm.tm_mon + 1) tm.tm_mday
|
|
tm.tm_hour tm.tm_min tm.tm_sec in
|
|
(* Basic format substitution *)
|
|
let r = if fmt = "%H:%M:%S" then
|
|
Printf.sprintf "%02d:%02d:%02d" tm.tm_hour tm.tm_min tm.tm_sec
|
|
else if fmt = "%Y-%m-%d" then
|
|
Printf.sprintf "%04d-%02d-%02d" (tm.tm_year + 1900) (tm.tm_mon + 1) tm.tm_mday
|
|
else if fmt = "%Y-%m-%d %H:%M:%S" then result
|
|
else result in
|
|
String r);
|
|
|
|
bind "state-get" (fun args ->
|
|
match args with
|
|
| String key :: rest ->
|
|
let default = match rest with v :: _ -> v | [] -> Nil in
|
|
(match Hashtbl.find_opt _ephemeral_state key with
|
|
| Some v -> v | None -> default)
|
|
| _ -> Nil);
|
|
|
|
bind "state-set!" (fun args ->
|
|
match args with
|
|
| String key :: value :: _ -> Hashtbl.replace _ephemeral_state key value; Nil
|
|
| _ -> Nil);
|
|
|
|
bind "state-clear!" (fun args ->
|
|
match args with
|
|
| [String key] -> Hashtbl.remove _ephemeral_state key; Nil
|
|
| _ -> Nil);
|
|
|
|
bind "request-method" (fun _args -> String !_req_method);
|
|
bind "request-body" (fun _args -> String !_req_body);
|
|
|
|
bind "request-form" (fun args ->
|
|
match args with
|
|
| String name :: rest ->
|
|
let default = match rest with v :: _ -> v | [] -> String "" in
|
|
let pairs = parse_urlencoded !_req_body in
|
|
(match List.assoc_opt name pairs with
|
|
| Some v -> String v | None -> default)
|
|
| _ -> String "");
|
|
|
|
bind "request-arg" (fun args ->
|
|
match args with
|
|
| String name :: rest ->
|
|
let default = match rest with v :: _ -> v | [] -> Nil in
|
|
let pairs = parse_urlencoded !_req_query in
|
|
(match List.assoc_opt name pairs with
|
|
| Some v -> String v | None -> default)
|
|
| _ -> Nil);
|
|
|
|
bind "request-form-all" (fun _args ->
|
|
let pairs = parse_urlencoded !_req_body in
|
|
let d = Hashtbl.create 8 in
|
|
List.iter (fun (k, v) -> Hashtbl.replace d k (String v)) pairs;
|
|
Dict d);
|
|
|
|
bind "request-args-all" (fun _args ->
|
|
let pairs = parse_urlencoded !_req_query in
|
|
let d = Hashtbl.create 8 in
|
|
List.iter (fun (k, v) -> Hashtbl.replace d k (String v)) pairs;
|
|
Dict d);
|
|
|
|
bind "request-form-list" (fun args ->
|
|
match args with
|
|
| [String name] ->
|
|
let pairs = parse_urlencoded !_req_body in
|
|
List (List.filter_map (fun (k, v) -> if k = name then Some (String v) else None) pairs)
|
|
| _ -> List []);
|
|
|
|
bind "request-json" (fun _args -> String !_req_body);
|
|
|
|
bind "request-header" (fun args ->
|
|
match args with
|
|
| String name :: rest ->
|
|
let default = match rest with v :: _ -> v | [] -> String "" in
|
|
let lname = String.lowercase_ascii name in
|
|
(match List.assoc_opt lname (List.map (fun (k,v) -> (String.lowercase_ascii k, v)) !_req_headers) with
|
|
| Some v -> String v | None -> default)
|
|
| _ -> String "");
|
|
|
|
bind "request-headers-all" (fun _args ->
|
|
let d = Hashtbl.create 8 in
|
|
List.iter (fun (k, v) -> Hashtbl.replace d (String.lowercase_ascii k) (String v)) !_req_headers;
|
|
Dict d);
|
|
|
|
bind "request-content-type" (fun _args ->
|
|
match List.assoc_opt "content-type" (List.map (fun (k,v) -> (String.lowercase_ascii k, v)) !_req_headers) with
|
|
| Some v -> String v | None -> String "");
|
|
|
|
bind "request-file-name" (fun _args -> String "");
|
|
|
|
bind "into" (fun args ->
|
|
match args with
|
|
| [String "list"; Dict d] ->
|
|
List (Hashtbl.fold (fun k v acc -> List [String k; v] :: acc) d [])
|
|
| [String "dict"; List pairs] ->
|
|
let d = Hashtbl.create 8 in
|
|
List.iter (fun pair -> match pair with
|
|
| List [String k; v] -> Hashtbl.replace d k v
|
|
| _ -> ()) pairs;
|
|
Dict d
|
|
| _ -> Nil);
|
|
|
|
(* Primitive 1: pretty-print — AST → formatted SX source *)
|
|
bind "pretty-print" (fun args ->
|
|
match args with
|
|
| [v] -> String (pretty_print_value v)
|
|
| _ -> raise (Eval_error "pretty-print: expected 1 argument"));
|
|
|
|
(* Primitive 2: read-file — path → string contents or nil *)
|
|
bind "read-file" (fun args ->
|
|
match args with
|
|
| [String path] ->
|
|
(try
|
|
let ic = open_in path in
|
|
let n = in_channel_length ic in
|
|
let s = Bytes.create n in
|
|
really_input ic s 0 n;
|
|
close_in ic;
|
|
String (Bytes.to_string s)
|
|
with _ -> Nil)
|
|
| _ -> raise (Eval_error "read-file: expected string path"));
|
|
|
|
(* Primitive 3: env-list-typed — list all bindings of a given type *)
|
|
bind "env-list-typed" (fun args ->
|
|
match args with
|
|
| [String type_name] ->
|
|
let matches = ref [] in
|
|
Hashtbl.iter (fun id v ->
|
|
let matches_type = match type_name, v with
|
|
| "component", Component _ -> true
|
|
| "island", Island _ -> true
|
|
| "lambda", Lambda _ -> true
|
|
| "macro", Macro _ -> true
|
|
| "native", NativeFn _ -> true
|
|
| _ -> false
|
|
in
|
|
if matches_type then
|
|
matches := String (Sx_types.unintern id) :: !matches
|
|
) env.bindings;
|
|
List (List.sort compare !matches)
|
|
| _ -> raise (Eval_error "env-list-typed: expected type name string"));
|
|
|
|
(* helper dispatcher — looks up named function in env, calls it directly.
|
|
In coroutine mode this goes through the Python IO bridge.
|
|
In HTTP mode we dispatch locally to functions defined by SX helpers. *)
|
|
bind "helper" (fun args ->
|
|
match args with
|
|
| String name :: rest ->
|
|
(try
|
|
let fn = env_get env name in
|
|
Sx_ref.cek_call fn (List rest)
|
|
with Eval_error _ ->
|
|
Printf.eprintf "[helper] not found: %s\n%!" name;
|
|
Nil)
|
|
| _ -> raise (Eval_error "helper: expected (helper \"name\" ...args)"));
|
|
|
|
(* component-source — look up component/island from env, pretty-print its definition *)
|
|
bind "component-source" (fun args ->
|
|
match args with
|
|
| [String name] ->
|
|
let lookup = if String.length name > 0 && name.[0] = '~'
|
|
then name
|
|
else "~" ^ name in
|
|
(try
|
|
let comp = env_get env lookup in
|
|
match comp with
|
|
| Component c ->
|
|
let params = List (List.map (fun s -> Symbol s) c.c_params) in
|
|
let form = List [Symbol "defcomp"; Symbol ("~" ^ c.c_name);
|
|
params; c.c_body] in
|
|
String (pretty_print_value form)
|
|
| Island c ->
|
|
let params = List (List.map (fun s -> Symbol s) c.i_params) in
|
|
let form = List [Symbol "defisland"; Symbol ("~" ^ c.i_name);
|
|
params; c.i_body] in
|
|
String (pretty_print_value form)
|
|
| _ -> String (";; " ^ name ^ ": not a component")
|
|
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 =
|
|
let env = make_server_env () in
|
|
(* Stub declarative metadata forms — no-ops at render time *)
|
|
http_setup_declarative_stubs env;
|
|
(* Platform constructors expected by evaluator.sx *)
|
|
http_setup_platform_constructors env;
|
|
(* Page helpers *)
|
|
http_setup_page_helpers env;
|
|
(* Load all .sx files *)
|
|
let project_dir = try Sys.getenv "SX_PROJECT_DIR" with Not_found ->
|
|
try Sys.getenv "SX_ROOT" with Not_found ->
|
|
if Sys.file_exists "/app/spec" then "/app" else Sys.getcwd () in
|
|
let spec_base = try Sys.getenv "SX_SPEC_DIR" with Not_found ->
|
|
project_dir ^ "/spec" in
|
|
let lib_base = try Sys.getenv "SX_LIB_DIR" with Not_found ->
|
|
project_dir ^ "/lib" in
|
|
let web_base = try Sys.getenv "SX_WEB_DIR" with Not_found ->
|
|
project_dir ^ "/web" in
|
|
let shared_sx = try Sys.getenv "SX_SHARED_DIR" with Not_found ->
|
|
project_dir ^ "/shared/sx/templates" in
|
|
let sx_sx = try Sys.getenv "SX_COMPONENTS_DIR" with Not_found ->
|
|
let docker_path = project_dir ^ "/sx" in
|
|
let dev_path = project_dir ^ "/sx/sx" in
|
|
if Sys.file_exists docker_path && Sys.is_directory docker_path
|
|
&& not (Sys.file_exists (docker_path ^ "/sx")) (* avoid matching parent of sx/sx *)
|
|
then docker_path
|
|
else if Sys.file_exists dev_path && Sys.is_directory dev_path then dev_path
|
|
else begin
|
|
Printf.eprintf "[sx-http] WARNING: no components dir at %s or %s\n%!" docker_path dev_path;
|
|
docker_path
|
|
end in
|
|
(* Expose project paths to SX helpers *)
|
|
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));
|
|
(* Set import env so load_library_file (called by _import_hook) uses the main env *)
|
|
_import_env := Some env;
|
|
let t0 = Unix.gettimeofday () in
|
|
(* Core spec + adapters.
|
|
Skip: primitives.sx (declarative metadata — all prims native in OCaml),
|
|
types.sx (gradual types — not needed for rendering),
|
|
evaluator.sx (SX-level CEK — native evaluator already compiled in).
|
|
The native CEK evaluator is faster — evaluator.sx adds a second SX-level
|
|
stepper that's 100x slower. *)
|
|
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;
|
|
(* Libraries *)
|
|
(* 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"; "_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;
|
|
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;
|
|
(* sxc/ has core layout components like ~docs/page *)
|
|
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;
|
|
let t1 = Unix.gettimeofday () in
|
|
Printf.eprintf "[sx-http] All files loaded in %.3fs\n%!" (t1 -. t0);
|
|
(* Derive batchable_helpers from __io-registry *)
|
|
(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;
|
|
Printf.eprintf "[sx-http] IO registry: %d ops, %d batchable\n%!"
|
|
(Hashtbl.length registry) (List.length batchable);
|
|
(* Validate: warn if bound IO ops are not declared *)
|
|
let expected = ["query"; "action"; "request-arg"; "request-method";
|
|
"ctx"; "helper"; "json-encode"; "into"; "sleep";
|
|
"set-response-status"; "set-response-header"] in
|
|
List.iter (fun name ->
|
|
if not (Hashtbl.mem registry name) then
|
|
Printf.eprintf "[sx-http] WARNING: IO '%s' bound but not in registry\n%!" name
|
|
) expected
|
|
| _ -> ()
|
|
with _ -> ());
|
|
(* Extract app config from __app-config dict *)
|
|
(try match env_get env "__app-config" with
|
|
| Dict d ->
|
|
_app_config := Some d;
|
|
(* App config can add extra batchable helpers on top of registry *)
|
|
let extra = get_app_list "batchable-helpers" [] in
|
|
if extra <> [] then
|
|
batchable_helpers := List.sort_uniq String.compare (!batchable_helpers @ extra);
|
|
Printf.eprintf "[sx-http] App config loaded: title=%s prefix=%s\n%!"
|
|
(get_app_str "title" "?") (get_app_str "path-prefix" "?")
|
|
| _ -> Printf.eprintf "[sx-http] WARNING: __app-config is not a dict\n%!"
|
|
with _ -> Printf.eprintf "[sx-http] No __app-config found, using defaults\n%!");
|
|
(* SSR overrides — rebind browser-only functions AFTER .sx files load.
|
|
effect and register-in-scope are no-ops on the server; the SX definitions
|
|
from signals.sx are replaced so effect bodies never execute during SSR. *)
|
|
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);
|
|
(* Re-bind component-source — data/helpers.sx overrides the native version
|
|
with an SX version that calls env-get with wrong arity. Native version
|
|
uses env_get directly and handles pretty-printing in OCaml. *)
|
|
bind "component-source" (fun args ->
|
|
match args with
|
|
| [String name] ->
|
|
let lookup = if String.length name > 0 && name.[0] = '~'
|
|
then name
|
|
else "~" ^ name in
|
|
(try
|
|
let comp = env_get env lookup in
|
|
match comp with
|
|
| Component c ->
|
|
let params = List (List.map (fun s -> Symbol s) c.c_params) in
|
|
let form = List [Symbol "defcomp"; Symbol ("~" ^ c.c_name);
|
|
params; c.c_body] in
|
|
String (pretty_print_value form)
|
|
| Island c ->
|
|
let params = List (List.map (fun s -> Symbol s) c.i_params) in
|
|
let form = List [Symbol "defisland"; Symbol ("~" ^ c.i_name);
|
|
params; c.i_body] in
|
|
String (pretty_print_value form)
|
|
| _ -> String (";; " ^ name ^ ": not a component")
|
|
with _ -> String (";; component " ^ name ^ " not found"))
|
|
| _ -> raise (Eval_error "component-source: expected (name)"));
|
|
let jt0 = Unix.gettimeofday () in
|
|
let count = ref 0 in
|
|
(* 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";
|
|
"compile-letrec"; "compile-lambda"; "compile-define"; "compile-set";
|
|
"compile-quote"; "compile-cond"; "compile-case"; "compile-case-clauses";
|
|
"compile-thread"; "compile-thread-step"; "compile-defcomp";
|
|
"compile-defisland"; "compile-defmacro";
|
|
"compile-quasiquote"; "compile-qq-expr"; "compile-qq-list"; "compile-call";
|
|
"make-emitter"; "make-pool"; "make-scope"; "pool-add";
|
|
"scope-define-local"; "scope-resolve";
|
|
"emit-byte"; "emit-u16"; "emit-i16"; "emit-op"; "emit-const";
|
|
"current-offset"; "patch-i16";
|
|
] in
|
|
List.iter (fun name ->
|
|
try
|
|
match env_get env name with
|
|
| Lambda l ->
|
|
l.l_compiled <- Some Sx_vm.jit_failed_sentinel;
|
|
(match Sx_vm.jit_compile_lambda l (env_to_vm_globals env) with
|
|
| Some cl -> l.l_compiled <- Some cl; incr count
|
|
| None -> ())
|
|
| _ -> ()
|
|
with _ -> ()
|
|
) compiler_names;
|
|
let jt1 = Unix.gettimeofday () in
|
|
Printf.eprintf "[sx-http] JIT pre-compiled %d compiler fns in %.3fs\n%!" !count (jt1 -. jt0);
|
|
(* Re-bind native primitives that stdlib.sx may have overwritten with
|
|
narrower SX versions. The native assoc handles variadic key/value pairs
|
|
which evaluator.sx requires. *)
|
|
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"))));
|
|
(* Also re-bind highlight from SX lib if loaded *)
|
|
(try
|
|
let hl = env_get env "highlight" in
|
|
ignore hl (* already bound by lib/highlight.sx *)
|
|
with _ ->
|
|
(* Fallback: passthrough highlight *)
|
|
ignore (env_bind env "highlight" (NativeFn ("highlight", fun args ->
|
|
match args with
|
|
| String code :: _ -> SxExpr (Printf.sprintf "(pre :class \"text-sm overflow-x-auto\" (code \"%s\"))" (escape_sx_string code))
|
|
| _ -> Nil))));
|
|
(* Static file directory *)
|
|
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
|
|
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 *)
|
|
http_inject_shell_statics env static_dir sx_sxc;
|
|
(* Init shared VM globals AFTER all files loaded + shell statics injected.
|
|
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
|
|
immutable values), writes happen only during single-threaded startup. *)
|
|
let response_cache : (string, string) Hashtbl.t = Hashtbl.create 128 in
|
|
|
|
let cache_response path =
|
|
match http_render_page env path [] with
|
|
| Some html ->
|
|
let resp = http_response html in
|
|
Hashtbl.replace response_cache path resp;
|
|
Printf.eprintf "[cache] %s → %d bytes\n%!" path (String.length html)
|
|
| None ->
|
|
Printf.eprintf "[cache] %s → not found\n%!" path
|
|
in
|
|
|
|
(* Pre-warm + cache key pages — from config or just homepage *)
|
|
let warmup_paths = match get_app_config "warmup-paths" (Keyword "auto") with
|
|
| Keyword "auto" -> [get_app_str "path-prefix" "/sx/"]
|
|
| List l | ListRef { contents = l } ->
|
|
List.filter_map (function String s -> Some s | _ -> None) l
|
|
| _ -> [get_app_str "path-prefix" "/sx/"]
|
|
in
|
|
let t_warm = Unix.gettimeofday () in
|
|
List.iter cache_response warmup_paths;
|
|
let n_cached = Hashtbl.length response_cache in
|
|
Printf.eprintf "[sx-http] Pre-warmed %d pages in %.3fs\n%!"
|
|
n_cached (Unix.gettimeofday () -. t_warm);
|
|
|
|
(* Write full response to a socket *)
|
|
let write_response client response =
|
|
let resp_bytes = Bytes.of_string response in
|
|
let total = Bytes.length resp_bytes in
|
|
let written = ref 0 in
|
|
(try
|
|
while !written < total do
|
|
let n = Unix.write client resp_bytes !written (total - !written) in
|
|
written := !written + n
|
|
done
|
|
with Unix.Unix_error _ -> ());
|
|
(try Unix.close client with _ -> ())
|
|
in
|
|
|
|
(* Check if request has SX-Request header (SX AJAX navigation — return SX wire format)
|
|
or HX-Request header (htmx AJAX — return rendered HTML). *)
|
|
let has_substring s sub =
|
|
let slen = String.length s and sublen = String.length sub in
|
|
if sublen > slen then false
|
|
else let rec check i = if i > slen - sublen then false
|
|
else if String.sub s i sublen = sub then true else check (i + 1)
|
|
in check 0
|
|
in
|
|
let is_sx_request data =
|
|
let lower = String.lowercase_ascii data in
|
|
has_substring lower "sx-request" || has_substring lower "hx-request"
|
|
in
|
|
let _is_hx_request data =
|
|
let lower = String.lowercase_ascii data in
|
|
has_substring lower "hx-request" && not (has_substring lower "sx-request")
|
|
in
|
|
|
|
(* Non-blocking event loop with render worker pool.
|
|
- Main loop: Unix.select on listen socket + all connected clients
|
|
- Cached responses: served immediately from main loop (microseconds)
|
|
- Cache misses: queued to render workers (domain pool)
|
|
- Never blocks on rendering — accept loop always responsive *)
|
|
|
|
let n_workers = max 4 (Domain.recommended_domain_count ()) in
|
|
|
|
(* Render queue: for cache misses that need full page render *)
|
|
let render_queue : (Unix.file_descr * string * (string * string) list) list ref = ref [] in
|
|
let render_mutex = Mutex.create () in
|
|
let render_cond = Condition.create () in
|
|
let shutdown = ref false in
|
|
|
|
(* Render worker: processes cache misses in background *)
|
|
let render_worker _id () =
|
|
while not !shutdown do
|
|
let work =
|
|
Mutex.lock render_mutex;
|
|
while !render_queue = [] && not !shutdown do
|
|
Condition.wait render_cond render_mutex
|
|
done;
|
|
let w = match !render_queue with
|
|
| item :: rest -> render_queue := rest; Some item
|
|
| [] -> None
|
|
in
|
|
Mutex.unlock render_mutex;
|
|
w
|
|
in
|
|
match work with
|
|
| Some (fd, path, headers) ->
|
|
let is_ajax = headers <> [] in
|
|
let is_htmx = List.exists (fun (k,_) -> String.lowercase_ascii k = "hx-request") headers in
|
|
let cache_key = if is_ajax then (if is_htmx then "htmx:" else "ajax:") ^ path else path in
|
|
let response =
|
|
try
|
|
match http_render_page env path headers with
|
|
| Some body ->
|
|
(* htmx requests get HTML; SX requests get SX wire format *)
|
|
let final_body = if is_htmx then
|
|
(try
|
|
let exprs = Sx_parser.parse_all body in
|
|
let expr = match exprs with [e] -> e | [] -> Nil | _ -> List (Symbol "<>" :: exprs) in
|
|
Sx_render.sx_render_to_html env expr env
|
|
with _ -> body)
|
|
else body in
|
|
let ct = if is_ajax && not is_htmx then "text/sx; charset=utf-8"
|
|
else "text/html; charset=utf-8" in
|
|
let resp = http_response ~content_type:ct final_body in
|
|
Hashtbl.replace response_cache cache_key resp;
|
|
resp
|
|
| None -> http_response ~status:404 "<h1>Not Found</h1>"
|
|
with e ->
|
|
Printf.eprintf "[render] Error for %s: %s\n%!" path (Printexc.to_string e);
|
|
http_response ~status:500 "<h1>Internal Server Error</h1>"
|
|
in
|
|
write_response fd response
|
|
| None -> ()
|
|
done
|
|
in
|
|
|
|
(* Fast path: handle a request from the main loop.
|
|
Returns true if handled immediately (cached), false if queued. *)
|
|
let fast_handle fd data is_ajax =
|
|
match parse_http_request data with
|
|
| None -> write_response fd (http_response ~status:400 "Bad Request"); true
|
|
| Some (method_, raw_path) ->
|
|
begin
|
|
let path = url_decode (match String.index_opt raw_path '?' with
|
|
| Some i -> String.sub raw_path 0 i | None -> raw_path) in
|
|
let query = parse_query_string raw_path in
|
|
(* Set request context for primitives *)
|
|
_req_method := method_;
|
|
_req_query := query;
|
|
_req_headers := parse_http_headers data;
|
|
_req_body := (if method_ = "POST" || method_ = "PUT" || method_ = "PATCH"
|
|
then extract_body data else "");
|
|
(* Parse Cookie header into request_cookies for get-cookie primitive *)
|
|
Hashtbl.clear _request_cookies;
|
|
(match List.assoc_opt "cookie"
|
|
(List.map (fun (k,v) -> (String.lowercase_ascii k, v)) !_req_headers) with
|
|
| Some cookie_str ->
|
|
List.iter (fun pair ->
|
|
let trimmed = String.trim pair in
|
|
(match String.index_opt trimmed '=' with
|
|
| Some i ->
|
|
let k = String.sub trimmed 0 i in
|
|
let v = String.sub trimmed (i+1) (String.length trimmed - i - 1) in
|
|
Hashtbl.replace _request_cookies k v
|
|
| None -> ())
|
|
) (String.split_on_char ';' cookie_str)
|
|
| None -> ());
|
|
let app_prefix = get_app_str "path-prefix" "/sx/" in
|
|
let app_prefix_bare = if String.length app_prefix > 1
|
|
&& app_prefix.[String.length app_prefix - 1] = '/'
|
|
then String.sub app_prefix 0 (String.length app_prefix - 1) else app_prefix in
|
|
let app_home = get_app_str "home-path" app_prefix in
|
|
let debug_prefix = app_prefix ^ "_debug/" in
|
|
let debug_prefix_len = String.length debug_prefix in
|
|
if path = "/" then begin
|
|
write_response fd (http_redirect app_home); true
|
|
end else
|
|
(* Debug endpoint — runs on main thread, no render worker *)
|
|
let raw_decoded = url_decode raw_path in
|
|
if String.length path > debug_prefix_len
|
|
&& String.sub path 0 debug_prefix_len = debug_prefix then begin
|
|
let cmd = String.sub raw_decoded debug_prefix_len (String.length raw_decoded - debug_prefix_len) in
|
|
let query_start = try String.index cmd '?' with Not_found -> String.length cmd in
|
|
let action = String.sub cmd 0 query_start in
|
|
let query = if query_start < String.length cmd - 1
|
|
then String.sub cmd (query_start + 1) (String.length cmd - query_start - 1)
|
|
else "" in
|
|
let get_param key =
|
|
let prefix = key ^ "=" in
|
|
let parts = String.split_on_char '&' query in
|
|
match List.find_opt (fun p -> String.length p >= String.length prefix
|
|
&& String.sub p 0 (String.length prefix) = prefix) parts with
|
|
| Some p -> url_decode (String.sub p (String.length prefix) (String.length p - String.length prefix))
|
|
| None -> "" in
|
|
let result = match action with
|
|
| "env" ->
|
|
let name = get_param "name" in
|
|
(try
|
|
let v = env_get env name in
|
|
Printf.sprintf "%s = %s\n" name (Sx_runtime.value_to_str (Sx_runtime.type_of v))
|
|
with _ -> Printf.sprintf "%s = UNDEFINED\n" name)
|
|
| "eval" ->
|
|
let expr_s = get_param "expr" in
|
|
(try
|
|
let exprs = Sx_parser.parse_all expr_s in
|
|
let result = List.fold_left (fun _ e -> Sx_ref.eval_expr e (Env env)) Nil exprs in
|
|
Sx_runtime.value_to_str result ^ "\n"
|
|
with e -> Printf.sprintf "ERROR: %s\n" (Printexc.to_string e))
|
|
| "route" ->
|
|
let p = get_param "path" in
|
|
(try
|
|
let handler = env_get env "sx-handle-request" in
|
|
let headers_dict = Hashtbl.create 0 in
|
|
let r = Sx_ref.cek_call handler (List [String p; Dict headers_dict; Env env; Nil]) in
|
|
match r with
|
|
| Dict d ->
|
|
let page_ast = match Hashtbl.find_opt d "page-ast" with Some v -> v | _ -> Nil in
|
|
Printf.sprintf "page-ast: %s\n" (Sx_runtime.value_to_str page_ast)
|
|
| _ -> Printf.sprintf "route returned: %s\n" (Sx_runtime.value_to_str r)
|
|
with e -> Printf.sprintf "ERROR: %s\n" (Printexc.to_string e))
|
|
| _ -> "Unknown debug command. Try: env?name=X, eval?expr=X, route?path=X\n"
|
|
in
|
|
write_response fd (http_response ~content_type:"text/plain; charset=utf-8" result); true
|
|
end else
|
|
(* Handler endpoints: paths containing "(api." are handler calls,
|
|
not page renders. Evaluate the handler directly, return fragment. *)
|
|
let is_handler_path =
|
|
let rec has_sub s sub i =
|
|
if i + String.length sub > String.length s then false
|
|
else if String.sub s i (String.length sub) = sub then true
|
|
else has_sub s sub (i + 1) in
|
|
has_sub path "(api." 0 in
|
|
let app_prefix_len = String.length app_prefix in
|
|
let is_sx = path = app_prefix || path = app_prefix_bare
|
|
|| (String.length path > app_prefix_len
|
|
&& String.sub path 0 app_prefix_len = app_prefix) in
|
|
if is_sx && is_handler_path then begin
|
|
(* Handler dispatch — slug + path param extraction, method-based lookup, param binding *)
|
|
let response =
|
|
try
|
|
let slug, path_param_val =
|
|
let rec find_api s i =
|
|
if i + 5 > String.length s then ("", None)
|
|
else if String.sub s i 5 = "(api." then begin
|
|
let start = i + 5 in
|
|
if start < String.length s && s.[start] = '(' then begin
|
|
let inner = start + 1 in
|
|
let end_ = let rec sc j = if j >= String.length s then j
|
|
else match s.[j] with '.' | ')' -> j | _ -> sc (j+1) in sc inner in
|
|
let name = String.sub s inner (end_ - inner) in
|
|
let pval = if end_ < String.length s && s.[end_] = '.' then
|
|
let vs = end_ + 1 in
|
|
let ve = try String.index_from s vs ')' with Not_found -> String.length s in
|
|
Some (String.sub s vs (ve - vs)) else None in
|
|
(name, pval)
|
|
end else begin
|
|
let end_ = try String.index_from s start ')' with Not_found -> String.length s in
|
|
(String.sub s start (end_ - start), None)
|
|
end
|
|
end else find_api s (i + 1) in
|
|
find_api path 0 in
|
|
let req_method = String.uppercase_ascii !_req_method in
|
|
let try_key k = try let v = env_get env k in
|
|
if v <> Nil then Some (k, v) else None with _ -> None in
|
|
let handler_prefix_list = get_app_list "handler-prefixes"
|
|
["handler:ex-"; "handler:reactive-"; "handler:"] in
|
|
let prefixes = List.map (fun p -> p ^ slug) handler_prefix_list in
|
|
let suffixes = match req_method with
|
|
| "POST" -> List.concat_map (fun base -> [base; base ^ "-save"; base ^ "-submit"]) prefixes
|
|
| "PUT" | "PATCH" -> List.concat_map (fun base -> [base; base ^ "-put"; base ^ "-save"]) prefixes
|
|
| "DELETE" -> prefixes
|
|
| _ -> List.concat_map (fun base -> [base; base ^ "-form"; base ^ "-status"]) prefixes in
|
|
let found = List.fold_left (fun acc k ->
|
|
match acc with Some _ -> acc | None -> try_key k) None suffixes in
|
|
(match found with
|
|
| None ->
|
|
http_response ~status:404 ~content_type:"text/sx; charset=utf-8"
|
|
(Printf.sprintf "(div :class \"p-4 text-rose-600\" \"Handler not found: %s\")" (List.hd prefixes))
|
|
| Some (_hk, hdef) ->
|
|
(match path_param_val with
|
|
| Some pval ->
|
|
let ppath = (match hdef with Dict d ->
|
|
(match Hashtbl.find_opt d "path" with Some (String s) -> s | _ -> "") | _ -> "") in
|
|
let pname = let rec f s i = if i + 4 > String.length s then "id"
|
|
else if String.sub s i 4 = "<sx:" then
|
|
let gt = try String.index_from s (i+4) '>' with Not_found -> String.length s in
|
|
String.map (fun c -> if c = '_' then '-' else c) (String.sub s (i+4) (gt-i-4))
|
|
else f s (i+1) in f ppath 0 in
|
|
let sep = if !_req_query = "" then "" else "&" in
|
|
_req_query := !_req_query ^ sep ^ pname ^ "=" ^ pval
|
|
| None -> ());
|
|
let body = (match hdef with Dict d ->
|
|
(match Hashtbl.find_opt d "body" with Some v -> v | None -> Nil) | _ -> Nil) in
|
|
let params = (match hdef with Dict d ->
|
|
(match Hashtbl.find_opt d "params" with
|
|
| Some (List p) -> p | Some (ListRef r) -> !r | _ -> []) | _ -> []) in
|
|
let param_names = List.filter_map (fun p -> match p with
|
|
| Symbol s when s <> "&key" && s <> "&rest" -> Some s
|
|
| String s when s <> "&key" && s <> "&rest" -> Some s
|
|
| _ -> None) params in
|
|
(* Bind handler params in env before aser.
|
|
Try request-form first for POST (request-arg returns "" as default,
|
|
which is truthy in SX, preventing or-fallback to request-form). *)
|
|
let is_post = req_method = "POST" || req_method = "PUT" || req_method = "PATCH" in
|
|
List.iter (fun n ->
|
|
let v = try
|
|
let form_val = Sx_ref.eval_expr (List [Symbol "request-form"; String n]) (Env env) in
|
|
let arg_val = Sx_ref.eval_expr (List [Symbol "request-arg"; String n]) (Env env) in
|
|
if is_post then (if form_val <> String "" then form_val else arg_val)
|
|
else (if arg_val <> Nil then arg_val else form_val)
|
|
with _ -> Nil in
|
|
ignore (env_bind env n v)
|
|
) param_names;
|
|
let aser_call = List [Symbol "aser"; List [Symbol "quote"; body]; Env env] in
|
|
let body_str = match Sx_ref.eval_expr aser_call (Env env) with
|
|
| String s | SxExpr s -> s | v -> Sx_types.inspect v in
|
|
let status = !_pending_response_status in
|
|
(* HX-Request → render to HTML for htmx; otherwise SX wire format *)
|
|
let is_hx = has_substring (String.lowercase_ascii data) "hx-request" in
|
|
if is_hx then
|
|
let html = try
|
|
let exprs = Sx_parser.parse_all body_str in
|
|
let expr = match exprs with [e] -> e | [] -> Nil | _ -> List (Symbol "<>" :: exprs) in
|
|
Sx_render.sx_render_to_html env expr env
|
|
with _ -> body_str in
|
|
http_response ~status ~content_type:"text/html; charset=utf-8" html
|
|
else
|
|
http_response ~status ~content_type:"text/sx; charset=utf-8" body_str)
|
|
with e ->
|
|
Printf.eprintf "[handler] 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\" \"Handler error: %s\")"
|
|
(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). *)
|
|
ignore (env_bind env "expand-components?" (NativeFn ("expand-components?", fun _args -> Bool true)));
|
|
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 is_htmx_req = is_ajax && has_substring (String.lowercase_ascii data) "hx-request" in
|
|
let cache_key = if is_htmx_req then "htmx:" ^ path
|
|
else if is_ajax then "ajax:" ^ path else path in
|
|
match (if has_state_cookie || is_htmx_req then None
|
|
else Hashtbl.find_opt response_cache cache_key) with
|
|
| Some cached -> write_response fd cached; true
|
|
| None ->
|
|
if is_ajax then begin
|
|
(* AJAX: render on main thread — aser only, fast, no SSR.
|
|
Avoids queueing behind slow full-page renders.
|
|
HX-Request (htmx) gets HTML; SX-Request gets SX wire format. *)
|
|
let headers = parse_http_headers data in
|
|
let is_htmx = List.exists (fun (k,_) ->
|
|
String.lowercase_ascii k = "hx-request") headers in
|
|
let response =
|
|
try match http_render_page env path headers with
|
|
| Some body ->
|
|
let final_body = if is_htmx then
|
|
(try
|
|
let exprs = Sx_parser.parse_all body in
|
|
let expr = match exprs with [e] -> e | [] -> Nil | _ -> List (Symbol "<>" :: exprs) in
|
|
Sx_render.sx_render_to_html env expr env
|
|
with _ -> body)
|
|
else body in
|
|
let ct = if is_htmx then "text/html; charset=utf-8"
|
|
else "text/sx; charset=utf-8" in
|
|
let resp = http_response ~content_type:ct final_body in
|
|
if not is_htmx then Hashtbl.replace response_cache cache_key resp;
|
|
resp
|
|
| None -> http_response ~status:404
|
|
"(div :class \"p-8\" (h2 :class \"text-rose-600 font-semibold\" \"Page not found\") (p :class \"text-stone-500\" \"No route matched this path\"))"
|
|
with e ->
|
|
Printf.eprintf "[ajax] Error for %s: %s\n%!" path (Printexc.to_string e);
|
|
http_response ~status:500
|
|
(Printf.sprintf "(div :class \"p-8\" (h2 :class \"text-rose-600 font-semibold\" \"Render Error\") (pre :class \"text-sm bg-stone-100 p-4 rounded\" \"%s\"))"
|
|
(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 "<h1>Not Found</h1>"
|
|
with e ->
|
|
Printf.eprintf "[render] Cookie render error for %s: %s\n%!" path (Printexc.to_string e);
|
|
http_response ~status:500 "<h1>Error</h1>"
|
|
in
|
|
write_response fd response; true
|
|
end else begin
|
|
(* Full page: queue to render worker *)
|
|
Mutex.lock render_mutex;
|
|
render_queue := !render_queue @ [(fd, path, [])];
|
|
Condition.signal render_cond;
|
|
Mutex.unlock render_mutex;
|
|
false
|
|
end
|
|
end else if String.length path > 8 && String.sub path 0 8 = "/static/" then begin
|
|
write_response fd (serve_static_file static_dir path); true
|
|
end else begin
|
|
write_response fd (http_response ~status:404 "<h1>Not Found</h1>"); true
|
|
end
|
|
end
|
|
in
|
|
|
|
(* Spawn render workers *)
|
|
let workers = Array.init n_workers (fun id ->
|
|
Domain.spawn (render_worker id)) in
|
|
|
|
(* Start TCP server — non-blocking accept loop *)
|
|
let sock = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in
|
|
Unix.setsockopt sock Unix.SO_REUSEADDR true;
|
|
Unix.bind sock (Unix.ADDR_INET (Unix.inet_addr_any, port));
|
|
Unix.listen sock 1024;
|
|
Printf.eprintf "[sx-http] Listening on port %d (%d render workers, non-blocking)\n%!" port n_workers;
|
|
|
|
(* Auto-restart: check if binary has changed every N requests *)
|
|
let binary_path = Sys.executable_name in
|
|
let binary_mtime = try (Unix.stat binary_path).Unix.st_mtime with _ -> 0.0 in
|
|
let request_count = ref 0 in
|
|
let check_interval = 10 in (* check every 10 requests *)
|
|
let check_restart () =
|
|
incr request_count;
|
|
if !request_count mod check_interval = 0 then begin
|
|
let current_mtime = try (Unix.stat binary_path).Unix.st_mtime with _ -> 0.0 in
|
|
if current_mtime > binary_mtime then begin
|
|
Printf.eprintf "[sx-http] Binary changed, restarting...\n%!";
|
|
(* Close listen socket, then exec self *)
|
|
Unix.close sock;
|
|
Unix.execv binary_path (Array.of_list (Array.to_list Sys.argv))
|
|
end
|
|
end
|
|
in
|
|
|
|
(try
|
|
while true do
|
|
(* Accept a connection *)
|
|
let (client, _addr) = Unix.accept sock in
|
|
check_restart ();
|
|
(* Read request — non-blocking: set a short timeout *)
|
|
Unix.setsockopt_float client Unix.SO_RCVTIMEO 5.0;
|
|
Unix.setsockopt_float client Unix.SO_SNDTIMEO 10.0;
|
|
let buf = Buffer.create 8192 in
|
|
let tmp = Bytes.create 8192 in
|
|
let n = try Unix.read client tmp 0 8192 with _ -> 0 in
|
|
Buffer.add_subbytes buf tmp 0 n;
|
|
(* For POST: ensure full body is read based on Content-Length *)
|
|
if n > 0 then begin
|
|
let initial = Buffer.contents buf in
|
|
let header_end =
|
|
let rec find s i = if i + 4 > String.length s then -1
|
|
else if String.sub s i 4 = "\r\n\r\n" then i + 4
|
|
else find s (i + 1) in find initial 0 in
|
|
if header_end > 0 then begin
|
|
(* Parse Content-Length from headers *)
|
|
let headers_str = String.lowercase_ascii (String.sub initial 0 header_end) in
|
|
let content_length =
|
|
let rec find_cl s i =
|
|
if i + 16 > String.length s then 0
|
|
else if String.sub s i 16 = "content-length: " then
|
|
let start = i + 16 in
|
|
let end_ = try String.index_from s start '\r' with Not_found ->
|
|
try String.index_from s start '\n' with Not_found -> String.length s in
|
|
(try int_of_string (String.trim (String.sub s start (end_ - start))) with _ -> 0)
|
|
else find_cl s (i + 1) in find_cl headers_str 0 in
|
|
let body_so_far = String.length initial - header_end in
|
|
let remaining = content_length - body_so_far in
|
|
if remaining > 0 then begin
|
|
let body_buf = Bytes.create remaining in
|
|
let read_so_far = ref 0 in
|
|
while !read_so_far < remaining do
|
|
let r = try Unix.read client body_buf !read_so_far (remaining - !read_so_far)
|
|
with _ -> 0 in
|
|
if r = 0 then read_so_far := remaining (* EOF *)
|
|
else read_so_far := !read_so_far + r
|
|
done;
|
|
Buffer.add_subbytes buf body_buf 0 !read_so_far
|
|
end
|
|
end
|
|
end;
|
|
let n = Buffer.length buf in
|
|
if n > 0 then begin
|
|
let data = Buffer.contents buf in
|
|
let is_ajax = is_sx_request data in
|
|
if is_ajax then Printf.eprintf "[sx-http] AJAX request detected\n%!";
|
|
let handled =
|
|
try fast_handle client data is_ajax
|
|
with e ->
|
|
Printf.eprintf "[sx-http] Error: %s\n%!" (Printexc.to_string e);
|
|
write_response client (http_response ~status:500 "<h1>Internal Server Error</h1>");
|
|
true
|
|
in
|
|
ignore handled
|
|
end else
|
|
(try Unix.close client with _ -> ())
|
|
done
|
|
with _ ->
|
|
shutdown := true;
|
|
Condition.broadcast render_cond;
|
|
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
|
|
if List.mem "--test" args then test_mode ()
|
|
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
|
|
let rec find = function
|
|
| "--http" :: p :: _ -> (try port := int_of_string p with _ -> ())
|
|
| _ :: rest -> find rest
|
|
| [] -> ()
|
|
in find args;
|
|
http_mode !port
|
|
end
|
|
else begin
|
|
(* Normal persistent server mode *)
|
|
let env = make_server_env () in
|
|
send "(ready)";
|
|
(* Main command loop *)
|
|
try
|
|
while true do
|
|
match read_line_blocking () with
|
|
| None -> exit 0 (* stdin closed *)
|
|
| Some line ->
|
|
let line = String.trim line in
|
|
if line = "" then () (* skip blank lines *)
|
|
(* Discard stale io-responses from previous requests. *)
|
|
else if String.length line > 14
|
|
&& String.sub line 0 14 = "(io-response " then
|
|
Printf.eprintf "[sx-server] discarding stale io-response (%d chars)\n%!"
|
|
(String.length line)
|
|
else begin
|
|
let exprs = Sx_parser.parse_all line in
|
|
match exprs with
|
|
(* Epoch marker: (epoch N) — set current epoch, read next command *)
|
|
| [List [Symbol "epoch"; Number n]] ->
|
|
current_epoch := int_of_float n
|
|
| [cmd] -> dispatch env cmd
|
|
| _ -> send_error ("Expected single command, got " ^ string_of_int (List.length exprs))
|
|
end
|
|
done
|
|
with
|
|
| End_of_file -> ()
|
|
end
|