Merge branch 'loops/host' into merge/host-arch
# Conflicts: # lib/erlang/runtime.sx
This commit is contained in:
@@ -2812,10 +2812,13 @@ let run_spec_tests env test_files =
|
||||
| "insertAdjacentHTML" | "prepend" | "showModal" | "show" | "close"
|
||||
| "getBoundingClientRect" | "getAnimations" | "scrollIntoView"
|
||||
| "scrollTo" | "scroll" | "reset" -> Bool true
|
||||
| "firstElementChild" ->
|
||||
| "firstElementChild" | "firstChild" ->
|
||||
(* the mock treats element children and child nodes alike, so
|
||||
firstChild == firstElementChild — children-to-fragment walks
|
||||
firstChild to drain a parsed fragment into a swap target. *)
|
||||
let kids = match Hashtbl.find_opt d "children" with Some (List l) -> l | _ -> [] in
|
||||
(match kids with c :: _ -> c | [] -> Nil)
|
||||
| "lastElementChild" ->
|
||||
| "lastElementChild" | "lastChild" ->
|
||||
let kids = match Hashtbl.find_opt d "children" with Some (List l) -> l | _ -> [] in
|
||||
(match List.rev kids with c :: _ -> c | [] -> Nil)
|
||||
| "nextElementSibling" | "nextSibling" ->
|
||||
@@ -2961,6 +2964,15 @@ let run_spec_tests env test_files =
|
||||
| "setTimeout" -> (match rest with fn :: _ -> ignore (Sx_ref.cek_call fn (List [])); Nil | _ -> Nil)
|
||||
| "clearTimeout" -> Nil
|
||||
| _ -> Nil)
|
||||
(* NodeList.item(i) — dom-query-all iterates the querySelectorAll result
|
||||
(a bare List) via this method, exactly like a browser NodeList. *)
|
||||
| (List _ | ListRef _) :: String "item" :: [idx] ->
|
||||
let items = match args with
|
||||
| List l :: _ -> l
|
||||
| ListRef { contents = l } :: _ -> l
|
||||
| _ -> [] in
|
||||
let i = match idx with Number n -> int_of_float n | Integer n -> n | _ -> -1 in
|
||||
if i >= 0 && i < List.length items then List.nth items i else Nil
|
||||
| Dict d :: String "hasOwnProperty" :: [String k] ->
|
||||
Bool (Hashtbl.mem d k)
|
||||
| Dict d :: String m :: rest ->
|
||||
@@ -3070,6 +3082,26 @@ let run_spec_tests env test_files =
|
||||
(* console.log/debug/error — no-op in tests *)
|
||||
Nil
|
||||
|
||||
else if mt = "domparser" then
|
||||
(* DOMParser.parseFromString(text, "text/html") — returns a mock
|
||||
document whose <body> is parsed from `text`. An empty string yields
|
||||
a valid empty document (truthy), matching the browser: that's what
|
||||
the engine's handle-html-response relies on for an empty-body
|
||||
sx-swap="delete" response. *)
|
||||
(match m with
|
||||
| "parseFromString" ->
|
||||
let text = match rest with String t :: _ -> t | _ -> "" in
|
||||
let bd = match make_mock_element "body" with Dict d -> d | _ -> Hashtbl.create 0 in
|
||||
Hashtbl.replace bd "tagName" (String "BODY");
|
||||
Hashtbl.replace bd "nodeName" (String "BODY");
|
||||
parse_html_into bd text;
|
||||
Hashtbl.replace bd "innerHTML" (String text);
|
||||
let doc = Hashtbl.create 4 in
|
||||
Hashtbl.replace doc "__mock_type" (String "document");
|
||||
Hashtbl.replace doc "body" (Dict bd);
|
||||
Dict doc
|
||||
| _ -> Nil)
|
||||
|
||||
else
|
||||
(* Element methods *)
|
||||
(match m with
|
||||
@@ -3483,6 +3515,10 @@ let run_spec_tests env test_files =
|
||||
Dict ev
|
||||
| [String "Object"] ->
|
||||
Dict (Hashtbl.create 4)
|
||||
| [String "DOMParser"] ->
|
||||
let d = Hashtbl.create 4 in
|
||||
Hashtbl.replace d "__mock_type" (String "domparser");
|
||||
Dict d
|
||||
| _ -> Nil);
|
||||
|
||||
reg "host-callback" (fun args ->
|
||||
@@ -3686,6 +3722,7 @@ let run_spec_tests env test_files =
|
||||
load_module "router.sx" web_dir;
|
||||
load_module "deps.sx" web_dir;
|
||||
load_module "orchestration.sx" web_dir;
|
||||
load_module "console-render.sx" web_dir;
|
||||
(* Library modules for lib/tests/ *)
|
||||
load_module "bytecode.sx" lib_dir;
|
||||
load_module "compiler.sx" lib_dir;
|
||||
|
||||
@@ -32,6 +32,14 @@ let () = ignore (Sx_vm_extensions.id_of_name "")
|
||||
which we swallow so a re-entered server process doesn't die. *)
|
||||
let () = try Erlang_ext.register () with Failure _ -> ()
|
||||
|
||||
(* Ignore SIGPIPE: a client that closes its connection mid-response (a browser
|
||||
aborting an in-flight fetch — the SX engine cancels superseded requests on a
|
||||
debounced filter or a fast nav) must NOT kill the server. SIGPIPE's default
|
||||
action terminates the process before any exception is raised; ignoring it
|
||||
turns the failed write into a catchable Sys_error (EPIPE), which the
|
||||
per-connection handler already swallows, dropping just that one connection. *)
|
||||
let () = try Sys.set_signal Sys.sigpipe Sys.Signal_ignore with _ -> ()
|
||||
|
||||
(* ====================================================================== *)
|
||||
(* Font measurement via otfm — reads OpenType/TrueType font tables *)
|
||||
(* ====================================================================== *)
|
||||
@@ -522,9 +530,61 @@ let rec load_library_file path =
|
||||
Printf.eprintf "[load-library] %s: %s\n%!" (Filename.basename path) msg
|
||||
) exprs
|
||||
|
||||
(** IO-aware CEK run — handles suspension by dispatching IO requests.
|
||||
Import requests are handled locally (load .sx file).
|
||||
Other IO requests are sent to the Python bridge. *)
|
||||
(* IO-aware CEK run (cek_run_with_io, below) — handles suspension by dispatching
|
||||
IO requests. Import requests are handled locally (load .sx file). *)
|
||||
(** Resolve a single IO request value to its response. Shared by
|
||||
cek_run_with_io's suspension loop AND the _cek_io_resolver installed for the
|
||||
http-listen serving path, so the synchronous inline-resolve path (sx_vm.ml's
|
||||
HO-callback suspend fix) resolves durable reads byte-identically to the
|
||||
CEK-driven path. Without an installed resolver, a `perform` inside an HO
|
||||
primitive callback (map/filter/…) unwinds the native loop and corrupts the
|
||||
stack — the host's map/rest/drop serving-JIT miscompile. *)
|
||||
and resolve_io_request request =
|
||||
let op = match Sx_runtime.get_val request (String "op") with String s -> s | _ -> "" in
|
||||
(match op with
|
||||
| "import" ->
|
||||
(* Resolve library locally — load the .sx file *)
|
||||
let lib_spec = Sx_runtime.get_val request (String "library") in
|
||||
(* library_loaded_p takes the library SPEC and computes the key itself —
|
||||
passing an already-computed key string double-applies library_name_key
|
||||
and crashes (sx_to_list on a string). *)
|
||||
if Sx_types.sx_truthy (Sx_ref.library_loaded_p lib_spec) then
|
||||
(* Already loaded — just resume *)
|
||||
Nil
|
||||
else begin
|
||||
(match resolve_library_path lib_spec with
|
||||
| Some path -> load_library_file path
|
||||
| None ->
|
||||
Printf.eprintf "[import] WARNING: no file for library %s\n%!"
|
||||
(Sx_runtime.value_to_str lib_spec));
|
||||
Nil
|
||||
end
|
||||
| "text-measure" ->
|
||||
let args = let a = Sx_runtime.get_val request (String "args") in
|
||||
(match a with List l -> l | _ -> [a]) in
|
||||
let font = match args with String f :: _ -> f | _ -> "serif" in
|
||||
let size = match args with
|
||||
| [_font; Number sz; _text] -> sz
|
||||
| [_font; Number sz] -> sz
|
||||
| _ -> 16.0 in
|
||||
let text = match args with
|
||||
| [_font; _sz; String t] -> t
|
||||
| _ -> "" in
|
||||
let (w, h, asc, desc) = measure_text_otfm font size text in
|
||||
let d = Hashtbl.create 4 in
|
||||
Hashtbl.replace d "width" (Number w);
|
||||
Hashtbl.replace d "height" (Number h);
|
||||
Hashtbl.replace d "ascent" (Number asc);
|
||||
Hashtbl.replace d "descent" (Number desc);
|
||||
Dict d
|
||||
| _ ->
|
||||
let argsv = Sx_runtime.get_val request (String "args") in
|
||||
(match Sx_persist_store.handle_op op argsv with
|
||||
| Some resp -> resp
|
||||
| None ->
|
||||
let args = (match argsv with List l -> l | _ -> [argsv]) in
|
||||
io_request op args))
|
||||
|
||||
and cek_run_with_io state =
|
||||
let s = ref state in
|
||||
let is_terminal s = match Sx_ref.cek_terminal_p s with Bool true -> true | _ -> false in
|
||||
@@ -535,49 +595,7 @@ and cek_run_with_io state =
|
||||
done;
|
||||
if is_suspended !s then begin
|
||||
let request = Sx_runtime.get_val !s (String "request") in
|
||||
let op = match Sx_runtime.get_val request (String "op") with String s -> s | _ -> "" in
|
||||
let response = match op with
|
||||
| "import" ->
|
||||
(* Resolve library locally — load the .sx file *)
|
||||
let lib_spec = Sx_runtime.get_val request (String "library") in
|
||||
let key = Sx_ref.library_name_key lib_spec in
|
||||
if Sx_types.sx_truthy (Sx_ref.library_loaded_p key) then
|
||||
(* Already loaded — just resume *)
|
||||
Nil
|
||||
else begin
|
||||
(match resolve_library_path lib_spec with
|
||||
| Some path -> load_library_file path
|
||||
| None ->
|
||||
Printf.eprintf "[import] WARNING: no file for library %s\n%!"
|
||||
(Sx_runtime.value_to_str lib_spec));
|
||||
Nil
|
||||
end
|
||||
| "text-measure" ->
|
||||
let args = let a = Sx_runtime.get_val request (String "args") in
|
||||
(match a with List l -> l | _ -> [a]) in
|
||||
let font = match args with String f :: _ -> f | _ -> "serif" in
|
||||
let size = match args with
|
||||
| [_font; Number sz; _text] -> sz
|
||||
| [_font; Number sz] -> sz
|
||||
| _ -> 16.0 in
|
||||
let text = match args with
|
||||
| [_font; _sz; String t] -> t
|
||||
| _ -> "" in
|
||||
let (w, h, asc, desc) = measure_text_otfm font size text in
|
||||
let d = Hashtbl.create 4 in
|
||||
Hashtbl.replace d "width" (Number w);
|
||||
Hashtbl.replace d "height" (Number h);
|
||||
Hashtbl.replace d "ascent" (Number asc);
|
||||
Hashtbl.replace d "descent" (Number desc);
|
||||
Dict d
|
||||
| _ ->
|
||||
let argsv = Sx_runtime.get_val request (String "args") in
|
||||
(match Sx_persist_store.handle_op op argsv with
|
||||
| Some resp -> resp
|
||||
| None ->
|
||||
let args = (match argsv with List l -> l | _ -> [argsv]) in
|
||||
io_request op args)
|
||||
in
|
||||
let response = resolve_io_request request in
|
||||
s := Sx_ref.cek_resume !s response;
|
||||
loop ()
|
||||
end else
|
||||
@@ -745,9 +763,27 @@ let setup_evaluator_bridge env =
|
||||
| _ -> raise (Eval_error "http-listen: (port handler)") in
|
||||
let sock = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in
|
||||
Unix.setsockopt sock Unix.SO_REUSEADDR true;
|
||||
(* Bind host: loopback by default (safe for tests + local runs); set
|
||||
SX_HTTP_HOST=0.0.0.0 to expose on the network (container/Caddy). *)
|
||||
let bind_addr =
|
||||
match Sys.getenv_opt "SX_HTTP_HOST" with
|
||||
| Some h -> (try Unix.inet_addr_of_string h
|
||||
with _ -> Unix.inet_addr_loopback)
|
||||
| None -> Unix.inet_addr_loopback in
|
||||
Unix.bind sock
|
||||
(Unix.ADDR_INET (Unix.inet_addr_loopback, port));
|
||||
(Unix.ADDR_INET (bind_addr, port));
|
||||
Unix.listen sock 64;
|
||||
(* Install the synchronous IO resolver for the serving path. Without it, a
|
||||
`perform` (durable kv read) that fires inside an HO-primitive callback
|
||||
(map/filter/reduce/…) during request handling suspends through the
|
||||
native OCaml loop, dropping its iteration state and leaving the stack
|
||||
misaligned — the serving-JIT host miscompile (map/rest/drop wrong args,
|
||||
blank pages, empty picker). With a resolver installed, sx_vm.ml resolves
|
||||
that callback's IO inline (byte-identically to cek_run_with_io) and the
|
||||
loop is never unwound. Only set if one isn't already installed. *)
|
||||
(if !Sx_types._cek_io_resolver = None then
|
||||
Sx_types._cek_io_resolver :=
|
||||
Some (fun request _state -> resolve_io_request request));
|
||||
(* SX runtime is shared across threads — serialize handler calls. *)
|
||||
let mtx = Mutex.create () in
|
||||
let reason = function
|
||||
@@ -807,9 +843,31 @@ let setup_evaluator_bridge env =
|
||||
Hashtbl.replace req "body" (String body);
|
||||
Mutex.lock mtx;
|
||||
let resp =
|
||||
(try Sx_runtime.sx_call handler [Dict req]
|
||||
with e -> Mutex.unlock mtx; raise e) in
|
||||
Mutex.unlock mtx;
|
||||
(* Run the handler through the IO-aware CEK runner (not bare
|
||||
sx_call) so request handlers can perform per-request IO —
|
||||
durable store reads/writes resolve via cek_run_with_io's
|
||||
suspension loop instead of returning an unresolved suspension.
|
||||
On ANY handler exception, synthesise a 500 response rather than
|
||||
letting it escape: an escaped exception drops the connection
|
||||
with no bytes written, which a reverse proxy (Caddy/Cloudflare)
|
||||
surfaces as a 502 error page. A real 500 keeps the origin
|
||||
responsive and debuggable. Note: a native exception (e.g. the
|
||||
parser's Parse_error) cannot be caught by an SX (guard ...), so
|
||||
this boundary is the only place it can be trapped. *)
|
||||
(try
|
||||
let st = Sx_ref.continue_with_call handler
|
||||
(List [Dict req]) (Env (Sx_types.make_env ()))
|
||||
(List [Dict req]) (List []) in
|
||||
let r = cek_run_with_io st in
|
||||
Mutex.unlock mtx; r
|
||||
with e ->
|
||||
Mutex.unlock mtx;
|
||||
Printf.eprintf "[http-listen] handler error: %s\n%!"
|
||||
(Printexc.to_string e);
|
||||
let d = Sx_types.make_dict () in
|
||||
Hashtbl.replace d "status" (Integer 500);
|
||||
Hashtbl.replace d "body" (String "Internal Server Error");
|
||||
Dict d) in
|
||||
let getk k = match resp with
|
||||
| Dict h -> Hashtbl.find_opt h k | _ -> None in
|
||||
let status = match getk "status" with
|
||||
@@ -835,6 +893,18 @@ let setup_evaluator_bridge env =
|
||||
List.iter (fun (k, v) ->
|
||||
Buffer.add_string buf
|
||||
(Printf.sprintf "%s: %s\r\n" k v)) rhdrs;
|
||||
(* Cookies: a response carries :set-cookies as a LIST of pre-formatted
|
||||
cookie strings (Dream's dream-set-cookie), because a headers Dict
|
||||
cannot hold more than one Set-Cookie. Emit one header per item. *)
|
||||
(match getk "set-cookies" with
|
||||
| Some (List items) ->
|
||||
List.iter (fun v ->
|
||||
match v with
|
||||
| String s ->
|
||||
Buffer.add_string buf
|
||||
(Printf.sprintf "Set-Cookie: %s\r\n" s)
|
||||
| _ -> ()) items
|
||||
| _ -> ());
|
||||
if not (List.exists
|
||||
(fun (k, _) ->
|
||||
String.lowercase_ascii k = "content-type")
|
||||
@@ -1227,6 +1297,20 @@ let setup_type_constructors env =
|
||||
(* Already a value — return as-is *)
|
||||
v
|
||||
| _ -> raise (Eval_error "parse: expected string"));
|
||||
(* Like parse, but returns nil instead of raising on malformed input. The
|
||||
parser raises a native Parse_error that an SX-level (guard ...) cannot catch
|
||||
(guard only traps SX conditions, not host exceptions), so code that handles
|
||||
untrusted text — e.g. a stored post body — needs a value-returning parse to
|
||||
degrade gracefully rather than crash the request. *)
|
||||
bind "parse-safe" (fun args ->
|
||||
match args with
|
||||
| [String s] | [SxExpr s] ->
|
||||
(try
|
||||
let exprs = Sx_parser.parse_all s in
|
||||
(match exprs with [e] -> e | _ -> List exprs)
|
||||
with _ -> Nil)
|
||||
| [v] -> v
|
||||
| _ -> Nil);
|
||||
(* Native bytecode compiler — bootstrapped from lib/compiler.sx *)
|
||||
bind "compile" (fun args ->
|
||||
match args with [expr] -> Sx_compiler.compile expr | _ -> Nil);
|
||||
@@ -1714,6 +1798,10 @@ let rec dispatch env cmd =
|
||||
| Nil -> "nil"
|
||||
| Bool true -> "true" | Bool false -> "false"
|
||||
| Number n -> Sx_types.format_number n
|
||||
(* Bytecode opcodes + arity/upvalue-count are Integers; without this case
|
||||
they hit the `_ -> "nil"` fallthrough, so every .sxbc came out as
|
||||
`:bytecode (nil nil ...)` -> "VM: unknown opcode 0" -> source fallback. *)
|
||||
| Integer n -> string_of_int n
|
||||
| String s -> "\"" ^ escape_sx_string s ^ "\""
|
||||
| Symbol s -> s | Keyword k -> ":" ^ k
|
||||
| List items | ListRef { contents = items } -> "(" ^ String.concat " " (List.map raw_serialize items) ^ ")"
|
||||
@@ -1741,8 +1829,9 @@ let rec dispatch env cmd =
|
||||
| _ -> "" in
|
||||
let response = if op = "import" then begin
|
||||
let lib_spec = Sx_runtime.get_val request (String "library") in
|
||||
let key = Sx_ref.library_name_key lib_spec in
|
||||
if Sx_types.sx_truthy (Sx_ref.library_loaded_p key) then Nil
|
||||
(* pass the SPEC, not a pre-computed key — library_loaded_p applies
|
||||
library_name_key itself (a key string would crash sx_to_list). *)
|
||||
if Sx_types.sx_truthy (Sx_ref.library_loaded_p lib_spec) then Nil
|
||||
else begin
|
||||
(match resolve_library_path lib_spec with
|
||||
| Some path -> load_library_file path | None -> ());
|
||||
@@ -4901,6 +4990,14 @@ let () =
|
||||
else begin
|
||||
(* Normal persistent server mode *)
|
||||
let env = make_server_env () in
|
||||
(* render-page: render an (unevaluated) SX page/component expression to HTML
|
||||
using the server env, so http-listen handlers can serve interactive SX
|
||||
pages. render-to-html expands components + collects keyword attrs itself;
|
||||
SX handlers can't reach the server env, so this primitive supplies it. *)
|
||||
ignore (env_bind env "render-page" (NativeFn ("render-page", fun args ->
|
||||
match args with
|
||||
| expr :: _ -> String (sx_render_to_html expr env)
|
||||
| _ -> raise (Eval_error "render-page: (expr)"))));
|
||||
(* JIT in the epoch serving mode is OPT-IN via SX_SERVING_JIT=1.
|
||||
Default OFF: this mode is the shared command channel used by every
|
||||
loop's conformance runner, and enabling JIT globally regresses
|
||||
|
||||
@@ -71,6 +71,11 @@ cp "$ROOT/shared/sx/templates/tw-layout.sx" "$DIST/sx/"
|
||||
cp "$ROOT/shared/sx/templates/tw-type.sx" "$DIST/sx/"
|
||||
cp "$ROOT/shared/sx/templates/tw.sx" "$DIST/sx/"
|
||||
|
||||
# 9b. Host app components (content-addressed, client-expanded on boosted nav).
|
||||
# Listed in the host's data-sx-manifest "boot" array so the client eager-loads
|
||||
# them after the web stack — see lib/host/static.sx + sx-platform.js loadWebStack.
|
||||
cp "$ROOT/lib/host/sx/relate-picker.sx" "$DIST/sx/"
|
||||
|
||||
# 10. Hyperscript
|
||||
for f in tokenizer parser compiler runtime integration htmx; do
|
||||
cp "$ROOT/lib/hyperscript/$f.sx" "$DIST/sx/hs-$f.sx"
|
||||
|
||||
@@ -48,6 +48,8 @@ const SOURCE_MAP = {
|
||||
'boot.sx': 'web/boot.sx',
|
||||
'tw-layout.sx': 'web/tw-layout.sx', 'tw-type.sx': 'web/tw-type.sx', 'tw.sx': 'web/tw.sx',
|
||||
'text-layout.sx': 'lib/text-layout.sx',
|
||||
// Host app components (content-addressed, client-expanded on boosted nav).
|
||||
'relate-picker.sx': 'lib/host/sx/relate-picker.sx',
|
||||
};
|
||||
let synced = 0;
|
||||
for (const [dist, src] of Object.entries(SOURCE_MAP)) {
|
||||
@@ -87,6 +89,8 @@ const FILES = [
|
||||
'hs-tokenizer.sx', 'hs-parser.sx', 'hs-compiler.sx', 'hs-runtime.sx',
|
||||
'hs-worker.sx', 'hs-prolog.sx',
|
||||
'hs-integration.sx', 'hs-htmx.sx',
|
||||
// Host app components — standalone defcomps, no inter-module deps.
|
||||
'relate-picker.sx',
|
||||
'boot.sx',
|
||||
];
|
||||
|
||||
|
||||
@@ -646,6 +646,18 @@
|
||||
// Load entry point itself (boot.sx — not a library, just defines + init)
|
||||
loadBytecodeFile("sx/" + entry.file) || loadSxFile("sx/" + entry.file.replace(/\.sxbc$/, '.sx'));
|
||||
|
||||
// App components: the page's data-sx-manifest "boot" array lists app-specific
|
||||
// modules (e.g. ~relate-picker) to eager-load after the web stack, so their
|
||||
// defcomps are registered before a boosted fragment references them. Loaded
|
||||
// content-addressed, the same as any module.
|
||||
var pageM = loadPageManifest();
|
||||
if (pageM && pageM.boot && pageM.boot.length) {
|
||||
for (var b = 0; b < pageM.boot.length; b++) {
|
||||
var bf = pageM.boot[b];
|
||||
loadBytecodeFile("sx/" + bf) || loadSxFile("sx/" + bf.replace(/\.sxbc$/, '.sx'));
|
||||
}
|
||||
}
|
||||
|
||||
if (K.endModuleLoad) K.endModuleLoad();
|
||||
var count = Object.keys(_loadedLibs).length + 1; // +1 for entry
|
||||
var dt = Math.round(performance.now() - t0);
|
||||
|
||||
@@ -73,6 +73,7 @@ let rec value_to_js (v : value) : Js.Unsafe.any =
|
||||
| Nil -> Js.Unsafe.inject Js.null
|
||||
| Bool b -> Js.Unsafe.inject (Js.bool b)
|
||||
| Number n -> Js.Unsafe.inject (Js.number_of_float n)
|
||||
| Integer n -> Js.Unsafe.inject (Js.number_of_float (float_of_int n))
|
||||
| String s -> Js.Unsafe.inject (Js.string s)
|
||||
| RawHTML s -> Js.Unsafe.inject (Js.string s)
|
||||
| Symbol s ->
|
||||
@@ -329,8 +330,9 @@ let handle_import_suspension request =
|
||||
let lib_spec = match request with
|
||||
| Dict d -> (match Hashtbl.find_opt d "library" with Some v -> v | _ -> Nil)
|
||||
| _ -> Nil in
|
||||
let key = Sx_ref.library_name_key lib_spec in
|
||||
if Sx_types.sx_truthy (Sx_ref.library_loaded_p key) then
|
||||
(* library_loaded_p takes the SPEC and applies library_name_key itself —
|
||||
passing a pre-computed key string double-applies it and crashes. *)
|
||||
if Sx_types.sx_truthy (Sx_ref.library_loaded_p lib_spec) then
|
||||
Some Nil (* Already loaded — resume immediately *)
|
||||
else
|
||||
None (* Not loaded — JS platform must fetch it *)
|
||||
|
||||
@@ -15,25 +15,29 @@ exception Cbor_error of string
|
||||
|
||||
let write_head buf major v =
|
||||
let m = major lsl 5 in
|
||||
(* Width selection + big-endian byte emission via Int64, so the web targets
|
||||
compute identically to native: on js_of_ocaml [int] is 32-bit, so the
|
||||
literal 0x100000000 (2^32) truncates to 0 (sending small values to the
|
||||
8-byte branch) and [v lsr (8*i)] with i>=4 is shift-mod-32. Int64 has the
|
||||
full 64-bit width and well-defined shifts on every target. *)
|
||||
let v64 = Int64.of_int v in
|
||||
let put_be nbytes =
|
||||
for i = nbytes - 1 downto 0 do
|
||||
Buffer.add_char buf
|
||||
(Char.chr (Int64.to_int
|
||||
(Int64.logand (Int64.shift_right_logical v64 (8 * i)) 0xFFL)))
|
||||
done
|
||||
in
|
||||
if v < 24 then
|
||||
Buffer.add_char buf (Char.chr (m lor v))
|
||||
else if v < 0x100 then begin
|
||||
Buffer.add_char buf (Char.chr (m lor 24));
|
||||
Buffer.add_char buf (Char.chr v)
|
||||
Buffer.add_char buf (Char.chr (m lor 24)); put_be 1
|
||||
end else if v < 0x10000 then begin
|
||||
Buffer.add_char buf (Char.chr (m lor 25));
|
||||
Buffer.add_char buf (Char.chr ((v lsr 8) land 0xFF));
|
||||
Buffer.add_char buf (Char.chr (v land 0xFF))
|
||||
end else if v < 0x100000000 then begin
|
||||
Buffer.add_char buf (Char.chr (m lor 26));
|
||||
for i = 3 downto 0 do
|
||||
Buffer.add_char buf (Char.chr ((v lsr (8 * i)) land 0xFF))
|
||||
done
|
||||
Buffer.add_char buf (Char.chr (m lor 25)); put_be 2
|
||||
end else if Int64.compare v64 0x100000000L < 0 then begin
|
||||
Buffer.add_char buf (Char.chr (m lor 26)); put_be 4
|
||||
end else begin
|
||||
Buffer.add_char buf (Char.chr (m lor 27));
|
||||
for i = 7 downto 0 do
|
||||
Buffer.add_char buf (Char.chr ((v lsr (8 * i)) land 0xFF))
|
||||
done
|
||||
Buffer.add_char buf (Char.chr (m lor 27)); put_be 8
|
||||
end
|
||||
|
||||
(* dag-cbor map key order: shorter key first, then bytewise. *)
|
||||
|
||||
@@ -32,7 +32,11 @@ let base32_lower (s : string) : string =
|
||||
while !bits >= 5 do
|
||||
bits := !bits - 5;
|
||||
Buffer.add_char buf b32_alpha.[(!acc lsr !bits) land 0x1f]
|
||||
done) s;
|
||||
done;
|
||||
(* Keep only the unconsumed low [bits] bits, so [acc] stays tiny (< 2^13).
|
||||
Without this it grows by 8 bits per byte and overflows native [int] on
|
||||
the 32-bit web targets, corrupting the emitted symbols. *)
|
||||
acc := !acc land ((1 lsl !bits) - 1)) s;
|
||||
if !bits > 0 then
|
||||
Buffer.add_char buf b32_alpha.[(!acc lsl (5 - !bits)) land 0x1f];
|
||||
Buffer.contents buf
|
||||
|
||||
@@ -68,15 +68,22 @@ let sub (a : bn) (b : bn) : bn =
|
||||
norm r
|
||||
|
||||
let mul (a : bn) (b : bn) : bn =
|
||||
(* Accumulate in Int64: a limb product is 26+26 = 52 bits, which overflows the
|
||||
web targets' int (32-bit js_of_ocaml / 31-bit wasm_of_ocaml). Int64 is a
|
||||
real 64-bit type on every target, so the carries are exact. *)
|
||||
let la = Array.length a and lb = Array.length b in
|
||||
let r = Array.make (la + lb) 0 in
|
||||
let maskL = Int64.of_int mask in
|
||||
for i = 0 to la - 1 do
|
||||
let carry = ref 0 in
|
||||
let carry = ref 0L in
|
||||
let ai = Int64.of_int a.(i) in
|
||||
for j = 0 to lb - 1 do
|
||||
let s = r.(i + j) + a.(i) * b.(j) + !carry in
|
||||
r.(i + j) <- s land mask; carry := s lsr bits
|
||||
let s = Int64.add (Int64.add (Int64.of_int r.(i + j))
|
||||
(Int64.mul ai (Int64.of_int b.(j)))) !carry in
|
||||
r.(i + j) <- Int64.to_int (Int64.logand s maskL);
|
||||
carry := Int64.shift_right_logical s bits
|
||||
done;
|
||||
r.(i + lb) <- r.(i + lb) + !carry
|
||||
r.(i + lb) <- r.(i + lb) + Int64.to_int !carry
|
||||
done;
|
||||
norm r
|
||||
|
||||
@@ -109,12 +116,16 @@ let bn_mod (a : bn) (m : bn) : bn =
|
||||
end
|
||||
|
||||
let div_small (a : bn) (d : int) : bn =
|
||||
(* [rem lsl bits] reaches ~2^34 (rem < d <= 256, bits = 26), past the web
|
||||
targets' int width — accumulate the running remainder in Int64. *)
|
||||
let la = Array.length a in
|
||||
let q = Array.make la 0 in
|
||||
let rem = ref 0 in
|
||||
let rem = ref 0L in
|
||||
let dL = Int64.of_int d in
|
||||
for i = la - 1 downto 0 do
|
||||
let cur = (!rem lsl bits) lor a.(i) in
|
||||
q.(i) <- cur / d; rem := cur mod d
|
||||
let cur = Int64.logor (Int64.shift_left !rem bits) (Int64.of_int a.(i)) in
|
||||
q.(i) <- Int64.to_int (Int64.div cur dL);
|
||||
rem := Int64.rem cur dL
|
||||
done;
|
||||
norm q
|
||||
|
||||
|
||||
@@ -404,7 +404,7 @@ and library_loaded_p spec =
|
||||
|
||||
(* library-exports *)
|
||||
and library_exports spec =
|
||||
(get ((get (_library_registry_) ((library_name_key (spec))))) ((String "exports")))
|
||||
(let entry = (get (_library_registry_) ((library_name_key (spec)))) in (if sx_truthy (entry) then (get (entry) ((String "exports"))) else (Dict (Hashtbl.create 0))))
|
||||
|
||||
(* register-library *)
|
||||
and register_library spec exports =
|
||||
|
||||
@@ -3,37 +3,40 @@
|
||||
No C stubs, no external deps. Used by the fed-sx host primitives
|
||||
[crypto-sha256] / [crypto-sha512]. Reference: FIPS 180-4. *)
|
||||
|
||||
(* ---- SHA-256 (FIPS 180-4 §6.2). 32-bit words held in native int,
|
||||
masked to 32 bits after every arithmetic op. ---- *)
|
||||
|
||||
let mask32 = 0xFFFFFFFF
|
||||
(* ---- SHA-256 (FIPS 180-4 §6.2). 32-bit words via Int32, NOT native int.
|
||||
On the web targets the kernel is compiled by js_of_ocaml (32-bit int) and
|
||||
wasm_of_ocaml (31-bit int), where native [int] silently truncates the 32-bit
|
||||
round words — producing WRONG digests (and, downstream, bad CIDs and a
|
||||
Char.chr crash at kernel init). Int32 has well-defined wrap-around mod 2^32 on
|
||||
every target, so this matches the 63-bit native build exactly. ---- *)
|
||||
|
||||
let k256 = [|
|
||||
0x428a2f98; 0x71374491; 0xb5c0fbcf; 0xe9b5dba5;
|
||||
0x3956c25b; 0x59f111f1; 0x923f82a4; 0xab1c5ed5;
|
||||
0xd807aa98; 0x12835b01; 0x243185be; 0x550c7dc3;
|
||||
0x72be5d74; 0x80deb1fe; 0x9bdc06a7; 0xc19bf174;
|
||||
0xe49b69c1; 0xefbe4786; 0x0fc19dc6; 0x240ca1cc;
|
||||
0x2de92c6f; 0x4a7484aa; 0x5cb0a9dc; 0x76f988da;
|
||||
0x983e5152; 0xa831c66d; 0xb00327c8; 0xbf597fc7;
|
||||
0xc6e00bf3; 0xd5a79147; 0x06ca6351; 0x14292967;
|
||||
0x27b70a85; 0x2e1b2138; 0x4d2c6dfc; 0x53380d13;
|
||||
0x650a7354; 0x766a0abb; 0x81c2c92e; 0x92722c85;
|
||||
0xa2bfe8a1; 0xa81a664b; 0xc24b8b70; 0xc76c51a3;
|
||||
0xd192e819; 0xd6990624; 0xf40e3585; 0x106aa070;
|
||||
0x19a4c116; 0x1e376c08; 0x2748774c; 0x34b0bcb5;
|
||||
0x391c0cb3; 0x4ed8aa4a; 0x5b9cca4f; 0x682e6ff3;
|
||||
0x748f82ee; 0x78a5636f; 0x84c87814; 0x8cc70208;
|
||||
0x90befffa; 0xa4506ceb; 0xbef9a3f7; 0xc67178f2 |]
|
||||
0x428a2f98l; 0x71374491l; 0xb5c0fbcfl; 0xe9b5dba5l;
|
||||
0x3956c25bl; 0x59f111f1l; 0x923f82a4l; 0xab1c5ed5l;
|
||||
0xd807aa98l; 0x12835b01l; 0x243185bel; 0x550c7dc3l;
|
||||
0x72be5d74l; 0x80deb1fel; 0x9bdc06a7l; 0xc19bf174l;
|
||||
0xe49b69c1l; 0xefbe4786l; 0x0fc19dc6l; 0x240ca1ccl;
|
||||
0x2de92c6fl; 0x4a7484aal; 0x5cb0a9dcl; 0x76f988dal;
|
||||
0x983e5152l; 0xa831c66dl; 0xb00327c8l; 0xbf597fc7l;
|
||||
0xc6e00bf3l; 0xd5a79147l; 0x06ca6351l; 0x14292967l;
|
||||
0x27b70a85l; 0x2e1b2138l; 0x4d2c6dfcl; 0x53380d13l;
|
||||
0x650a7354l; 0x766a0abbl; 0x81c2c92el; 0x92722c85l;
|
||||
0xa2bfe8a1l; 0xa81a664bl; 0xc24b8b70l; 0xc76c51a3l;
|
||||
0xd192e819l; 0xd6990624l; 0xf40e3585l; 0x106aa070l;
|
||||
0x19a4c116l; 0x1e376c08l; 0x2748774cl; 0x34b0bcb5l;
|
||||
0x391c0cb3l; 0x4ed8aa4al; 0x5b9cca4fl; 0x682e6ff3l;
|
||||
0x748f82eel; 0x78a5636fl; 0x84c87814l; 0x8cc70208l;
|
||||
0x90befffal; 0xa4506cebl; 0xbef9a3f7l; 0xc67178f2l |]
|
||||
|
||||
let rotr32 x n = ((x lsr n) lor (x lsl (32 - n))) land mask32
|
||||
let rotr32 (x : int32) (n : int) : int32 =
|
||||
Int32.logor (Int32.shift_right_logical x n) (Int32.shift_left x (32 - n))
|
||||
|
||||
let sha256_hex (msg : string) : string =
|
||||
let h = [| 0x6a09e667; 0xbb67ae85; 0x3c6ef372; 0xa54ff53a;
|
||||
0x510e527f; 0x9b05688c; 0x1f83d9ab; 0x5be0cd19 |] in
|
||||
let h = [| 0x6a09e667l; 0xbb67ae85l; 0x3c6ef372l; 0xa54ff53al;
|
||||
0x510e527fl; 0x9b05688cl; 0x1f83d9abl; 0x5be0cd19l |] in
|
||||
let len = String.length msg in
|
||||
(* Padded length: multiple of 64 bytes. *)
|
||||
let bitlen = len * 8 in
|
||||
let bitlen = Int64.mul (Int64.of_int len) 8L in
|
||||
let padlen =
|
||||
let r = (len + 1) mod 64 in
|
||||
if r <= 56 then 56 - r else 120 - r
|
||||
@@ -42,60 +45,79 @@ let sha256_hex (msg : string) : string =
|
||||
let buf = Bytes.make total '\000' in
|
||||
Bytes.blit_string msg 0 buf 0 len;
|
||||
Bytes.set buf len '\x80';
|
||||
(* 64-bit big-endian bit length (we cap at OCaml int range). *)
|
||||
(* 64-bit big-endian bit length. Int64 shifts so the high bytes (shift >= 32)
|
||||
are correct on the 32-bit web targets — native int `lsr 32` is shift-mod-32
|
||||
on js_of_ocaml and would leak the low length byte into a higher word. *)
|
||||
for i = 0 to 7 do
|
||||
Bytes.set buf (total - 1 - i)
|
||||
(Char.chr ((bitlen lsr (8 * i)) land 0xFF))
|
||||
(Char.chr (Int64.to_int
|
||||
(Int64.logand (Int64.shift_right_logical bitlen (8 * i)) 0xFFL)))
|
||||
done;
|
||||
let w = Array.make 64 0 in
|
||||
let byte i = Int32.of_int (Char.code (Bytes.get buf i)) in
|
||||
let w = Array.make 64 0l in
|
||||
let nblocks = total / 64 in
|
||||
for b = 0 to nblocks - 1 do
|
||||
let base = b * 64 in
|
||||
for t = 0 to 15 do
|
||||
let o = base + t * 4 in
|
||||
w.(t) <-
|
||||
(Char.code (Bytes.get buf o) lsl 24)
|
||||
lor (Char.code (Bytes.get buf (o + 1)) lsl 16)
|
||||
lor (Char.code (Bytes.get buf (o + 2)) lsl 8)
|
||||
lor (Char.code (Bytes.get buf (o + 3)))
|
||||
Int32.logor
|
||||
(Int32.logor
|
||||
(Int32.shift_left (byte o) 24)
|
||||
(Int32.shift_left (byte (o + 1)) 16))
|
||||
(Int32.logor
|
||||
(Int32.shift_left (byte (o + 2)) 8)
|
||||
(byte (o + 3)))
|
||||
done;
|
||||
for t = 16 to 63 do
|
||||
let s0 =
|
||||
(rotr32 w.(t - 15) 7) lxor (rotr32 w.(t - 15) 18)
|
||||
lxor (w.(t - 15) lsr 3) in
|
||||
Int32.logxor
|
||||
(Int32.logxor (rotr32 w.(t - 15) 7) (rotr32 w.(t - 15) 18))
|
||||
(Int32.shift_right_logical w.(t - 15) 3) in
|
||||
let s1 =
|
||||
(rotr32 w.(t - 2) 17) lxor (rotr32 w.(t - 2) 19)
|
||||
lxor (w.(t - 2) lsr 10) in
|
||||
w.(t) <- (w.(t - 16) + s0 + w.(t - 7) + s1) land mask32
|
||||
Int32.logxor
|
||||
(Int32.logxor (rotr32 w.(t - 2) 17) (rotr32 w.(t - 2) 19))
|
||||
(Int32.shift_right_logical w.(t - 2) 10) in
|
||||
w.(t) <-
|
||||
Int32.add (Int32.add w.(t - 16) s0) (Int32.add w.(t - 7) s1)
|
||||
done;
|
||||
let a = ref h.(0) and bb = ref h.(1) and c = ref h.(2)
|
||||
and d = ref h.(3) and e = ref h.(4) and f = ref h.(5)
|
||||
and g = ref h.(6) and hh = ref h.(7) in
|
||||
for t = 0 to 63 do
|
||||
let s1 =
|
||||
(rotr32 !e 6) lxor (rotr32 !e 11) lxor (rotr32 !e 25) in
|
||||
let ch = (!e land !f) lxor ((lnot !e land mask32) land !g) in
|
||||
let t1 = (!hh + s1 + ch + k256.(t) + w.(t)) land mask32 in
|
||||
Int32.logxor
|
||||
(Int32.logxor (rotr32 !e 6) (rotr32 !e 11)) (rotr32 !e 25) in
|
||||
let ch =
|
||||
Int32.logxor (Int32.logand !e !f)
|
||||
(Int32.logand (Int32.lognot !e) !g) in
|
||||
let t1 =
|
||||
Int32.add
|
||||
(Int32.add (Int32.add !hh s1) (Int32.add ch k256.(t))) w.(t) in
|
||||
let s0 =
|
||||
(rotr32 !a 2) lxor (rotr32 !a 13) lxor (rotr32 !a 22) in
|
||||
let maj = (!a land !bb) lxor (!a land !c) lxor (!bb land !c) in
|
||||
let t2 = (s0 + maj) land mask32 in
|
||||
Int32.logxor
|
||||
(Int32.logxor (rotr32 !a 2) (rotr32 !a 13)) (rotr32 !a 22) in
|
||||
let maj =
|
||||
Int32.logxor
|
||||
(Int32.logxor (Int32.logand !a !bb) (Int32.logand !a !c))
|
||||
(Int32.logand !bb !c) in
|
||||
let t2 = Int32.add s0 maj in
|
||||
hh := !g; g := !f; f := !e;
|
||||
e := (!d + t1) land mask32;
|
||||
e := Int32.add !d t1;
|
||||
d := !c; c := !bb; bb := !a;
|
||||
a := (t1 + t2) land mask32
|
||||
a := Int32.add t1 t2
|
||||
done;
|
||||
h.(0) <- (h.(0) + !a) land mask32;
|
||||
h.(1) <- (h.(1) + !bb) land mask32;
|
||||
h.(2) <- (h.(2) + !c) land mask32;
|
||||
h.(3) <- (h.(3) + !d) land mask32;
|
||||
h.(4) <- (h.(4) + !e) land mask32;
|
||||
h.(5) <- (h.(5) + !f) land mask32;
|
||||
h.(6) <- (h.(6) + !g) land mask32;
|
||||
h.(7) <- (h.(7) + !hh) land mask32
|
||||
h.(0) <- Int32.add h.(0) !a;
|
||||
h.(1) <- Int32.add h.(1) !bb;
|
||||
h.(2) <- Int32.add h.(2) !c;
|
||||
h.(3) <- Int32.add h.(3) !d;
|
||||
h.(4) <- Int32.add h.(4) !e;
|
||||
h.(5) <- Int32.add h.(5) !f;
|
||||
h.(6) <- Int32.add h.(6) !g;
|
||||
h.(7) <- Int32.add h.(7) !hh
|
||||
done;
|
||||
let out = Buffer.create 64 in
|
||||
Array.iter (fun x -> Buffer.add_string out (Printf.sprintf "%08x" x)) h;
|
||||
Array.iter (fun x -> Buffer.add_string out (Printf.sprintf "%08lx" x)) h;
|
||||
Buffer.contents out
|
||||
|
||||
(* ---- SHA-512 (FIPS 180-4 §6.4). 64-bit words via Int64.
|
||||
@@ -146,7 +168,7 @@ let sha512_hex (msg : string) : string =
|
||||
0x510e527fade682d1L; 0x9b05688c2b3e6c1fL;
|
||||
0x1f83d9abfb41bd6bL; 0x5be0cd19137e2179L |] in
|
||||
let len = String.length msg in
|
||||
let bitlen = len * 8 in
|
||||
let bitlen = Int64.mul (Int64.of_int len) 8L in
|
||||
(* Pad to a multiple of 128 bytes; 16-byte big-endian length. *)
|
||||
let padlen =
|
||||
let r = (len + 1) mod 128 in
|
||||
@@ -156,9 +178,12 @@ let sha512_hex (msg : string) : string =
|
||||
let buf = Bytes.make total '\000' in
|
||||
Bytes.blit_string msg 0 buf 0 len;
|
||||
Bytes.set buf len '\x80';
|
||||
(* Low 64 bits of the bit length (high 64 stay 0). Int64 shifts so the bytes
|
||||
at shift >= 32 are correct on the 32-bit web targets (js shift-mod-32). *)
|
||||
for i = 0 to 7 do
|
||||
Bytes.set buf (total - 1 - i)
|
||||
(Char.chr ((bitlen lsr (8 * i)) land 0xFF))
|
||||
(Char.chr (Int64.to_int
|
||||
(Int64.logand (Int64.shift_right_logical bitlen (8 * i)) 0xFFL)))
|
||||
done;
|
||||
let w = Array.make 80 0L in
|
||||
let nblocks = total / 128 in
|
||||
|
||||
Reference in New Issue
Block a user