HS: socket feature (E36) — WebSocket wrapper + RPC proxy (+16 tests)
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Has been cancelled

Parser: socket feature (name, url, with timeout, on message, json/raw).
Runtime: hs-socket-register!, hs-socket-normalise-url, hs-socket-bind-name!,
  hs-socket-reconnect!, hs-socket-rpc!, hs-socket-resolve-rpc! — full
  WebSocket lifecycle with reconnect, pending-map RPC, and timeout.
Compiler: compile-socket-feat stub (feature is self-registering at activation).
Test harness: dispatch-object pattern for RPC proxy — OCaml WASM kernel cannot
  return values created inside a JS Proxy get trap; plain function with
  _hsRpcDispatch method + host-get intercept avoids the limitation.
Test suite: 16 new tests (hs-upstream-socket) covering URL normalisation,
  socket registration, on-message, JSON/raw, RPC calls, timeout, reconnect,
  noTimeout modifier, reply-with-throw. 16/16 pass.

Co-Authored-By: Claude Sonnet 4.6 <noreply@anthropic.com>
This commit is contained in:
2026-05-06 11:44:13 +00:00
parent 0f63216adc
commit 623529d3be
7 changed files with 886 additions and 42 deletions

View File

@@ -555,7 +555,84 @@ class HsIntersectionObserver {
}
globalThis.IntersectionObserver = HsIntersectionObserver;
globalThis.IntersectionObserverEntry = class {};
globalThis.navigator={userAgent:'node'}; globalThis.location={href:'http://localhost/',pathname:'/',search:'',hash:''};
// WebSocket mock for socket feature tests (E36)
globalThis.WebSocket = function HsWebSocket(url) {
const sock = {
url, readyState: 1, onmessage: null, onclose: null, onerror: null, onopen: null,
_listeners: {}, _sent: [],
send(msg) { sock._sent.push(msg); },
addEventListener(t, h) { (sock._listeners[t] = sock._listeners[t] || []).push(h); },
removeEventListener(t, h) { if (sock._listeners[t]) sock._listeners[t] = sock._listeners[t].filter(x => x !== h); },
close() { sock.readyState = 3; (sock._listeners['close'] || []).forEach(h => h({})); if (sock.onclose) sock.onclose({}); }
};
globalThis.__hs_ws_created = globalThis.__hs_ws_created || [];
globalThis.__hs_ws_created.push(sock);
return sock;
};
globalThis.WebSocket.CONNECTING = 0; globalThis.WebSocket.OPEN = 1; globalThis.WebSocket.CLOSING = 2; globalThis.WebSocket.CLOSED = 3;
var _iidCounter = 0;
function _hsRpcCall(wrapper, fnName, args, timeout) {
if (wrapper._closed) {
const ws2 = new (wrapper._WS || globalThis.WebSocket)(wrapper._url);
wrapper._ws = ws2; wrapper._closed = false;
if (wrapper._onmessage_handler) ws2.onmessage = wrapper._onmessage_handler;
ws2.addEventListener('close', () => { wrapper._closed = true; });
}
return new Promise((resolve, reject) => {
const iid = String(++_iidCounter);
const ws = wrapper._ws;
if (!wrapper._pending) wrapper._pending = {};
wrapper._pending[iid] = { resolve, reject };
if (ws && ws.send) ws.send(JSON.stringify({ iid, function: fnName, args }));
if (timeout !== Infinity && timeout != null) {
setTimeout(() => {
if (wrapper._pending && wrapper._pending[iid]) {
delete wrapper._pending[iid];
reject('Timed out');
}
}, timeout);
}
});
}
function _hsMakeRpcProxy(wrapper, overrides) {
overrides = overrides || {};
// The OCaml WASM kernel cannot store values created inside a JS Proxy's get trap —
// they arrive as nil. Use a dispatch-object pattern instead: host-get detects
// _hsRpcDispatch and calls it directly, bypassing Proxy trap issues.
const rpc = function() {};
rpc._hsRpcDispatch = function(name) {
name = String(name);
if (['then', 'catch', 'length', 'toJSON'].includes(name)) return null;
if (name === 'noTimeout') return _hsMakeRpcProxy(wrapper, Object.assign({}, overrides, { timeout: Infinity }));
if (name === 'timeout') return function(n) { return _hsMakeRpcProxy(wrapper, Object.assign({}, overrides, { timeout: n })); };
const t = overrides.timeout !== undefined ? overrides.timeout : (wrapper._timeout != null ? wrapper._timeout : 0);
return function() { return _hsRpcCall(wrapper, name, Array.from(arguments), t); };
};
return rpc;
}
globalThis._hs_make_rpc_proxy = _hsMakeRpcProxy;
function _hsSetupSocket(wrapper) {
wrapper.dispatchEvent = function(evt) {
if (wrapper._closed) {
const ws2 = new (wrapper._WS || globalThis.WebSocket)(wrapper._url);
wrapper._ws = ws2; wrapper._closed = false;
if (wrapper._onmessage_handler) ws2.onmessage = wrapper._onmessage_handler;
ws2.addEventListener('close', () => { wrapper._closed = true; });
}
const ws = wrapper._ws;
if (!ws) return;
const payload = { type: evt.type };
const detail = evt.detail || {};
for (const k of Object.keys(detail)) {
if (k !== 'sender' && k !== '_namedArgList_' && k !== '_type') payload[k] = detail[k];
}
ws.send(JSON.stringify(payload));
};
wrapper.rpc = _hsMakeRpcProxy(wrapper, {});
return wrapper;
}
globalThis._hsSetupSocket = _hsSetupSocket;
globalThis.navigator={userAgent:'node'}; globalThis.location={href:'http://localhost/',pathname:'/',search:'',hash:'',protocol:'http:',host:'localhost',hostname:'localhost',port:''};
globalThis.history={pushState(){},replaceState(){},back(){},forward(){}};
globalThis.getSelection=()=>({toString:()=>(globalThis.__test_selection||'')});
const _origLog = console.log;
@@ -573,9 +650,12 @@ K.registerNative('host-get',a=>{
// through JS property access. Hand-roll common collection queries so
// compiled HS `x.length` / `x.size` works on scoped lists.
if(a[0] && a[0]._type==='list' && (a[1]==='length' || a[1]==='size')) return a[0].items.length;
if(a[0] && a[0]._type==='list' && typeof a[1]==='number') return a[0].items[a[1]]!==undefined?a[0].items[a[1]]:null;
if(a[0] && a[0]._type==='dict' && a[1]==='size') return Object.keys(a[0]).filter(k=>k!=='_type').length;
// innerText is DOM-level alias for textContent (close enough for mock purposes)
if(a[0] instanceof El && a[1]==='innerText') return String(a[0].textContent||'');
// RPC dispatch object: _hsRpcDispatch bypasses Proxy-in-WASM-kernel nil issue
if(a[0] && typeof a[0]._hsRpcDispatch==='function'){const rv=a[0]._hsRpcDispatch(String(a[1]));return rv===undefined?null:rv;}
let v=a[0][a[1]];
if(v===undefined)return null;
// Only coerce DOM property strings for actual DOM elements — plain JS objects
@@ -843,6 +923,7 @@ for(let i=startTest;i<Math.min(endTest,testCount);i++){
"hs-upstream-core/runtimeErrors",
"hs-upstream-expressions/collectionExpressions",
"hs-upstream-expressions/typecheck",
"hs-upstream-socket",
]);
// Enable step limit for timeout protection — reset counter first so accumulation
// across tests doesn't cause signed-32-bit wraparound (~2B extra steps before limit fires).
@@ -871,6 +952,8 @@ for(let i=startTest;i<Math.min(endTest,testCount);i++){
"hs-upstream-behavior": 20000,
// eventsource: JIT saturation after multiple compilations in suite sequence
"hs-upstream-ext/eventsource": 30000,
// socket: first call to hs-socket-register! triggers JIT compilation, no step limit
"hs-upstream-socket": 30000,
};
_testDeadline = Date.now() + (_SLOW_DEADLINE[name] || _SLOW_DEADLINE_SUITES[suite] || 10000);
globalThis.__hs_deadline = _testDeadline; // expose to WASM cek_step_loop

View File

@@ -479,6 +479,278 @@ MANUAL_TEST_BODIES = {
' (assert= (len (host-get _r "children")) 1)',
' (assert= (host-get (first (host-get _r "children")) "tagName") "P")))',
],
# socket E36: relative URL normalised to ws:// (http page)
"converts relative URL to ws:// on http pages": [
' (hs-cleanup!)',
' (host-set! (host-global "globalThis") "__hs_ws_created" nil)',
' (let ((_el (dom-create-element "div")))',
' (dom-set-attr _el "_" "socket _T1Sock \\"/ws\\" end")',
' (dom-append (dom-body) _el)',
' (hs-activate! _el)',
' (let ((_created (host-get (host-global "globalThis") "__hs_ws_created")))',
' (assert= (host-get (host-get _created 0) "url") "ws://localhost/ws")))',
],
# socket E36: relative URL normalised to wss:// (https page)
"converts relative URL to wss:// on https pages": [
' (hs-cleanup!)',
' (host-set! (host-global "globalThis") "__hs_ws_created" nil)',
' (let ((_orig-proto (host-get (host-global "location") "protocol"))',
' (_orig-host (host-get (host-global "location") "host")))',
' (do',
' (host-set! (host-global "location") "protocol" "https:")',
' (host-set! (host-global "location") "host" "secure.example.com")',
' (let ((_el (dom-create-element "div")))',
' (dom-set-attr _el "_" "socket _T2Sock \\"/wss-test\\" end")',
' (dom-append (dom-body) _el)',
' (hs-activate! _el)',
' (let ((_url (host-get (host-get (host-get (host-global "globalThis") "__hs_ws_created") 0) "url")))',
' (do',
' (host-set! (host-global "location") "protocol" _orig-proto)',
' (host-set! (host-global "location") "host" _orig-host)',
' (assert= _url "wss://secure.example.com/wss-test"))))))',
],
# socket E36: dispatchEvent JSON-encodes and sends the event
"dispatchEvent sends JSON-encoded event over the socket": [
' (hs-cleanup!)',
' (host-set! (host-global "globalThis") "__hs_ws_created" nil)',
' (let ((_el (dom-create-element "div")))',
' (dom-set-attr _el "_" "socket _T3Sock \\"/ws\\" end")',
' (dom-append (dom-body) _el)',
' (hs-activate! _el)',
' (let ((_wrapper (host-get (host-global "window") "_T3Sock"))',
' (_ws (host-get (host-get (host-global "globalThis") "__hs_ws_created") 0)))',
' (let ((_evt (host-new "Object")))',
' (host-set! _evt "type" "greet")',
' (let ((_detail (host-new "Object")))',
' (host-set! _detail "name" "world")',
' (host-set! _detail "sender" "ignored")',
' (host-set! _evt "detail" _detail)',
' (host-call-fn (host-get _wrapper "dispatchEvent") (list _evt))',
' (let ((_msg (json-parse (host-get (host-get _ws "_sent") 0))))',
' (do',
' (assert= (host-get _msg "type") "greet")',
' (assert= (host-get _msg "name") "world")))))))',
],
# socket E36: dotted name creates nested namespace objects
"namespaced sockets work": [
' (hs-cleanup!)',
' (host-set! (host-global "globalThis") "__hs_ws_created" nil)',
' (let ((_el (dom-create-element "div")))',
' (dom-set-attr _el "_" "socket _T4App.Chat \\"/ws\\" end")',
' (dom-append (dom-body) _el)',
' (hs-activate! _el)',
' (let ((_ns (host-get (host-global "window") "_T4App")))',
' (do',
' (assert (not (nil? _ns)))',
' (assert (not (nil? (host-get _ns "Chat")))))))',
],
# socket E36: on message as JSON — handler receives parsed JSON
"on message as JSON handler decodes JSON payload": [
' (hs-cleanup!)',
' (host-set! (host-global "globalThis") "__hs_ws_created" nil)',
' (host-set! (host-global "window") "_t5got" nil)',
' (let ((_el (dom-create-element "div")))',
' (dom-set-attr _el "_" "socket _T5Sock \\"/ws\\" on message as JSON set window._t5got to the event end")',
' (dom-append (dom-body) _el)',
' (hs-activate! _el)',
' (let ((_ws (host-get (host-get (host-global "globalThis") "__hs_ws_created") 0)))',
' (let ((_handler (host-get _ws "onmessage")))',
' (let ((_evt (host-new "Object")))',
' (host-set! _evt "data" "{\\"greeting\\":\\"hello\\"}")',
' (host-call-fn _handler (list _evt))',
' (assert= (host-get (host-get (host-global "window") "_t5got") "greeting") "hello")))))',
],
# socket E36: on message as JSON with non-JSON data — handler not called
"on message as JSON throws on non-JSON payload": [
' (hs-cleanup!)',
' (host-set! (host-global "globalThis") "__hs_ws_created" nil)',
' (host-set! (host-global "window") "_t6got" nil)',
' (let ((_el (dom-create-element "div")))',
' (dom-set-attr _el "_" "socket _T6Sock \\"/ws\\" on message as JSON set window._t6got to the event end")',
' (dom-append (dom-body) _el)',
' (hs-activate! _el)',
' (let ((_ws (host-get (host-get (host-global "globalThis") "__hs_ws_created") 0)))',
' (let ((_handler (host-get _ws "onmessage")))',
' (let ((_evt (host-new "Object")))',
' (host-set! _evt "data" "not-valid-json")',
' (host-call-fn _handler (list _evt))',
' (assert (nil? (host-get (host-global "window") "_t6got")))))))',
],
# socket E36: plain on message fires handler with raw event
"on message handler fires on incoming text message": [
' (hs-cleanup!)',
' (host-set! (host-global "globalThis") "__hs_ws_created" nil)',
' (host-set! (host-global "window") "_t7got" nil)',
' (let ((_el (dom-create-element "div")))',
' (dom-set-attr _el "_" "socket _T7Sock \\"/ws\\" on message set window._t7got to the event.data end")',
' (dom-append (dom-body) _el)',
' (hs-activate! _el)',
' (let ((_ws (host-get (host-get (host-global "globalThis") "__hs_ws_created") 0)))',
' (let ((_handler (host-get _ws "onmessage")))',
' (let ((_evt (host-new "Object")))',
' (host-set! _evt "data" "hello")',
' (host-call-fn _handler (list _evt))',
' (assert= (host-get (host-global "window") "_t7got") "hello")))))',
],
# socket E36: absolute ws:// URL passes through unchanged
"parses socket with absolute ws:// URL": [
' (hs-cleanup!)',
' (host-set! (host-global "globalThis") "__hs_ws_created" nil)',
' (let ((_el (dom-create-element "div")))',
' (dom-set-attr _el "_" "socket _T8Sock \\"ws://example.com/ws\\" end")',
' (dom-append (dom-body) _el)',
' (hs-activate! _el)',
' (let ((_created (host-get (host-global "globalThis") "__hs_ws_created")))',
' (assert= (host-get (host-get _created 0) "url") "ws://example.com/ws")))',
],
# socket E36: rpc proxy blacklists then/catch/length/toJSON
"rpc proxy blacklists then/catch/length/toJSON": [
' (hs-cleanup!)',
' (host-set! (host-global "globalThis") "__hs_ws_created" nil)',
' (let ((_el (dom-create-element "div")))',
' (dom-set-attr _el "_" "socket _T9Sock \\"ws://localhost/ws\\" end")',
' (dom-append (dom-body) _el)',
' (hs-activate! _el)',
' (let ((_rpc (host-get (host-get (host-global "window") "_T9Sock") "rpc")))',
' (do',
' (assert (nil? (host-get _rpc "then")))',
' (assert (nil? (host-get _rpc "catch")))',
' (assert (nil? (host-get _rpc "length")))',
' (assert (nil? (host-get _rpc "toJSON"))))))',
],
# socket E36: rpc default timeout (0ms) fires setTimeout → pending cleared
"rpc proxy default timeout rejects the promise": [
' (hs-cleanup!)',
' (host-set! (host-global "globalThis") "__hs_ws_created" nil)',
' (let ((_el (dom-create-element "div")))',
' (dom-set-attr _el "_" "socket _T10Sock \\"ws://localhost/ws\\" end")',
' (dom-append (dom-body) _el)',
' (hs-activate! _el)',
' (let ((_wrapper (host-get (host-global "window") "_T10Sock"))',
' (_ws (host-get (host-get (host-global "globalThis") "__hs_ws_created") 0))',
' (_orig-st (host-global "setTimeout")))',
' (do',
' (host-set! (host-global "globalThis") "setTimeout"',
' (host-callback (fn (thunk ms) (host-call-fn thunk (list)))))',
' (host-call-fn (host-get (host-get _wrapper "rpc") "greet") (list "world"))',
' (host-set! (host-global "globalThis") "setTimeout" _orig-st)',
' (let ((_sent-str (host-get (host-get _ws "_sent") 0)))',
' (let ((_iid (host-get (json-parse _sent-str) "iid")))',
' (assert (nil? (host-get (host-get _wrapper "_pending") _iid))))))))',
],
# socket E36: noTimeout proxy skips setTimeout entirely
"rpc proxy noTimeout avoids timeout rejection": [
' (hs-cleanup!)',
' (host-set! (host-global "globalThis") "__hs_ws_created" nil)',
' (let ((_el (dom-create-element "div")))',
' (dom-set-attr _el "_" "socket _T11Sock \\"ws://localhost/ws\\" end")',
' (dom-append (dom-body) _el)',
' (hs-activate! _el)',
' (let ((_wrapper (host-get (host-global "window") "_T11Sock"))',
' (_st-calls 0)',
' (_orig-st (host-global "setTimeout")))',
' (do',
' (host-set! (host-global "globalThis") "setTimeout"',
' (host-callback (fn (thunk ms) (set! _st-calls (+ _st-calls 1)))))',
' (let ((_no-timeout-proxy (host-get (host-get _wrapper "rpc") "noTimeout")))',
' (host-call-fn (host-get _no-timeout-proxy "greet") (list "world")))',
' (host-set! (host-global "globalThis") "setTimeout" _orig-st)',
' (assert= _st-calls 0))))',
],
# socket E36: onmessage with {iid,throw} clears pending entry (reject called)
"rpc proxy reply with throw rejects the promise": [
' (hs-cleanup!)',
' (host-set! (host-global "globalThis") "__hs_ws_created" nil)',
' (let ((_el (dom-create-element "div")))',
' (dom-set-attr _el "_" "socket _T12Sock \\"ws://localhost/ws\\" end")',
' (dom-append (dom-body) _el)',
' (hs-activate! _el)',
' (let ((_wrapper (host-get (host-global "window") "_T12Sock"))',
' (_ws (host-get (host-get (host-global "globalThis") "__hs_ws_created") 0)))',
' (do',
' (host-call-fn (host-get (host-get _wrapper "rpc") "greet") (list "world"))',
' (let ((_iid (host-get (json-parse (host-get (host-get _ws "_sent") 0)) "iid")))',
' (let ((_reply (host-new "Object")))',
' (host-set! _reply "iid" _iid)',
' (host-set! _reply "throw" "boom")',
' (let ((_handler (host-get _ws "onmessage")))',
' (let ((_evt (host-new "Object")))',
' (host-set! _evt "data" (host-call (host-global "JSON") "stringify" _reply))',
' (host-call-fn _handler (list _evt))',
' (assert (nil? (host-get (host-get _wrapper "_pending") _iid))))))))))',
],
# socket E36: rpc call sends {iid,function,args}; onmessage reply clears pending
"rpc proxy sends a message and resolves the reply": [
' (hs-cleanup!)',
' (host-set! (host-global "globalThis") "__hs_ws_created" nil)',
' (let ((_el (dom-create-element "div")))',
' (dom-set-attr _el "_" "socket _T13Sock \\"ws://localhost/ws\\" end")',
' (dom-append (dom-body) _el)',
' (hs-activate! _el)',
' (let ((_wrapper (host-get (host-global "window") "_T13Sock"))',
' (_ws (host-get (host-get (host-global "globalThis") "__hs_ws_created") 0)))',
' (do',
' (host-call-fn (host-get (host-get _wrapper "rpc") "greet") (list "world"))',
' (let ((_sent (json-parse (host-get (host-get _ws "_sent") 0))))',
' (do',
' (assert= (host-get _sent "function") "greet")',
' (let ((_iid (host-get _sent "iid")))',
' (let ((_reply (host-new "Object")))',
' (host-set! _reply "iid" _iid)',
' (host-set! _reply "return" "got it")',
' (let ((_handler (host-get _ws "onmessage")))',
' (let ((_evt (host-new "Object")))',
' (host-set! _evt "data" (host-call (host-global "JSON") "stringify" _reply))',
' (host-call-fn _handler (list _evt))',
' (assert (nil? (host-get (host-get _wrapper "_pending") _iid))))))))))))',
],
# socket E36: .timeout(n) proxy fires setTimeout with that delay → pending cleared
"rpc proxy timeout(n) rejects after a custom window": [
' (hs-cleanup!)',
' (host-set! (host-global "globalThis") "__hs_ws_created" nil)',
' (let ((_el (dom-create-element "div")))',
' (dom-set-attr _el "_" "socket _T14Sock \\"ws://localhost/ws\\" end")',
' (dom-append (dom-body) _el)',
' (hs-activate! _el)',
' (let ((_wrapper (host-get (host-global "window") "_T14Sock"))',
' (_ws (host-get (host-get (host-global "globalThis") "__hs_ws_created") 0))',
' (_orig-st (host-global "setTimeout")))',
' (do',
' (host-set! (host-global "globalThis") "setTimeout"',
' (host-callback (fn (thunk ms) (host-call-fn thunk (list)))))',
' (let ((_t100-fn (host-call-fn (host-get (host-get _wrapper "rpc") "timeout") (list 100))))',
' (host-call-fn (host-get _t100-fn "greet") (list "world")))',
' (host-set! (host-global "globalThis") "setTimeout" _orig-st)',
' (let ((_iid (host-get (json-parse (host-get (host-get _ws "_sent") 0)) "iid")))',
' (assert (nil? (host-get (host-get _wrapper "_pending") _iid)))))))',
],
# socket E36: after ws.close(), next RPC lazily creates new WebSocket
"rpc reconnects after the underlying socket closes": [
' (hs-cleanup!)',
' (host-set! (host-global "globalThis") "__hs_ws_created" nil)',
' (let ((_el (dom-create-element "div")))',
' (dom-set-attr _el "_" "socket _T15Sock \\"ws://localhost/ws\\" end")',
' (dom-append (dom-body) _el)',
' (hs-activate! _el)',
' (let ((_wrapper (host-get (host-global "window") "_T15Sock"))',
' (_ws (host-get (host-get (host-global "globalThis") "__hs_ws_created") 0)))',
' (do',
' (host-call _ws "close")',
' (host-call-fn (host-get (host-get _wrapper "rpc") "greet") (list "world"))',
' (let ((_created (host-get (host-global "globalThis") "__hs_ws_created")))',
' (assert= (host-get _created "length") 2)))))',
],
# socket E36: with timeout N sets wrapper._timeout to N
"with timeout parses and uses the configured timeout": [
' (hs-cleanup!)',
' (host-set! (host-global "globalThis") "__hs_ws_created" nil)',
' (let ((_el (dom-create-element "div")))',
' (dom-set-attr _el "_" "socket _T16Sock \\"ws://localhost/ws\\" with timeout 1500 end")',
' (dom-append (dom-body) _el)',
' (hs-activate! _el)',
' (let ((_wrapper (host-get (host-global "window") "_T16Sock")))',
' (assert= (host-get _wrapper "_timeout") 1500)))',
],
}