diff --git a/hosts/ocaml/bin/sx_server.ml b/hosts/ocaml/bin/sx_server.ml index 18997bbd..b3010d19 100644 --- a/hosts/ocaml/bin/sx_server.ml +++ b/hosts/ocaml/bin/sx_server.ml @@ -692,6 +692,37 @@ let make_server_env () = setup_io_bridges env; setup_html_tags env; setup_io_env env; + (* defhandler — native special form. Called by CEK as (handler [raw-args; Env eval-env]). + Registers handler as handler:name in the eval env. *) + ignore (Sx_ref.register_special_form (String "defhandler") (NativeFn ("defhandler", fun sf_args -> + (* Custom special forms receive [List args; Env eval_env] *) + let raw_args, eval_env = match sf_args with + | [List a; Env e] | [ListRef { contents = a }; Env e] -> (a, e) + | _ -> ([], env) in + match raw_args with + | name_sym :: rest -> + let name = match name_sym with Symbol s -> s | String s -> s | _ -> Sx_types.inspect name_sym in + let rec parse_opts acc = function + | Keyword k :: v :: rest -> Hashtbl.replace acc k v; parse_opts acc rest + | rest -> (acc, rest) in + let opts = Hashtbl.create 4 in + let (_, remaining) = parse_opts opts rest in + let params, body = match remaining with + | List p :: b :: _ -> (p, b) | List p :: [] -> (p, Nil) | _ -> ([], Nil) in + let hdef = Hashtbl.create 8 in + Hashtbl.replace hdef "__type" (String "handler"); + Hashtbl.replace hdef "name" (String name); + Hashtbl.replace hdef "params" (List params); + Hashtbl.replace hdef "body" body; + Hashtbl.replace hdef "closure" (Env eval_env); + Hashtbl.replace hdef "method" (match Hashtbl.find_opt opts "method" with + | Some (Keyword m) -> String m | Some v -> v | None -> String "get"); + Hashtbl.replace hdef "path" (match Hashtbl.find_opt opts "path" with Some v -> v | None -> Nil); + Hashtbl.replace hdef "csrf" (match Hashtbl.find_opt opts "csrf" with Some v -> v | None -> Bool true); + Hashtbl.replace hdef "returns" (match Hashtbl.find_opt opts "returns" with Some v -> v | None -> String "element"); + ignore (env_bind eval_env ("handler:" ^ name) (Dict hdef)); + Dict hdef + | _ -> Nil))); (* Initialize trampoline ref so HO primitives (map, filter, etc.) can call SX lambdas. Must be done here because Sx_ref is only available at the binary level, not in the library. *) @@ -1840,7 +1871,48 @@ let http_setup_declarative_stubs env = noop "define-primitive"; noop "deftype"; noop "defeffect"; - noop "define-page-helper" + noop "define-page-helper"; + (* defhandler — register as native special form so it works without web-forms.sx. + Parses the handler args and stores as handler:name in the env. *) + ignore (Sx_ref.register_special_form (String "defhandler") (NativeFn ("defhandler", fun args -> + match args with + | name_sym :: rest -> + let name = match name_sym with Symbol s -> s | String s -> s | _ -> Sx_types.inspect name_sym in + (* Parse keyword opts and find params/body *) + let rec parse_opts acc = function + | Keyword k :: v :: rest -> Hashtbl.replace acc k v; parse_opts acc rest + | rest -> (acc, rest) + in + let opts = Hashtbl.create 4 in + let (_, remaining) = parse_opts opts rest in + let params, body = match remaining with + | List p :: b :: _ -> (p, b) + | List p :: [] -> (p, Nil) + | _ -> ([], Nil) + in + let hdef = Hashtbl.create 8 in + Hashtbl.replace hdef "__type" (String "handler"); + Hashtbl.replace hdef "name" (String name); + Hashtbl.replace hdef "params" (List params); + Hashtbl.replace hdef "body" body; + Hashtbl.replace hdef "closure" (Env env); + Hashtbl.replace hdef "method" (match Hashtbl.find_opt opts "method" with + | Some (Keyword m) -> String m | Some v -> v | None -> String "get"); + Hashtbl.replace hdef "path" (match Hashtbl.find_opt opts "path" with + | Some v -> v | None -> Nil); + Hashtbl.replace hdef "csrf" (match Hashtbl.find_opt opts "csrf" with + | Some v -> v | None -> Bool true); + Hashtbl.replace hdef "returns" (match Hashtbl.find_opt opts "returns" with + | Some v -> v | None -> String "element"); + let handler_key = "handler:" ^ name in + ignore (env_bind env handler_key (Dict hdef)); + Dict hdef + | _ -> Nil))); + (* Also stub defquery/defaction/defrelation/defstyle as no-ops *) + noop "defquery"; + noop "defaction"; + noop "defrelation"; + noop "defstyle" let http_setup_platform_constructors env = (* Platform constructor functions expected by evaluator.sx.