coop/rose-ash
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Server cleanup: extract app-specific config into SX

Browse Source 
Phase 1 Step 2 of architecture roadmap. The OCaml HTTP server is now
generic — all sx_docs-specific values (layout components, path prefix,
title, warmup paths, handler prefixes, CSS/JS, client libs) move into
sx/sx/app-config.sx as a __app-config dict. Server reads config at
startup with hardcoded defaults as fallback, so it works with no config,
partial config, or full config.

Removed: 9 demo data stubs, stepper cookie cache logic, page-functions.sx
directory heuristic. Added: 29-test server config test suite covering
standard, custom, no-config, and minimal-config scenarios.

Co-Authored-By: Claude Opus 4.6 (1M context) <noreply@anthropic.com>
This commit is contained in:
giles
2026-04-02 21:00:32 +00:00
parent 9dd90eba7f
commit 17b6c872f2
4 changed files with 364 additions and 61 deletions
Download Patch File Download Diff File Expand all files Collapse all files

139
hosts/ocaml/bin/sx_server.ml
View File

@@ -146,16 +146,35 @@ let io_counter = ref 0
let _request_cookies = Sx_scope.request_cookies
let _scope_stacks = Sx_scope.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 = [
let batchable_helpers = ref [
"highlight"; "component-source"
]
let is_batchable name args =
name = "helper" &&
match args with
| String h :: _ -> List.mem h batchable_helpers
| String h :: _ -> List.mem h !batchable_helpers
| _ -> false
(** Read an io-response from stdin, discarding stale messages from old epochs. *)
@@ -1615,7 +1634,8 @@ let http_render_page env path headers =
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 wrapped = List [Symbol "~layouts/doc"; Keyword "path"; String nav_path; page_ast] in
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 =
@@ -1628,7 +1648,8 @@ let http_render_page env path headers =
Some body_str
end else begin
(* Full page: aser → SSR → shell *)
let full_ast = List [Symbol "~shared:layout/app-body"; Keyword "content"; wrapped] in
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 =
@@ -1650,7 +1671,7 @@ let http_render_page env path headers =
let t3 = Unix.gettimeofday () in
let get_shell name = try env_get env ("__shell-" ^ name) with _ -> Nil in
let shell_args = [
Keyword "title"; String "SX"; Keyword "csrf"; String "";
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";
@@ -1666,7 +1687,8 @@ let http_render_page env path headers =
Keyword "init-sx"; get_shell "init-sx";
Keyword "meta-html"; String "";
] in
let shell_call = List (Symbol "~shared:shell/sx-page-shell" :: shell_args) 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";
@@ -1769,11 +1791,8 @@ let http_inject_shell_statics env static_dir sx_sxc =
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_libs = [
templates_dir ^ "/tw-layout.sx";
templates_dir ^ "/tw-type.sx";
templates_dir ^ "/tw.sx";
] 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
@@ -1809,9 +1828,9 @@ let http_inject_shell_statics env static_dir sx_sxc =
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 tw_css = read_css_file (static_dir ^ "/styles/tw.css") in
let basics_css = read_css_file (static_dir ^ "/styles/basics.css") in
let sx_css = basics_css ^ "\n" ^ tw_css in
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.
@@ -1840,11 +1859,13 @@ let http_inject_shell_statics env static_dir sx_sxc =
| Some v -> serialize_value v | _ -> "" in
let has_data = match extract_kw "data" rest with
| Some _ -> true | None -> false in
if path_val <> "" then
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 _ -> ()
@@ -1864,16 +1885,17 @@ let http_inject_shell_statics env static_dir sx_sxc =
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).
The boot code hydrates existing islands but doesn't do fresh render.
This script forces a render from page-sx after boot completes. *)
ignore (env_bind env "__shell-init-sx" (String
(* 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
@@ -2292,17 +2314,7 @@ let http_setup_page_helpers env =
with _ -> String (";; component " ^ name ^ " not found"))
| _ -> raise (Eval_error "component-source: expected (name)"));
(* Stub remaining demo/action helpers that need real IO *)
let stub name = bind name (fun _args -> Nil) in
stub "run-spec-tests";
stub "run-modular-tests";
stub "streaming-demo-data";
stub "affinity-demo-data";
stub "optimistic-demo-data";
stub "action:add-demo-item";
stub "offline-demo-data";
stub "prove-data";
stub "page-helpers-demo-data"
ignore bind (* suppress unused warning *)
let http_mode port =
let env = make_server_env () in
@@ -2325,11 +2337,16 @@ let http_mode port =
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 ->
(* Docker: /app/sx, dev: /project/sx/sx *)
let docker_path = project_dir ^ "/sx" in
let dev_path = project_dir ^ "/sx/sx" in
if Sys.file_exists (docker_path ^ "/page-functions.sx") then docker_path
else dev_path 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));
@@ -2387,6 +2404,15 @@ let http_mode port =
load_dir sx_sx;
let t1 = Unix.gettimeofday () in
Printf.eprintf "[sx-http] All files loaded in %.3fs\n%!" (t1 -. t0);
(* Extract app config from __app-config dict *)
(try match env_get env "__app-config" with
| Dict d ->
_app_config := Some d;
batchable_helpers := get_app_list "batchable-helpers" ["highlight"; "component-source"];
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. *)
@@ -2497,14 +2523,15 @@ let http_mode port =
Printf.eprintf "[cache] %s → not found\n%!" path
in
(* Pre-warm + cache all key pages *)
let _warmup_paths = ["/sx/"; "/sx/(geography)"; "/sx/(language)"; "/sx/(applications)";
"/sx/(geography.(reactive.(examples)))";
"/sx/(applications.(sxtp))"; "/sx/(geography.(cek))";
"/sx/(geography.(reactive))"; "/sx/(geography.(hypermedia))";
] 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;
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);
@@ -2619,13 +2646,21 @@ let http_mode port =
| 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 "/sx/"); true
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 > 11 && String.sub path 0 11 = "/sx/_debug/" then begin
let cmd = String.sub raw_decoded 11 (String.length raw_decoded - 11) 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
@@ -2676,8 +2711,10 @@ let http_mode port =
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 is_sx = path = "/sx/" || path = "/sx"
|| (String.length path > 4 && String.sub path 0 4 = "/sx/") 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 =
@@ -2706,8 +2743,9 @@ let http_mode port =
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
(* Try multiple handler name patterns: ex-slug, reactive-slug, slug *)
let prefixes = ["handler:ex-" ^ slug; "handler:reactive-" ^ slug; "handler:" ^ slug] 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
@@ -2763,10 +2801,7 @@ let http_mode port =
in
write_response fd response; true
end else if is_sx then begin
let has_stepper_cookie = Hashtbl.mem _request_cookies "sx-home-stepper" in
let cache_key = if is_ajax then "ajax:" ^ path
else if has_stepper_cookie then path ^ ":step=" ^ (try Hashtbl.find _request_cookies "sx-home-stepper" with Not_found -> "")
else path in
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 ->