rose-ash/hosts/ocaml/bin/sx_http.ml

(** SX HTTP server — serves sx-docs directly from OCaml, no Python bridge.

    Replaces: Quart + Hypercorn + ocaml_bridge.py + sx_router.py
    Keeps:    Caddy (TLS termination, static files, reverse proxy)

    Usage:
      sx_http.exe [--port 8013] [--static /path/to/shared/static]

    Architecture:
      1. At startup: load all .sx components, pre-compute shell statics
      2. Per request: parse HTTP GET → route → eval page → render HTML
      3. No Python, no bridge, no serialization boundaries *)

open Sx_types

(* ====================================================================== *)
(* Reuse sx_server infrastructure                                          *)
(* ====================================================================== *)

(* Import make_server_env and rendering from sx_server.
   We can't directly share because OCaml doesn't support cross-executable
   linking. Instead, we duplicate the minimal setup and reuse library fns. *)

let escape_sx_string s =
  let buf = Buffer.create (String.length s + 16) in
  String.iter (function
    | '"'  -> 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;
  Buffer.contents buf

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 } ->
    "(" ^ 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
  | _ -> "nil"


(* ====================================================================== *)
(* Environment setup — mirrors make_server_env from sx_server.ml           *)
(* ====================================================================== *)

(* IO bridge stubs — sx-docs has no IO callbacks, but the evaluator
   expects these symbols to exist. We stub them to raise clear errors. *)
let setup_io_stubs env =
  let stub name =
    ignore (env_bind env name (NativeFn (name, fun _args ->
      raise (Eval_error (Printf.sprintf "IO primitive '%s' not available in sx_http" name)))))
  in
  stub "io-request";
  stub "helper";
  (* query/action/service: not needed for sx-docs *)
  stub "query";
  stub "action";
  stub "service"

