coop/rose-ash
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
Files
19e7a6ee2d880887036f830edcd0620167073281
rose-ash/hosts/ocaml/bin/sx_server.ml
giles 19e7a6ee2d Step 5.5 phases 1-2: merge sx_scope into sx_primitives, 4-child define support 
Phase 1: Absorb sx_scope.ml (180 lines) into sx_primitives.ml. Scope stacks,
cookies, and trace infrastructure now live alongside other primitives. All 20
scope primitive registrations moved. References updated in sx_server.ml and
sx_browser.ml. sx_scope.ml deleted.

Phase 2: Transpiler handles (define name :effects (...) (fn ...)) forms.
ml-emit-define and ml-emit-define-body detect keyword at position 2 and use
(last expr) instead. Unblocks transpilation of spec/render.sx and
web/adapter-html.sx which use 4-child defines extensively.

2598/2598 tests passing.

Co-Authored-By: Claude Opus 4.6 (1M context) <noreply@anthropic.com>
2026-04-03 19:43:26 +00:00

3052 lines
136 KiB
OCaml
Raw Blame History

(** 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
(* ====================================================================== *)
(* 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"
(** 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 []
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
(** IO-aware CEK run — handles suspension by dispatching IO requests.
When the CEK machine suspends with a perform, this function sends
the IO request to the Python bridge, resumes with the response,
and repeats until evaluation completes. *)
let 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
(* Extract args based on operation type *)
let args = match op with
| "import" ->
let lib = Sx_runtime.get_val request (String "library") in
[String "import"; lib]
| _ ->
let a = Sx_runtime.get_val request (String "args") in
(match a with List l -> l | _ -> [a])
in
let response = 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. *)
let _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)
(* ---- 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)
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. *)
let _jit_compiling = ref false (* re-entrancy guard *)
(* 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) ->
(* Cached bytecode — run on VM, fall back to CEK on runtime error.
Log once per function name, then stay quiet. Don't disable. *)
(try Some (Sx_vm.call_closure cl args cl.vm_env_ref)
with
| Sx_vm.VmSuspended (request, saved_vm) ->
Some (make_vm_suspend_marker request saved_vm)
| 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;
None)
| Some _ -> None (* compile failed or disabled — CEK handles *)
| None ->
let fn_name = match l.l_name with Some n -> n | None -> "?" in
if !_jit_compiling then None
else if Hashtbl.mem _jit_warned fn_name then None
else begin
_jit_compiling := true;
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
_jit_compiling := false;
if dt > 0.5 || (match compiled with None -> true | _ -> false) then
Printf.eprintf "[jit] %s compile %s in %.3fs\n%!"
fn_name (match compiled with Some _ -> "OK" | None -> "FAIL") 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) ->
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;
None)
| None -> 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)
(* Command dispatch *)
(* ====================================================================== *)
let rec dispatch env cmd =
match cmd with
| List [Symbol "ping"] ->
send_ok_string "ocaml-cek"
| List [Symbol "load"; String path] ->
(try
let exprs = Sx_parser.parse_file path in
let prev_file = if Sx_types.env_has env "*current-file*" then Some (Sx_types.env_get env "*current-file*") else None in
ignore (Sx_types.env_bind env "*current-file*" (String path));
let count = ref 0 in
List.iter (fun expr ->
ignore (Sx_ref.eval_expr expr (Env env));
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 ->
Sx_ref.eval_expr expr (Env env)
) 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
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 "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.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.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 "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
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 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
(** 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 *)
let body_result =
let call = List [Symbol "aser"; List [Symbol "quote"; wrapped]; 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 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
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 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 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 "[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 "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
(* ====================================================================== *)
(* 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 ""
(** 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">.
The escape_sx_string function handles </ → <\\/ inside string
literals, preventing the HTML parser from matching </script>. *)
let component_defs = raw_defs 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-2.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 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
if path_val <> "" then begin
_defpage_paths := path_val :: !_defpage_paths;
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));
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 — starts empty, platforms extend via defio.
defio is a special form that populates __io-registry with metadata
about suspension points (IO ops that require platform resolution). *)
let io_registry = Hashtbl.create 64 in
ignore (env_bind env "__io-registry" (Dict io_registry));
ignore (Sx_ref.register_special_form (String "defio") (NativeFn ("defio", fun sf_args ->
let raw_args = match sf_args with
| [List a; Env _] | [ListRef { contents = a }; Env _] -> a
| _ -> [] in
match raw_args with
| String name :: rest ->
let entry = Hashtbl.create 8 in
let rec parse = function
| Keyword k :: v :: rest -> Hashtbl.replace entry k v; parse rest
| _ -> () in
parse rest;
Hashtbl.replace entry "name" (String name);
Hashtbl.replace io_registry name (Dict entry);
Dict entry
| _ -> Nil)))
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 env files =
(* Like cli_load_files but tolerant — logs errors, doesn't crash *)
List.iter (fun path ->
if Sys.file_exists path then begin
try
let exprs = Sx_parser.parse_file path in
List.iter (fun expr ->
try ignore (Sx_ref.eval_expr expr (Env env))
with e -> Printf.eprintf "[http-load] %s: %s\n%!" (Filename.basename path) (Printexc.to_string e)
) exprs
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)"));
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));
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"] in
let rec load_dir 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 path
end
else if Filename.check_suffix f ".sx"
&& not (List.mem f skip_files)
&& not (String.length f > 5 && String.sub f 0 5 = "test-")
&& not (Filename.check_suffix f ".test.sx") then
http_load_files env [path]
) 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 sx_sxc;
load_dir 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
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";
] 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;
(* 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;
(* 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 or HX-Request header (AJAX navigation) *)
let is_sx_request data =
let lower = String.lowercase_ascii data 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
has_substring lower "sx-request" || has_substring lower "hx-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 cache_key = if is_ajax then "ajax:" ^ path else path in
let response =
try
match http_render_page env path headers with
| Some body ->
let ct = if is_ajax then "text/sx; charset=utf-8"
else "text/html; charset=utf-8" in
let resp = http_response ~content_type:ct 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 *)
List.iter (fun n ->
let v = try Sx_ref.eval_expr
(List [Symbol "or"; List [Symbol "request-arg"; String n];
List [Symbol "request-form"; String n]]) (Env env)
with _ -> Nil in
ignore (env_bind env n v)
) param_names;
_pending_response_status := 200;
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
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 then begin
let cache_key = if is_ajax then "ajax:" ^ path else path in
match 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. *)
let headers = parse_http_headers data in
let response =
try match http_render_page env path headers with
| Some body ->
let resp = http_response ~content_type:"text/sx; charset=utf-8" body in
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 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 = Bytes.create 8192 in
let n = try Unix.read client buf 0 8192 with _ -> 0 in
if n > 0 then begin
let data = Bytes.sub_string buf 0 n 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)
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 "--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
Reference in New Issue View Git Blame Copy Permalink