sx-host step 3: HTTP server mode + define shorthand + SX highlighter
HTTP server (--http PORT): OCaml serves sx-docs directly, no Python. Loads components at startup, routes /sx/ URLs, renders full pages with shell. Geography page: 124ms TTFB (vs 144ms Quart). Single process. define shorthand: (define (name args) body) desugars to (define name (fn (args) body)) in the CEK step function. SX highlighter (lib/highlight.sx): pure SX syntax highlighting with Tailwind spans. Tokenizes SX/Lisp code — comments, strings, keywords, components, specials, numbers, booleans. Replaces Python highlight.py. Platform constructors: make-lambda, make-component, make-island, make-macro, make-thunk, make-env + accessor functions bound for evaluator.sx compatibility in HTTP mode. Tests: 1116/1117 OCaml, 7/7 Playwright (main tree). Co-Authored-By: Claude Opus 4.6 (1M context) <noreply@anthropic.com>
This commit is contained in:
@@ -1391,6 +1391,396 @@ let test_mode () =
|
||||
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
|
||||
|
||||
(** Render a page from an SX URL path. Returns HTML or None. *)
|
||||
let http_render_page env path =
|
||||
let t0 = Unix.gettimeofday () in
|
||||
(* Parse the URL path to an SX expression *)
|
||||
let path_expr =
|
||||
if path = "/" || path = "/sx/" || path = "/sx" then "home"
|
||||
else begin
|
||||
let p = if String.length path > 4 && String.sub path 0 4 = "/sx/" then
|
||||
String.sub path 4 (String.length path - 4)
|
||||
else if String.length path > 1 && path.[0] = '/' then
|
||||
String.sub path 1 (String.length path - 1)
|
||||
else path
|
||||
in
|
||||
(* URL convention: dots → spaces *)
|
||||
String.map (fun c -> if c = '.' then ' ' else c) p
|
||||
end
|
||||
in
|
||||
(* Evaluate page function to get component call *)
|
||||
let page_ast =
|
||||
try
|
||||
let exprs = Sx_parser.parse_all path_expr in
|
||||
let expr = match exprs with [e] -> e | _ -> List exprs in
|
||||
Sx_ref.eval_expr expr (Env env)
|
||||
with e ->
|
||||
Printf.eprintf "[http-route] eval failed for '%s': %s\n%!" path_expr (Printexc.to_string e);
|
||||
Nil
|
||||
in
|
||||
if page_ast = Nil then None
|
||||
else begin
|
||||
(* Wrap: (~layouts/doc :path "/sx/..." content) → (~shared:layout/app-body :content wrapped) *)
|
||||
let nav_path = if String.length path >= 4 && String.sub path 0 4 = "/sx/" then path
|
||||
else "/sx" ^ path in
|
||||
let wrapped = List [
|
||||
Symbol "~layouts/doc"; Keyword "path"; String nav_path; page_ast
|
||||
] in
|
||||
let full_ast = List [
|
||||
Symbol "~shared:layout/app-body"; Keyword "content"; wrapped
|
||||
] in
|
||||
let page_source = serialize_value full_ast in
|
||||
let t1 = Unix.gettimeofday () in
|
||||
(* Phase 1: aser — expand all components server-side *)
|
||||
let expand_fn = NativeFn ("expand-components?", fun _args -> Bool true) in
|
||||
ignore (env_bind env "expand-components?" expand_fn);
|
||||
let body_result =
|
||||
try
|
||||
let call = List [Symbol "aser"; List [Symbol "quote"; full_ast]; Env env] in
|
||||
Sx_ref.eval_expr call (Env env)
|
||||
with e ->
|
||||
Hashtbl.remove env.bindings (Sx_types.intern "expand-components?");
|
||||
raise e
|
||||
in
|
||||
Hashtbl.remove env.bindings (Sx_types.intern "expand-components?");
|
||||
let body_str = match body_result with
|
||||
| String s | SxExpr s -> s
|
||||
| _ -> serialize_value body_result
|
||||
in
|
||||
let t2 = Unix.gettimeofday () in
|
||||
(* Phase 2: SSR — render to HTML *)
|
||||
let body_html =
|
||||
try
|
||||
let body_exprs = Sx_parser.parse_all body_str 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 "[http-ssr] failed: %s\n%!" (Printexc.to_string e); ""
|
||||
in
|
||||
let t3 = Unix.gettimeofday () in
|
||||
(* Phase 3: Shell — wrap in full HTML page.
|
||||
Shell kwargs reference pre-injected __shell-* vars from env. *)
|
||||
let get_shell_var name = try env_get env ("__shell-" ^ name) with _ -> Nil in
|
||||
let shell_args = [
|
||||
Keyword "title"; String "SX";
|
||||
Keyword "csrf"; String "";
|
||||
Keyword "page-sx"; String page_source;
|
||||
Keyword "body-html"; String body_html;
|
||||
Keyword "component-defs"; get_shell_var "component-defs";
|
||||
Keyword "component-hash"; get_shell_var "component-hash";
|
||||
Keyword "pages-sx"; get_shell_var "pages-sx";
|
||||
Keyword "sx-css"; get_shell_var "sx-css";
|
||||
Keyword "sx-css-classes"; get_shell_var "sx-css-classes";
|
||||
Keyword "asset-url"; get_shell_var "asset-url";
|
||||
Keyword "sx-js-hash"; get_shell_var "sx-js-hash";
|
||||
Keyword "body-js-hash"; get_shell_var "body-js-hash";
|
||||
Keyword "wasm-hash"; get_shell_var "wasm-hash";
|
||||
Keyword "head-scripts"; get_shell_var "head-scripts";
|
||||
Keyword "body-scripts"; get_shell_var "body-scripts";
|
||||
Keyword "inline-css"; get_shell_var "inline-css";
|
||||
Keyword "inline-head-js"; get_shell_var "inline-head-js";
|
||||
Keyword "init-sx"; get_shell_var "init-sx";
|
||||
Keyword "use-wasm"; Bool (try Sys.getenv "SX_USE_WASM" = "1" with Not_found -> false);
|
||||
Keyword "meta-html"; String "";
|
||||
] 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 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
|
||||
|
||||
(** Pre-compute shell statics and inject into env as __shell-* vars. *)
|
||||
let http_inject_shell_statics env =
|
||||
(* Component definitions for client *)
|
||||
let buf = Buffer.create 65536 in
|
||||
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 component_defs = Buffer.contents buf in
|
||||
let component_hash = Digest.string component_defs |> Digest.to_hex in
|
||||
ignore (env_bind env "__shell-component-defs" (String component_defs));
|
||||
ignore (env_bind env "__shell-component-hash" (String component_hash));
|
||||
ignore (env_bind env "__shell-pages-sx" (String ""));
|
||||
ignore (env_bind env "__shell-sx-css" (String ""));
|
||||
ignore (env_bind env "__shell-sx-css-classes" (String ""));
|
||||
ignore (env_bind env "__shell-asset-url" (String "/static"));
|
||||
ignore (env_bind env "__shell-sx-js-hash" (String ""));
|
||||
ignore (env_bind env "__shell-body-js-hash" (String ""));
|
||||
ignore (env_bind env "__shell-wasm-hash" (String ""));
|
||||
ignore (env_bind env "__shell-head-scripts" Nil);
|
||||
ignore (env_bind env "__shell-body-scripts" Nil);
|
||||
ignore (env_bind env "__shell-inline-css" Nil);
|
||||
ignore (env_bind env "__shell-inline-head-js" Nil);
|
||||
ignore (env_bind env "__shell-init-sx" Nil);
|
||||
Printf.eprintf "[sx-http] Shell statics injected (defs=%d hash=%s)\n%!"
|
||||
(String.length component_defs) component_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"
|
||||
|
||||
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
|
||||
|
||||
let http_setup_page_helpers env =
|
||||
(* Page helpers that Python normally provides. Minimal stubs for HTTP mode. *)
|
||||
let bind name fn = ignore (env_bind env name (NativeFn (name, fn))) in
|
||||
(* highlight — passthrough without syntax coloring *)
|
||||
bind "highlight" (fun args ->
|
||||
match args with
|
||||
| String code :: _ ->
|
||||
let escaped = escape_sx_string code in
|
||||
SxExpr (Printf.sprintf "(pre :class \"text-sm overflow-x-auto\" (code \"%s\"))" escaped)
|
||||
| _ -> Nil);
|
||||
(* component-source — stub *)
|
||||
bind "component-source" (fun _args -> String "")
|
||||
|
||||
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 = project_dir ^ "/shared/sx/templates" in
|
||||
let sx_sx = project_dir ^ "/sx/sx" in
|
||||
let t0 = Unix.gettimeofday () in
|
||||
(* Core spec + adapters.
|
||||
Skip primitives.sx (declarative metadata — all prims are native in OCaml)
|
||||
and types.sx (gradual type system — not needed for rendering). *)
|
||||
let core_files = [
|
||||
spec_base ^ "/parser.sx";
|
||||
spec_base ^ "/render.sx"; spec_base ^ "/evaluator.sx";
|
||||
web_base ^ "/adapter-html.sx"; web_base ^ "/adapter-sx.sx";
|
||||
web_base ^ "/web-forms.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"] in
|
||||
let load_dir dir =
|
||||
if Sys.file_exists dir && Sys.is_directory dir then begin
|
||||
let files = Sys.readdir dir in
|
||||
Array.sort String.compare files;
|
||||
Array.iter (fun f ->
|
||||
if Filename.check_suffix f ".sx"
|
||||
&& not (List.mem f skip_files)
|
||||
&& not (Filename.check_suffix f ".test.sx") then
|
||||
http_load_files env [dir ^ "/" ^ f]
|
||||
) files
|
||||
end
|
||||
in
|
||||
load_dir lib_base;
|
||||
load_dir shared_sx;
|
||||
load_dir sx_sx;
|
||||
let t1 = Unix.gettimeofday () in
|
||||
Printf.eprintf "[sx-http] All files loaded in %.3fs\n%!" (t1 -. t0);
|
||||
(* Inject shell statics *)
|
||||
http_inject_shell_statics env;
|
||||
(* Start TCP server *)
|
||||
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 128;
|
||||
Printf.eprintf "[sx-http] Listening on port %d (project=%s)\n%!" port project_dir;
|
||||
while true do
|
||||
let (client, _addr) = Unix.accept sock in
|
||||
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 response =
|
||||
try
|
||||
match parse_http_request data with
|
||||
| None -> http_response ~status:400 "Bad Request"
|
||||
| Some (method_, raw_path) ->
|
||||
if method_ <> "GET" && method_ <> "HEAD" then
|
||||
http_response ~status:405 "Method Not Allowed"
|
||||
else begin
|
||||
let path = url_decode raw_path in
|
||||
let is_sx = path = "/" || path = "/sx/" || path = "/sx"
|
||||
|| (String.length path > 4 && String.sub path 0 4 = "/sx/") in
|
||||
if is_sx then
|
||||
match http_render_page env path with
|
||||
| Some html -> http_response html
|
||||
| None -> http_response ~status:404 "<h1>Not Found</h1>"
|
||||
else
|
||||
http_response ~status:404 "<h1>Not Found</h1>"
|
||||
end
|
||||
with e ->
|
||||
Printf.eprintf "[sx-http] Error: %s\n%!" (Printexc.to_string e);
|
||||
http_response ~status:500 "<h1>Internal Server Error</h1>"
|
||||
in
|
||||
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 _ -> ());
|
||||
end;
|
||||
(try Unix.close client with _ -> ())
|
||||
done
|
||||
|
||||
|
||||
let () =
|
||||
(* Check for CLI mode flags *)
|
||||
let args = Array.to_list Sys.argv in
|
||||
@@ -1398,6 +1788,16 @@ let () =
|
||||
else if List.mem "--render" args then cli_mode "render"
|
||||
else if List.mem "--aser-slot" args then cli_mode "aser-slot"
|
||||
else if List.mem "--aser" args then cli_mode "aser"
|
||||
else if List.mem "--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
|
||||
|
||||
Reference in New Issue
Block a user