let make_http_env () =
  let env = make_env () in
  Sx_render.setup_render_env env;
  (* Scope primitives — inline since Sx_scope was merged *)
  let _scope_stacks : (string, Sx_types.value list) Hashtbl.t = Hashtbl.create 8 in
  let bind name fn = ignore (Sx_types.env_bind env name (Sx_types.NativeFn (name, fn))) in
  bind "scope-push!" (fun args -> match args with
    | [String name; value] -> let s = try Hashtbl.find _scope_stacks name with Not_found -> [] in Hashtbl.replace _scope_stacks name (value :: s); Nil
    | [String name] -> let s = try Hashtbl.find _scope_stacks name with Not_found -> [] in Hashtbl.replace _scope_stacks name (Nil :: s); Nil
    | _ -> Nil);
  bind "scope-pop!" (fun args -> match args with
    | [String name] -> (match (try Hashtbl.find _scope_stacks name with Not_found -> []) with _ :: rest -> Hashtbl.replace _scope_stacks name rest | [] -> ()); Nil
    | _ -> Nil);
  bind "scope-peek" (fun args -> match args with
    | [String name] -> (match (try Hashtbl.find _scope_stacks name with Not_found -> []) with v :: _ -> v | [] -> Nil)
    | _ -> Nil);
  bind "scope-emit!" (fun args -> match args with
    | [String name; value] ->
      let key = name ^ ":emitted" in
      let s = try Hashtbl.find _scope_stacks key with Not_found -> [] in
      Hashtbl.replace _scope_stacks key (value :: s); Nil
    | _ -> Nil);
  bind "scope-emitted" (fun args -> match args with
    | [String name] ->
      let key = name ^ ":emitted" in
      let items = try Hashtbl.find _scope_stacks key with Not_found -> [] in
      Hashtbl.replace _scope_stacks key []; List (List.rev items)
    | _ -> List []);
  bind "collect!" (fun args -> match args with
    | [String name; value] ->
      let key = name ^ ":collected" in
      let s = try Hashtbl.find _scope_stacks key with Not_found -> [] in
      Hashtbl.replace _scope_stacks key (value :: s); Nil
    | _ -> Nil);
  bind "collected" (fun args -> match args with
    | [String name] ->
      let key = name ^ ":collected" in
      let items = try Hashtbl.find _scope_stacks key with Not_found -> [] in
      Hashtbl.replace _scope_stacks key []; List (List.rev items)
    | _ -> List []);
  (* Declarative form stubs — no-ops at runtime *)
  bind "define-module" (fun _args -> Nil);
  bind "define-primitive" (fun _args -> Nil);
  bind "deftype" (fun _args -> Nil);
  bind "defeffect" (fun _args -> Nil);
  bind "deftest" (fun _args -> Nil);
  bind "defstyle" (fun _args -> Nil);
  bind "defhandler" (fun _args -> Nil);
  bind "defpage" (fun _args -> Nil);
  bind "defquery" (fun _args -> Nil);
  bind "defaction" (fun _args -> Nil);
  bind "defrelation" (fun _args -> Nil);
  (* Render stubs *)
  bind "set-render-active!" (fun _args -> Nil);
  bind "render-active?" (fun _args -> Bool true);
  bind "trampoline" (fun args -> match args with
    | [Thunk (expr, e)] -> Sx_ref.eval_expr expr (Env e)
    | [v] -> v | _ -> Nil);
  (* Setup all the standard primitives *)
  (* Evaluator bridge — needed for aser, macro expansion *)
  ignore (env_bind env "eval-expr" (NativeFn ("eval-expr", fun args ->
    match args with
    | [expr; Env e] -> Sx_ref.eval_expr expr (Env e)
    | [expr] -> Sx_ref.eval_expr expr (Env env)
    | _ -> Nil)));
  ignore (env_bind env "apply" (NativeFn ("apply", fun args ->
    match args with
    | [f; List a] -> Sx_ref.cek_call f (List a)
    | _ -> Nil)));
  ignore (env_bind env "macroexpand-1" (NativeFn ("macroexpand-1", fun args ->
    match args with
    | [expr; Env e] ->
      (try Sx_ref.eval_expr (List [Symbol "macroexpand-1-impl"; List [Symbol "quote"; expr]]) (Env e)
       with _ -> expr)
    | _ -> Nil)));
  (* Trampoline for HO primitives *)
  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? = false on server *)
  ignore (env_bind env "client?" (NativeFn ("client?", fun _ -> Bool false)));
  (* IO stubs *)
  setup_io_stubs env;
  (* Component introspection *)
  ignore (env_bind env "component-name" (NativeFn ("component-name", fun args ->
    match args with [Component c] -> String c.c_name | [Island i] -> String i.i_name | _ -> Nil)));
  ignore (env_bind env "component-params" (NativeFn ("component-params", fun args ->
    match args with
    | [Component c] -> List (List.map (fun s -> Symbol s) c.c_params)
    | [Island i] -> List (List.map (fun s -> Symbol s) i.i_params)
    | _ -> Nil)));
  ignore (env_bind env "component-body" (NativeFn ("component-body", fun args ->
    match args with [Component c] -> c.c_body | [Island i] -> i.i_body | _ -> Nil)));
  ignore (env_bind env "component-has-children?" (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)));
  ignore (env_bind env "component-affinity" (NativeFn ("component-affinity", fun args ->
    match args with [Component c] -> String c.c_affinity | [Island _] -> String "client" | _ -> String "auto")));
  (* Spread attrs *)
  ignore (env_bind env "spread-attrs" (NativeFn ("spread-attrs", fun args ->
    match args with [Spread pairs] ->
      let d = Hashtbl.create 8 in
      List.iter (fun (k, v) -> Hashtbl.replace d k v) pairs; Dict d
    | _ -> Nil)));
  env


(* ====================================================================== *)
(* File loading                                                            *)
(* ====================================================================== *)

let load_file env path =
  try
    let src = In_channel.with_open_text path In_channel.input_all in
    let exprs = Sx_parser.parse_all src in
    List.iter (fun expr ->
      try ignore (Sx_ref.eval_expr expr (Env env))
      with e -> Printf.eprintf "[load] %s: %s\n%!" path (Printexc.to_string e)
    ) exprs;
    Printf.eprintf "[load] %s (%d forms)\n%!" path (List.length exprs)
  with e ->
    Printf.eprintf "[load] failed %s: %s\n%!" path (Printexc.to_string e)

