Server cleanup: extract app-specific config into SX
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:
@@ -146,16 +146,35 @@ let io_counter = ref 0
|
|||||||
let _request_cookies = Sx_scope.request_cookies
|
let _request_cookies = Sx_scope.request_cookies
|
||||||
let _scope_stacks = Sx_scope.scope_stacks
|
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
|
(** Helpers safe to defer — pure functions whose results are only used
|
||||||
as rendering output (inlined into SX wire format), not in control flow. *)
|
as rendering output (inlined into SX wire format), not in control flow. *)
|
||||||
let batchable_helpers = [
|
let batchable_helpers = ref [
|
||||||
"highlight"; "component-source"
|
"highlight"; "component-source"
|
||||||
]
|
]
|
||||||
|
|
||||||
let is_batchable name args =
|
let is_batchable name args =
|
||||||
name = "helper" &&
|
name = "helper" &&
|
||||||
match args with
|
match args with
|
||||||
| String h :: _ -> List.mem h batchable_helpers
|
| String h :: _ -> List.mem h !batchable_helpers
|
||||||
| _ -> false
|
| _ -> false
|
||||||
|
|
||||||
(** Read an io-response from stdin, discarding stale messages from old epochs. *)
|
(** 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 = 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
|
let page_ast = if page_ast = Nil then error_page_ast "Page returned empty content" else page_ast in
|
||||||
begin
|
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
|
if is_ajax then begin
|
||||||
(* AJAX: return SX wire format (aser output) with text/sx content type *)
|
(* AJAX: return SX wire format (aser output) with text/sx content type *)
|
||||||
let body_result =
|
let body_result =
|
||||||
@@ -1628,7 +1648,8 @@ let http_render_page env path headers =
|
|||||||
Some body_str
|
Some body_str
|
||||||
end else begin
|
end else begin
|
||||||
(* Full page: aser → SSR → shell *)
|
(* 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 page_source = serialize_value full_ast in
|
||||||
let t1 = Unix.gettimeofday () in
|
let t1 = Unix.gettimeofday () in
|
||||||
let body_result =
|
let body_result =
|
||||||
@@ -1650,7 +1671,7 @@ let http_render_page env path headers =
|
|||||||
let t3 = Unix.gettimeofday () in
|
let t3 = Unix.gettimeofday () in
|
||||||
let get_shell name = try env_get env ("__shell-" ^ name) with _ -> Nil in
|
let get_shell name = try env_get env ("__shell-" ^ name) with _ -> Nil in
|
||||||
let shell_args = [
|
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 "page-sx"; String page_source;
|
||||||
Keyword "body-html"; String body_html;
|
Keyword "body-html"; String body_html;
|
||||||
Keyword "component-defs"; get_shell "component-defs";
|
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 "init-sx"; get_shell "init-sx";
|
||||||
Keyword "meta-html"; String "";
|
Keyword "meta-html"; String "";
|
||||||
] in
|
] 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 =
|
let html =
|
||||||
if env_has env "render-to-html" then
|
if env_has env "render-to-html" then
|
||||||
let render_call = List [Symbol "render-to-html";
|
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 ->
|
let project_dir = try Sys.getenv "SX_PROJECT_DIR" with Not_found ->
|
||||||
Filename.dirname (Filename.dirname static_dir) in
|
Filename.dirname (Filename.dirname static_dir) in
|
||||||
let templates_dir = project_dir ^ "/shared/sx/templates" in
|
let templates_dir = project_dir ^ "/shared/sx/templates" in
|
||||||
let client_libs = [
|
let client_lib_names = get_app_list "client-libs" ["tw-layout.sx"; "tw-type.sx"; "tw.sx"] in
|
||||||
templates_dir ^ "/tw-layout.sx";
|
let client_libs = List.map (fun name -> templates_dir ^ "/" ^ name) client_lib_names in
|
||||||
templates_dir ^ "/tw-type.sx";
|
|
||||||
templates_dir ^ "/tw.sx";
|
|
||||||
] in
|
|
||||||
List.iter (fun path ->
|
List.iter (fun path ->
|
||||||
if Sys.file_exists path then begin
|
if Sys.file_exists path then begin
|
||||||
let src = In_channel.with_open_text path In_channel.input_all in
|
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 platform_hash = file_hash (static_dir ^ "/wasm/sx-platform-2.js") in
|
||||||
let sxbc_hash = sxbc_combined_hash (static_dir ^ "/wasm") in
|
let sxbc_hash = sxbc_combined_hash (static_dir ^ "/wasm") in
|
||||||
(* Read CSS for inline injection *)
|
(* Read CSS for inline injection *)
|
||||||
let tw_css = read_css_file (static_dir ^ "/styles/tw.css") in
|
let css_file_names = get_app_list "css-files" ["basics.css"; "tw.css"] in
|
||||||
let basics_css = read_css_file (static_dir ^ "/styles/basics.css") in
|
let sx_css = String.concat "\n" (List.map (fun name ->
|
||||||
let sx_css = basics_css ^ "\n" ^ tw_css in
|
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-defs" (String component_defs));
|
||||||
ignore (env_bind env "__shell-component-hash" (String component_hash));
|
ignore (env_bind env "__shell-component-hash" (String component_hash));
|
||||||
(* Build minimal pages-sx from defpage definitions in loaded .sx files.
|
(* 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
|
| Some v -> serialize_value v | _ -> "" in
|
||||||
let has_data = match extract_kw "data" rest with
|
let has_data = match extract_kw "data" rest with
|
||||||
| Some _ -> true | None -> false in
|
| 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
|
Buffer.add_string pages_buf
|
||||||
(Printf.sprintf "{:name \"%s\" :path \"%s\" :auth \"public\" :has-data %s :content \"%s\"}\n"
|
(Printf.sprintf "{:name \"%s\" :path \"%s\" :auth \"public\" :has-data %s :content \"%s\"}\n"
|
||||||
name path_val (if has_data then "true" else "false")
|
name path_val (if has_data then "true" else "false")
|
||||||
(escape_sx_string content_val))
|
(escape_sx_string content_val))
|
||||||
|
end
|
||||||
| _ -> ()
|
| _ -> ()
|
||||||
) exprs
|
) exprs
|
||||||
with _ -> ()
|
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-sxbc-hash" (String sxbc_hash));
|
||||||
ignore (env_bind env "__shell-inline-css" Nil);
|
ignore (env_bind env "__shell-inline-css" Nil);
|
||||||
ignore (env_bind env "__shell-inline-head-js" Nil);
|
ignore (env_bind env "__shell-inline-head-js" Nil);
|
||||||
(* init-sx: trigger client-side render when sx-root is empty (SSR failed).
|
(* 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.
|
let default_init_sx =
|
||||||
This script forces a render from page-sx after boot completes. *)
|
|
||||||
ignore (env_bind env "__shell-init-sx" (String
|
|
||||||
"document.addEventListener('sx:boot-done', function() { \
|
"document.addEventListener('sx:boot-done', function() { \
|
||||||
var root = document.getElementById('sx-root'); \
|
var root = document.getElementById('sx-root'); \
|
||||||
if (root && !root.innerHTML.trim() && typeof SX !== 'undefined' && SX.renderPage) { \
|
if (root && !root.innerHTML.trim() && typeof SX !== 'undefined' && SX.renderPage) { \
|
||||||
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%!"
|
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
|
(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"))
|
with _ -> String (";; component " ^ name ^ " not found"))
|
||||||
| _ -> raise (Eval_error "component-source: expected (name)"));
|
| _ -> raise (Eval_error "component-source: expected (name)"));
|
||||||
|
|
||||||
(* Stub remaining demo/action helpers that need real IO *)
|
ignore bind (* suppress unused warning *)
|
||||||
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"
|
|
||||||
|
|
||||||
let http_mode port =
|
let http_mode port =
|
||||||
let env = make_server_env () in
|
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 ->
|
let shared_sx = try Sys.getenv "SX_SHARED_DIR" with Not_found ->
|
||||||
project_dir ^ "/shared/sx/templates" in
|
project_dir ^ "/shared/sx/templates" in
|
||||||
let sx_sx = try Sys.getenv "SX_COMPONENTS_DIR" with Not_found ->
|
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 docker_path = project_dir ^ "/sx" in
|
||||||
let dev_path = project_dir ^ "/sx/sx" in
|
let dev_path = project_dir ^ "/sx/sx" in
|
||||||
if Sys.file_exists (docker_path ^ "/page-functions.sx") then docker_path
|
if Sys.file_exists docker_path && Sys.is_directory docker_path
|
||||||
else dev_path in
|
&& 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 *)
|
(* Expose project paths to SX helpers *)
|
||||||
ignore (env_bind env "_project-dir" (String project_dir));
|
ignore (env_bind env "_project-dir" (String project_dir));
|
||||||
ignore (env_bind env "_spec-dir" (String spec_base));
|
ignore (env_bind env "_spec-dir" (String spec_base));
|
||||||
@@ -2387,6 +2404,15 @@ let http_mode port =
|
|||||||
load_dir sx_sx;
|
load_dir sx_sx;
|
||||||
let t1 = Unix.gettimeofday () in
|
let t1 = Unix.gettimeofday () in
|
||||||
Printf.eprintf "[sx-http] All files loaded in %.3fs\n%!" (t1 -. t0);
|
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.
|
(* SSR overrides — rebind browser-only functions AFTER .sx files load.
|
||||||
effect and register-in-scope are no-ops on the server; the SX definitions
|
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. *)
|
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
|
Printf.eprintf "[cache] %s → not found\n%!" path
|
||||||
in
|
in
|
||||||
|
|
||||||
(* Pre-warm + cache all key pages *)
|
(* Pre-warm + cache key pages — from config or just homepage *)
|
||||||
let _warmup_paths = ["/sx/"; "/sx/(geography)"; "/sx/(language)"; "/sx/(applications)";
|
let warmup_paths = match get_app_config "warmup-paths" (Keyword "auto") with
|
||||||
"/sx/(geography.(reactive.(examples)))";
|
| Keyword "auto" -> [get_app_str "path-prefix" "/sx/"]
|
||||||
"/sx/(applications.(sxtp))"; "/sx/(geography.(cek))";
|
| List l | ListRef { contents = l } ->
|
||||||
"/sx/(geography.(reactive))"; "/sx/(geography.(hypermedia))";
|
List.filter_map (function String s -> Some s | _ -> None) l
|
||||||
] in
|
| _ -> [get_app_str "path-prefix" "/sx/"]
|
||||||
|
in
|
||||||
let t_warm = Unix.gettimeofday () 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
|
let n_cached = Hashtbl.length response_cache in
|
||||||
Printf.eprintf "[sx-http] Pre-warmed %d pages in %.3fs\n%!"
|
Printf.eprintf "[sx-http] Pre-warmed %d pages in %.3fs\n%!"
|
||||||
n_cached (Unix.gettimeofday () -. t_warm);
|
n_cached (Unix.gettimeofday () -. t_warm);
|
||||||
@@ -2619,13 +2646,21 @@ let http_mode port =
|
|||||||
| None -> ())
|
| None -> ())
|
||||||
) (String.split_on_char ';' cookie_str)
|
) (String.split_on_char ';' cookie_str)
|
||||||
| None -> ());
|
| 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
|
if path = "/" then begin
|
||||||
write_response fd (http_redirect "/sx/"); true
|
write_response fd (http_redirect app_home); true
|
||||||
end else
|
end else
|
||||||
(* Debug endpoint — runs on main thread, no render worker *)
|
(* Debug endpoint — runs on main thread, no render worker *)
|
||||||
let raw_decoded = url_decode raw_path in
|
let raw_decoded = url_decode raw_path in
|
||||||
if String.length path > 11 && String.sub path 0 11 = "/sx/_debug/" then begin
|
if String.length path > debug_prefix_len
|
||||||
let cmd = String.sub raw_decoded 11 (String.length raw_decoded - 11) in
|
&& 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 query_start = try String.index cmd '?' with Not_found -> String.length cmd in
|
||||||
let action = String.sub cmd 0 query_start in
|
let action = String.sub cmd 0 query_start in
|
||||||
let query = if query_start < String.length cmd - 1
|
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 if String.sub s i (String.length sub) = sub then true
|
||||||
else has_sub s sub (i + 1) in
|
else has_sub s sub (i + 1) in
|
||||||
has_sub path "(api." 0 in
|
has_sub path "(api." 0 in
|
||||||
let is_sx = path = "/sx/" || path = "/sx"
|
let app_prefix_len = String.length app_prefix in
|
||||||
|| (String.length path > 4 && String.sub path 0 4 = "/sx/") 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
|
if is_sx && is_handler_path then begin
|
||||||
(* Handler dispatch — slug + path param extraction, method-based lookup, param binding *)
|
(* Handler dispatch — slug + path param extraction, method-based lookup, param binding *)
|
||||||
let response =
|
let response =
|
||||||
@@ -2706,8 +2743,9 @@ let http_mode port =
|
|||||||
let req_method = String.uppercase_ascii !_req_method in
|
let req_method = String.uppercase_ascii !_req_method in
|
||||||
let try_key k = try let v = env_get env k 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
|
if v <> Nil then Some (k, v) else None with _ -> None in
|
||||||
(* Try multiple handler name patterns: ex-slug, reactive-slug, slug *)
|
let handler_prefix_list = get_app_list "handler-prefixes"
|
||||||
let prefixes = ["handler:ex-" ^ slug; "handler:reactive-" ^ slug; "handler:" ^ slug] in
|
["handler:ex-"; "handler:reactive-"; "handler:"] in
|
||||||
|
let prefixes = List.map (fun p -> p ^ slug) handler_prefix_list in
|
||||||
let suffixes = match req_method with
|
let suffixes = match req_method with
|
||||||
| "POST" -> List.concat_map (fun base -> [base; base ^ "-save"; base ^ "-submit"]) prefixes
|
| "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
|
| "PUT" | "PATCH" -> List.concat_map (fun base -> [base; base ^ "-put"; base ^ "-save"]) prefixes
|
||||||
@@ -2763,10 +2801,7 @@ let http_mode port =
|
|||||||
in
|
in
|
||||||
write_response fd response; true
|
write_response fd response; true
|
||||||
end else if is_sx then begin
|
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 path 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
|
|
||||||
match Hashtbl.find_opt response_cache cache_key with
|
match Hashtbl.find_opt response_cache cache_key with
|
||||||
| Some cached -> write_response fd cached; true
|
| Some cached -> write_response fd cached; true
|
||||||
| None ->
|
| None ->
|
||||||
|
|||||||
1
sx/sx/app-config.sx
Normal file
1
sx/sx/app-config.sx
Normal file
@@ -0,0 +1 @@
|
|||||||
|
(define __app-config {:handler-prefixes (list "handler:ex-" "handler:reactive-" "handler:") :shell "~shared:shell/sx-page-shell" :inner-layout "~layouts/doc" :outer-layout "~shared:layout/app-body" :css-files (list "basics.css" "tw.css") :warmup-paths (list "/sx/" "/sx/(geography)" "/sx/(language)" "/sx/(applications)" "/sx/(geography.(reactive.(examples)))" "/sx/(applications.(sxtp))" "/sx/(geography.(cek))" "/sx/(geography.(reactive))" "/sx/(geography.(hypermedia))") :batchable-helpers (list "highlight" "component-source") :title "SX" :init-script :default :home-path "/sx/" :path-prefix "/sx/" :client-libs (list "tw-layout.sx" "tw-type.sx" "tw.sx")})
|
||||||
255
tests/test_server_config.sh
Executable file
255
tests/test_server_config.sh
Executable file
@@ -0,0 +1,255 @@
|
|||||||
|
#!/usr/bin/env bash
|
||||||
|
# Test suite for SX HTTP server app config handling.
|
||||||
|
# Starts the server with different __app-config values and verifies behavior.
|
||||||
|
set -euo pipefail
|
||||||
|
|
||||||
|
cd "$(dirname "$0")/.."
|
||||||
|
PROJECT_DIR="$(pwd)"
|
||||||
|
SERVER="hosts/ocaml/_build/default/bin/sx_server.exe"
|
||||||
|
BASE_PORT=8090
|
||||||
|
PASS=0
|
||||||
|
FAIL=0
|
||||||
|
ERRORS=""
|
||||||
|
SERVER_PID=""
|
||||||
|
CURRENT_PORT=""
|
||||||
|
|
||||||
|
# ── Helpers ──────────────────────────────────────────────────────────
|
||||||
|
|
||||||
|
TMP_DIR=$(mktemp -d)
|
||||||
|
|
||||||
|
cleanup() {
|
||||||
|
if [ -n "${SERVER_PID:-}" ] && kill -0 "$SERVER_PID" 2>/dev/null; then
|
||||||
|
kill "$SERVER_PID" 2>/dev/null
|
||||||
|
wait "$SERVER_PID" 2>/dev/null || true
|
||||||
|
fi
|
||||||
|
rm -rf "$TMP_DIR"
|
||||||
|
}
|
||||||
|
trap cleanup EXIT
|
||||||
|
|
||||||
|
start_server() {
|
||||||
|
local port="$1"
|
||||||
|
local extra_env="${2:-}"
|
||||||
|
CURRENT_PORT="$port"
|
||||||
|
# Kill anything on this port
|
||||||
|
kill $(lsof -ti :"$port") 2>/dev/null || true
|
||||||
|
sleep 1
|
||||||
|
# Start server
|
||||||
|
eval "$extra_env SX_PROJECT_DIR=$PROJECT_DIR $SERVER --http $port" \
|
||||||
|
> "$TMP_DIR/stdout" 2> "$TMP_DIR/stderr" &
|
||||||
|
SERVER_PID=$!
|
||||||
|
# Wait for "Listening" message
|
||||||
|
local tries=0
|
||||||
|
while ! grep -q "Listening" "$TMP_DIR/stderr" 2>/dev/null; do
|
||||||
|
sleep 1
|
||||||
|
tries=$((tries + 1))
|
||||||
|
if [ $tries -gt 120 ]; then
|
||||||
|
echo "TIMEOUT waiting for server on port $port"
|
||||||
|
cat "$TMP_DIR/stderr"
|
||||||
|
return 1
|
||||||
|
fi
|
||||||
|
if ! kill -0 "$SERVER_PID" 2>/dev/null; then
|
||||||
|
echo "Server died during startup on port $port"
|
||||||
|
cat "$TMP_DIR/stderr"
|
||||||
|
return 1
|
||||||
|
fi
|
||||||
|
done
|
||||||
|
echo " (server ready on port $port)"
|
||||||
|
}
|
||||||
|
|
||||||
|
stop_server() {
|
||||||
|
if [ -n "${SERVER_PID:-}" ] && kill -0 "$SERVER_PID" 2>/dev/null; then
|
||||||
|
kill "$SERVER_PID" 2>/dev/null
|
||||||
|
wait "$SERVER_PID" 2>/dev/null || true
|
||||||
|
sleep 1
|
||||||
|
fi
|
||||||
|
SERVER_PID=""
|
||||||
|
}
|
||||||
|
|
||||||
|
url() { echo "http://localhost:$CURRENT_PORT$1"; }
|
||||||
|
|
||||||
|
assert_status() {
|
||||||
|
local desc="$1" path="$2" expected="$3"
|
||||||
|
shift 3
|
||||||
|
local actual
|
||||||
|
actual=$(curl -s -o /dev/null -w "%{http_code}" "$@" "$(url "$path")" 2>/dev/null)
|
||||||
|
if [ "$actual" = "$expected" ]; then
|
||||||
|
PASS=$((PASS + 1))
|
||||||
|
echo " PASS: $desc"
|
||||||
|
else
|
||||||
|
FAIL=$((FAIL + 1))
|
||||||
|
ERRORS="$ERRORS\n FAIL: $desc — expected $expected, got $actual"
|
||||||
|
echo " FAIL: $desc — expected $expected, got $actual"
|
||||||
|
fi
|
||||||
|
}
|
||||||
|
|
||||||
|
assert_redirect() {
|
||||||
|
local desc="$1" path="$2" expected_path="$3"
|
||||||
|
local actual
|
||||||
|
actual=$(curl -s -o /dev/null -w "%{redirect_url}" "$(url "$path")" 2>/dev/null)
|
||||||
|
local expected="http://localhost:$CURRENT_PORT$expected_path"
|
||||||
|
if [ "$actual" = "$expected" ]; then
|
||||||
|
PASS=$((PASS + 1))
|
||||||
|
echo " PASS: $desc"
|
||||||
|
else
|
||||||
|
FAIL=$((FAIL + 1))
|
||||||
|
ERRORS="$ERRORS\n FAIL: $desc — expected → $expected, got → $actual"
|
||||||
|
echo " FAIL: $desc — expected → $expected_path, got → $actual"
|
||||||
|
fi
|
||||||
|
}
|
||||||
|
|
||||||
|
assert_body_contains() {
|
||||||
|
local desc="$1" path="$2" expected="$3"
|
||||||
|
shift 3
|
||||||
|
curl -s "$@" "$(url "$path")" > "$TMP_DIR/body" 2>/dev/null
|
||||||
|
if grep -qF "$expected" "$TMP_DIR/body"; then
|
||||||
|
PASS=$((PASS + 1))
|
||||||
|
echo " PASS: $desc"
|
||||||
|
else
|
||||||
|
FAIL=$((FAIL + 1))
|
||||||
|
local size=$(wc -c < "$TMP_DIR/body")
|
||||||
|
ERRORS="$ERRORS\n FAIL: $desc — body ($size bytes) missing '$expected'"
|
||||||
|
echo " FAIL: $desc — body ($size bytes) missing '$expected'"
|
||||||
|
fi
|
||||||
|
}
|
||||||
|
|
||||||
|
assert_stderr_contains() {
|
||||||
|
local desc="$1" expected="$2"
|
||||||
|
if grep -qF "$expected" "$TMP_DIR/stderr" 2>/dev/null; then
|
||||||
|
PASS=$((PASS + 1))
|
||||||
|
echo " PASS: $desc"
|
||||||
|
else
|
||||||
|
FAIL=$((FAIL + 1))
|
||||||
|
ERRORS="$ERRORS\n FAIL: $desc — stderr missing '$expected'"
|
||||||
|
echo " FAIL: $desc — stderr missing '$expected'"
|
||||||
|
fi
|
||||||
|
}
|
||||||
|
|
||||||
|
assert_stderr_not_contains() {
|
||||||
|
local desc="$1" expected="$2"
|
||||||
|
if grep -qF "$expected" "$TMP_DIR/stderr" 2>/dev/null; then
|
||||||
|
FAIL=$((FAIL + 1))
|
||||||
|
ERRORS="$ERRORS\n FAIL: $desc — stderr should NOT contain '$expected'"
|
||||||
|
echo " FAIL: $desc — stderr should NOT contain '$expected'"
|
||||||
|
else
|
||||||
|
PASS=$((PASS + 1))
|
||||||
|
echo " PASS: $desc"
|
||||||
|
fi
|
||||||
|
}
|
||||||
|
|
||||||
|
# ── Setup ────────────────────────────────────────────────────────────
|
||||||
|
|
||||||
|
if [ ! -x "$SERVER" ]; then
|
||||||
|
echo "ERROR: Server binary not found at $SERVER"
|
||||||
|
echo "Run: cd hosts/ocaml && eval \$(opam env) && dune build"
|
||||||
|
exit 1
|
||||||
|
fi
|
||||||
|
|
||||||
|
echo "=== SX HTTP Server Config Tests ==="
|
||||||
|
echo ""
|
||||||
|
|
||||||
|
# ── Test Group 1: Default config (standard app-config.sx) ───────────
|
||||||
|
|
||||||
|
echo "── Group 1: Standard config ──"
|
||||||
|
start_server $((BASE_PORT + 1))
|
||||||
|
|
||||||
|
assert_stderr_contains "config loaded" "App config loaded: title=SX prefix=/sx/"
|
||||||
|
assert_stderr_contains "warmup ran 9 pages" "Pre-warmed 9 pages"
|
||||||
|
assert_stderr_not_contains "no stepper cookie refs" "sx-home-stepper"
|
||||||
|
|
||||||
|
assert_status "homepage 200" "/sx/" 200
|
||||||
|
assert_status "AJAX homepage 200" "/sx/" 200 -H "sx-request: true"
|
||||||
|
assert_status "geography 200" "/sx/(geography)" 200
|
||||||
|
assert_status "language 200" "/sx/(language)" 200
|
||||||
|
assert_status "applications 200" "/sx/(applications)" 200
|
||||||
|
assert_redirect "root → /sx/" "/" "/sx/"
|
||||||
|
assert_status "handler 200" "/sx/(api.spec-detail)?name=render-to-html" 200
|
||||||
|
assert_status "static 200" "/static/styles/tw.css" 200
|
||||||
|
assert_status "debug 200" "/sx/_debug/eval?expr=(%2B%201%202)" 200
|
||||||
|
assert_status "unknown 404" "/nope" 404
|
||||||
|
|
||||||
|
assert_body_contains "title is SX" "/sx/" "<title>SX</title>"
|
||||||
|
assert_body_contains "AJAX returns SX wire format" "/sx/" "sx-swap-oob" -H "sx-request: true"
|
||||||
|
assert_body_contains "debug eval result" "/sx/_debug/eval?expr=(%2B%201%202)" "3"
|
||||||
|
|
||||||
|
stop_server
|
||||||
|
echo ""
|
||||||
|
|
||||||
|
# ── Test Group 2: Custom title + minimal warmup ─────────────────────
|
||||||
|
|
||||||
|
echo "── Group 2: Custom title ──"
|
||||||
|
mkdir -p "$TMP_DIR/custom-sx"
|
||||||
|
cp -r "$PROJECT_DIR/sx/sx/"* "$TMP_DIR/custom-sx/"
|
||||||
|
cat > "$TMP_DIR/custom-sx/app-config.sx" << 'SXEOF'
|
||||||
|
(define __app-config
|
||||||
|
{:title "My Custom App"
|
||||||
|
:path-prefix "/sx/"
|
||||||
|
:home-path "/sx/"
|
||||||
|
:inner-layout "~layouts/doc"
|
||||||
|
:outer-layout "~shared:layout/app-body"
|
||||||
|
:shell "~shared:shell/sx-page-shell"
|
||||||
|
:client-libs (list "tw-layout.sx" "tw-type.sx" "tw.sx")
|
||||||
|
:css-files (list "basics.css" "tw.css")
|
||||||
|
:batchable-helpers (list "highlight" "component-source")
|
||||||
|
:handler-prefixes (list "handler:ex-" "handler:reactive-" "handler:")
|
||||||
|
:warmup-paths (list "/sx/")
|
||||||
|
:init-script :default})
|
||||||
|
SXEOF
|
||||||
|
|
||||||
|
start_server $((BASE_PORT + 2)) "SX_COMPONENTS_DIR=$TMP_DIR/custom-sx"
|
||||||
|
|
||||||
|
assert_stderr_contains "custom title in log" "App config loaded: title=My Custom App"
|
||||||
|
assert_stderr_contains "warmup 1 page" "Pre-warmed 1 pages"
|
||||||
|
assert_status "homepage works" "/sx/" 200
|
||||||
|
assert_body_contains "custom title in HTML" "/sx/" "<title>My Custom App</title>"
|
||||||
|
|
||||||
|
stop_server
|
||||||
|
echo ""
|
||||||
|
|
||||||
|
# ── Test Group 3: No config (missing __app-config) ──────────────────
|
||||||
|
|
||||||
|
echo "── Group 3: No app config (defaults) ──"
|
||||||
|
mkdir -p "$TMP_DIR/noconfig-sx"
|
||||||
|
cp -r "$PROJECT_DIR/sx/sx/"* "$TMP_DIR/noconfig-sx/"
|
||||||
|
rm -f "$TMP_DIR/noconfig-sx/app-config.sx"
|
||||||
|
|
||||||
|
start_server $((BASE_PORT + 3)) "SX_COMPONENTS_DIR=$TMP_DIR/noconfig-sx"
|
||||||
|
|
||||||
|
assert_stderr_contains "defaults fallback" "No __app-config found, using defaults"
|
||||||
|
assert_status "homepage without config" "/sx/" 200
|
||||||
|
assert_redirect "root redirect without config" "/" "/sx/"
|
||||||
|
assert_body_contains "default title" "/sx/" "<title>SX</title>"
|
||||||
|
|
||||||
|
stop_server
|
||||||
|
echo ""
|
||||||
|
|
||||||
|
# ── Test Group 4: Minimal config (only title) ───────────────────────
|
||||||
|
|
||||||
|
echo "── Group 4: Minimal config ──"
|
||||||
|
mkdir -p "$TMP_DIR/minimal-sx"
|
||||||
|
cp -r "$PROJECT_DIR/sx/sx/"* "$TMP_DIR/minimal-sx/"
|
||||||
|
cat > "$TMP_DIR/minimal-sx/app-config.sx" << 'SXEOF'
|
||||||
|
(define __app-config {:title "Bare"})
|
||||||
|
SXEOF
|
||||||
|
|
||||||
|
start_server $((BASE_PORT + 4)) "SX_COMPONENTS_DIR=$TMP_DIR/minimal-sx"
|
||||||
|
|
||||||
|
assert_stderr_contains "minimal config log" "App config loaded: title=Bare"
|
||||||
|
assert_status "homepage with minimal config" "/sx/" 200
|
||||||
|
assert_body_contains "bare title" "/sx/" "<title>Bare</title>"
|
||||||
|
# Defaults should still work for everything not specified
|
||||||
|
assert_redirect "default redirect" "/" "/sx/"
|
||||||
|
assert_status "default debug" "/sx/_debug/eval?expr=1" 200
|
||||||
|
|
||||||
|
stop_server
|
||||||
|
echo ""
|
||||||
|
|
||||||
|
# ── Summary ──────────────────────────────────────────────────────────
|
||||||
|
|
||||||
|
echo "=== Results: $PASS passed, $FAIL failed ==="
|
||||||
|
if [ $FAIL -gt 0 ]; then
|
||||||
|
echo -e "\nFailures:$ERRORS"
|
||||||
|
exit 1
|
||||||
|
else
|
||||||
|
echo "All tests passed."
|
||||||
|
exit 0
|
||||||
|
fi
|
||||||
@@ -2,14 +2,18 @@
|
|||||||
sx-url-to-expr
|
sx-url-to-expr
|
||||||
(fn
|
(fn
|
||||||
(path)
|
(path)
|
||||||
(cond
|
(let
|
||||||
(or (= path "/") (= path "/sx/") (= path "/sx"))
|
((prefix (cek-try (fn () (or (dict-get __app-config :path-prefix) "/sx/")) (fn (e) "/sx/")))
|
||||||
"home"
|
(prefix-len (len prefix))
|
||||||
(starts-with? path "/sx/")
|
(prefix-bare (slice prefix 0 (- prefix-len 1))))
|
||||||
(join " " (split (slice path 4 (len path)) "."))
|
(cond
|
||||||
(starts-with? path "/")
|
(or (= path "/") (= path prefix) (= path prefix-bare))
|
||||||
(join " " (split (slice path 1 (len path)) "."))
|
"home"
|
||||||
:else path)))
|
(starts-with? path prefix)
|
||||||
|
(join " " (split (slice path prefix-len (len path)) "."))
|
||||||
|
(starts-with? path "/")
|
||||||
|
(join " " (split (slice path 1 (len path)) "."))
|
||||||
|
:else path))))
|
||||||
|
|
||||||
(define
|
(define
|
||||||
sx-auto-quote
|
sx-auto-quote
|
||||||
@@ -52,5 +56,13 @@
|
|||||||
(nil? page-ast)
|
(nil? page-ast)
|
||||||
nil
|
nil
|
||||||
(let
|
(let
|
||||||
((nav-path (if (and (>= (len path) 4) (= (slice path 0 4) "/sx/")) path (str "/sx" path))))
|
((prefix (cek-try (fn () (or (dict-get __app-config :path-prefix) "/sx/")) (fn (e) "/sx/")))
|
||||||
|
(prefix-len (len prefix))
|
||||||
|
(nav-path
|
||||||
|
(if
|
||||||
|
(and
|
||||||
|
(>= (len path) prefix-len)
|
||||||
|
(= (slice path 0 prefix-len) prefix))
|
||||||
|
path
|
||||||
|
(str (slice prefix 0 (- prefix-len 1)) path))))
|
||||||
{:page-ast page-ast :nav-path nav-path :is-ajax is-ajax})))))
|
{:page-ast page-ast :nav-path nav-path :is-ajax is-ajax})))))
|
||||||
|
|||||||
Reference in New Issue
Block a user