diff --git a/hosts/ocaml/bin/sx_server.ml b/hosts/ocaml/bin/sx_server.ml index 38515d8b..5fa96763 100644 --- a/hosts/ocaml/bin/sx_server.ml +++ b/hosts/ocaml/bin/sx_server.ml @@ -1923,6 +1923,47 @@ let http_load_files env files = ) 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 @@ -1977,6 +2018,116 @@ let pretty_print_value ?(max_width=80) v = 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 @@ -2357,10 +2508,16 @@ let http_mode port = match parse_http_request data with | None -> write_response fd (http_response ~status:400 "Bad Request"); true | Some (method_, raw_path) -> - if method_ <> "GET" && method_ <> "HEAD" then begin - write_response fd (http_response ~status:405 "Method Not Allowed"); true - end else begin - let path = url_decode raw_path in + 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 ""); if path = "/" then begin write_response fd (http_redirect "/sx/"); true end else diff --git a/sx/sx/handlers/dispatch.sx b/sx/sx/handlers/dispatch.sx new file mode 100644 index 00000000..b052e679 --- /dev/null +++ b/sx/sx/handlers/dispatch.sx @@ -0,0 +1,51 @@ +(define + api + (fn + (slug) + (let + ((handler-key (str "handler:ex-" slug)) (hdef (env-get handler-key))) + (if + (nil? hdef) + (div + :class "p-8" + (h2 :class "text-rose-600 font-semibold" "Handler not found") + (p :class "text-stone-500" (str "No handler: " handler-key))) + (call-handler hdef))))) + +(define + call-handler + (fn + (hdef) + (let + ((method (get hdef "method")) + (params (get hdef "params")) + (body (get hdef "body")) + (closure (get hdef "closure"))) + (let + ((req-method (request-method)) + (handler-method (upper (or method "get")))) + (if + (and + (not (= handler-method "GET")) + (not (= req-method handler-method))) + (div + :class "p-4 text-rose-600" + (str + "Method not allowed: expected " + handler-method + " got " + req-method)) + (eval-handler-body params body closure)))))) + +(define + eval-handler-body + (fn + (params body closure) + (if + (or (nil? params) (empty? params)) + (eval-expr body closure) + (let + ((bindings (map (fn (p) (let ((name (if (symbol? p) (symbol-name p) (str p)))) (if (= name "&key") nil (if (= name "&rest") nil (let ((val (or (request-arg name) (request-form name)))) (list (make-symbol name) (or val nil))))))) (filter (fn (p) (let ((name (if (symbol? p) (symbol-name p) (str p)))) (and (not (= name "&key")) (not (= name "&rest"))))) params)))) + (let + ((let-form (list (quote let) (filter (fn (b) (not (nil? b))) bindings) body))) + (eval-expr let-form closure))))))