let load_dir env dir pattern =
  if Sys.file_exists dir && Sys.is_directory dir then
    Array.iter (fun f ->
      if Filename.check_suffix f pattern then
        load_file env (dir ^ "/" ^ f)
    ) (Sys.readdir dir)

let load_all_components env project_dir =
  let spec = project_dir ^ "/spec" in
  let lib = project_dir ^ "/lib" in
  let web = project_dir ^ "/web" in
  let shared_sx = project_dir ^ "/shared/sx/templates" in
  let sx_sx = project_dir ^ "/sx/sx" in
  (* Core spec *)
  List.iter (fun f -> load_file env (spec ^ "/" ^ f)) [
    "parser.sx"; "primitives.sx"; "render.sx"; "evaluator.sx";
  ];
  (* Libraries *)
  load_dir env lib ".sx";
  (* Web adapters *)
  load_dir env web ".sx";
  (* Shared templates *)
  load_dir env shared_sx ".sx";
  (* SX docs components *)
  load_dir env sx_sx ".sx"


(* ====================================================================== *)
(* Shell statics — computed once at startup                                *)
(* ====================================================================== *)

type shell_static = {
  component_defs: string;
  component_hash: string;
  pages_sx: string;
  sx_css: string;
  asset_url: string;
}

let compute_shell_statics env _project_dir =
  (* Serialize all components 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
  (* Pages SX — collect defpage paths for client router *)
  (* For now, empty — client routing uses the pages script tag *)
  let pages_sx = "" in
  (* CSS — for now pass through empty, Caddy serves tw.css *)
  let sx_css = "" in
  {
    component_defs;
    component_hash;
    pages_sx;
    sx_css;
    asset_url = "/static";
  }


(* ====================================================================== *)
(* HTML rendering — same as sx_server.ml                                   *)
(* ====================================================================== *)

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


(* ====================================================================== *)
(* Page rendering — aser + SSR + shell in one pass                         *)
(* ====================================================================== *)

let render_page env statics path =
  let t0 = Unix.gettimeofday () in
  (* Build the page AST: evaluate the URL path as an SX expression *)
  let path_expr = if path = "/" || path = "" || path = "/sx/" || path = "/sx" then "home"
    else begin
      (* /sx/(geography.(reactive)) → (geography (reactive)) *)
      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
      (* Convert dots to spaces for SX URL convention *)
      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 (List.map Fun.id exprs) in
      Sx_ref.eval_expr expr (Env env)
    with e ->
      Printf.eprintf "[route] eval failed for '%s': %s\n%!" path_expr (Printexc.to_string e);
      Nil
  in
  if page_ast = Nil then None
  else begin
    (* Wrap in layout: (~layouts/doc :path "/sx/..." page_ast) *)
    let nav_path = if 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
    (* Wrap in app-body *)
    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 *)
    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"; full_ast];
                       Env env] in
      Sx_ref.eval_expr call (Env env)
    in
    Hashtbl.remove env.bindings (Sx_types.intern "expand-components?");
    let body_str = match body_result with
      | String s | SxExpr s -> s
      | _ -> serialize_value body_result
    in
    let t2 = Unix.gettimeofday () in
    (* Phase 2: SSR — render expanded SX 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 "[ssr] render-to-html failed: %s\n%!" (Printexc.to_string e);
        ""
    in
    let t3 = Unix.gettimeofday () in
    (* Phase 3: Shell — wrap in full HTML page *)
    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"; String statics.component_defs;
      Keyword "component-hash"; String statics.component_hash;
      Keyword "pages-sx"; String statics.pages_sx;
      Keyword "sx-css"; String statics.sx_css;
      Keyword "sx-css-classes"; String "";
      Keyword "asset-url"; String statics.asset_url;
      Keyword "sx-js-hash"; String "";
      Keyword "body-js-hash"; String "";
      Keyword "wasm-hash"; String "";
      Keyword "head-scripts"; Nil;
      Keyword "body-scripts"; Nil;
      Keyword "inline-css"; Nil;
      Keyword "inline-head-js"; Nil;
      Keyword "init-sx"; Nil;
      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


(* ====================================================================== *)
(* HTTP server                                                             *)
(* ====================================================================== *)

let http_response ?(status=200) ?(content_type="text/html; charset=utf-8") body =
  let status_text = match status with
    | 200 -> "OK" | 404 -> "Not Found" | 500 -> "Internal Server Error"
    | _ -> "Unknown"
  in
  Printf.sprintf "HTTP/1.1 %d %s\r\nContent-Type: %s\r\nContent-Length: %d\r\nConnection: keep-alive\r\n\r\n%s"
    status status_text content_type (String.length body) body

let parse_request data =
  (* Extract method and path from "GET /path HTTP/1.1\r\n..." *)
  match String.split_on_char ' ' (String.trim (
    match String.index_opt data '\r' with
    | Some i -> String.sub data 0 i
    | None -> match String.index_opt data '\n' with
      | Some i -> String.sub data 0 i
      | None -> data
  )) with
  | method_ :: path :: _ -> Some (method_, path)
  | _ -> None

let handle_request env statics data =
  match parse_request data with
  | None -> http_response ~status:400 "Bad Request"
  | Some (method_, path) ->
    if method_ <> "GET" then
      http_response ~status:405 "Method Not Allowed"
    else begin
      let decoded = try
        let b = Buffer.create (String.length path) in
        let i = ref 0 in
        while !i < String.length path do
          if path.[!i] = '%' && !i + 2 < String.length path then begin
            let hex = String.sub path (!i + 1) 2 in
            Buffer.add_char b (Char.chr (int_of_string ("0x" ^ hex)));
            i := !i + 3
          end else begin
            Buffer.add_char b path.[!i];
            i := !i + 1
          end
        done;
        Buffer.contents b
      with _ -> path
      in
      (* Route: /sx/... or / → page render *)
      let is_sx_path = String.length decoded >= 4 && String.sub decoded 0 4 = "/sx/" in
      let is_home = decoded = "/" || decoded = "/sx/" in
      if is_home || is_sx_path then
        match render_page env statics decoded with
        | Some html -> http_response html
        | None -> http_response ~status:404 "<h1>404 Not Found</h1>"
      else
        http_response ~status:404 "<h1>404 Not Found</h1>"
    end

let serve env statics port =
  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\n%!" port;
  while true do
    let (client, _addr) = Unix.accept sock in
    (* Read request — simple: read up to 8KB, enough for any GET *)
    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 handle_request env statics data
        with e ->
          Printf.eprintf "[sx-http] Error: %s\n%!" (Printexc.to_string e);
          http_response ~status:500 "<h1>500 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
      while !written < total do
        let n = Unix.write client resp_bytes !written (total - !written) in
        written := !written + n
      done
    end;
    Unix.close client
  done


(* ====================================================================== *)
(* Main                                                                    *)
(* ====================================================================== *)

let () =
  let port = ref 8014 in
  let project_dir = ref (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
  (* Parse args *)
  let args = Array.to_list Sys.argv in
  let rec parse = function
    | "--port" :: p :: rest -> port := int_of_string p; parse rest
    | "--project" :: d :: rest -> project_dir := d; parse rest
    | _ :: rest -> parse rest
    | [] -> ()
  in
  parse (List.tl args);

  Printf.eprintf "[sx-http] project_dir=%s\n%!" !project_dir;

  (* Build environment *)
  let env = make_http_env () in

  (* Load all components *)
  let t0 = Unix.gettimeofday () in
  load_all_components env !project_dir;
  let t1 = Unix.gettimeofday () in
  Printf.eprintf "[sx-http] Components loaded in %.3fs\n%!" (t1 -. t0);

  (* Compute shell statics *)
  let statics = compute_shell_statics env !project_dir in
  let t2 = Unix.gettimeofday () in
  Printf.eprintf "[sx-http] Shell statics computed in %.3fs (defs=%d hash=%s)\n%!"
    (t2 -. t1) (String.length statics.component_defs) statics.component_hash;

  (* Start HTTP server *)
  serve env statics !port