giles
689dae7d0c
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 43s
Clicking a blog link now fragment-swaps #content with URL push + working back
button, no full reload — the SX-htmx engine driving the same OCaml kernel the
server runs. Six bugs in the source-load + boost path, found by bisecting in
chromium, all fixed:
1. Import double-apply (sx_server.ml x2, sx_browser.ml): the import suspension
handlers computed `key = library_name_key lib_spec` then called
`library_loaded_p key` — but library_loaded_p applies library_name_key
itself, so it ran sx_to_list on a string and crashed ("Expected list, got
string"). Only unloaded libs suspend, so it only bit lazy imports. Pass the
spec, not the key.
2. Unloaded-import crash (spec/evaluator.sx + sx_ref.ml library_exports): an
import of a not-yet-loaded library returned nil exports, and bind-import-set
did (keys nil) -> crash. Return an empty dict so the import is a graceful
no-op (lazy symbol resolution covers real usage).
3. value_to_js missing Integer (sx_browser.ml): integers passed to host methods
were mishandled, so dom-query-all's (host-call node-list "item" i) ignored i
and returned node 0 for every index — every element aliased the first, so
only one link ever boosted. Add the Integer -> JS number case.
4. browser-same-origin? rejected relative URLs (browser.sx x2): it only did
(starts-with? url origin), so "/alpha/" was treated as cross-origin and
should-boost-link? refused every relative link. Accept scheme-less,
non-protocol-relative URLs.
5. dom-query-in undefined (orchestration.sx x2): the swap path called a function
that exists nowhere; it's just dom-query with a container arg.
6. Lazy-deps never loaded under source fallback (sx-platform.js): lazy symbol
resolution only fires on the VM GLOBAL_GET path, but source-loaded swap
callbacks run on the CEK and raise instead of lazy-loading, so the post-swap
hs-boot-subtree!/htmx-boot-subtree! were undefined and aborted URL push.
Preload the manifest's lazy-deps.
Verified: native host conformance 271/271; lib/host/playwright/spa-check 4/4
(boot, boost, fragment swap + URL push, back button) in real chromium against an
ephemeral durable host server.
258 lines
6.9 KiB
Plaintext
258 lines
6.9 KiB
Plaintext
(define-library
|
|
(sx browser)
|
|
(export
|
|
browser-location-href
|
|
browser-location-pathname
|
|
browser-location-origin
|
|
browser-same-origin?
|
|
url-pathname
|
|
browser-push-state
|
|
browser-replace-state
|
|
browser-reload
|
|
browser-navigate
|
|
local-storage-get
|
|
local-storage-set
|
|
local-storage-remove
|
|
set-timeout
|
|
set-interval
|
|
clear-timeout
|
|
clear-interval
|
|
request-animation-frame
|
|
fetch-request
|
|
new-abort-controller
|
|
controller-signal
|
|
controller-abort
|
|
promise-then
|
|
promise-resolve
|
|
promise-delayed
|
|
browser-confirm
|
|
browser-prompt
|
|
browser-media-matches?
|
|
json-parse
|
|
json-stringify
|
|
log-info
|
|
log-warn
|
|
console-log
|
|
now-ms
|
|
schedule-idle
|
|
set-cookie
|
|
get-cookie)
|
|
(begin
|
|
(define
|
|
browser-location-href
|
|
(fn () (host-get (host-get (dom-window) "location") "href")))
|
|
(define
|
|
browser-location-pathname
|
|
(fn () (host-get (host-get (dom-window) "location") "pathname")))
|
|
(define
|
|
browser-location-origin
|
|
(fn () (host-get (host-get (dom-window) "location") "origin")))
|
|
(define
|
|
browser-same-origin?
|
|
;; A relative URL (no scheme, not protocol-relative "//host") is same-origin
|
|
;; by definition; an absolute URL must start with our origin. The old check
|
|
;; only did the latter, so it wrongly rejected every relative link ("/x").
|
|
(fn (url) (or (starts-with? url (browser-location-origin)) (and (not (string-contains? url "://")) (not (starts-with? url "//"))))))
|
|
(define
|
|
url-pathname
|
|
(fn
|
|
(url)
|
|
(host-get (host-new "URL" url (browser-location-origin)) "pathname")))
|
|
(define
|
|
browser-push-state
|
|
(fn
|
|
(url-or-state title url)
|
|
(if
|
|
(nil? title)
|
|
(host-call
|
|
(host-get (dom-window) "history")
|
|
"pushState"
|
|
nil
|
|
""
|
|
url-or-state)
|
|
(host-call
|
|
(host-get (dom-window) "history")
|
|
"pushState"
|
|
url-or-state
|
|
title
|
|
url))))
|
|
(define
|
|
browser-replace-state
|
|
(fn
|
|
(url-or-state title url)
|
|
(if
|
|
(nil? title)
|
|
(host-call
|
|
(host-get (dom-window) "history")
|
|
"replaceState"
|
|
nil
|
|
""
|
|
url-or-state)
|
|
(host-call
|
|
(host-get (dom-window) "history")
|
|
"replaceState"
|
|
url-or-state
|
|
title
|
|
url))))
|
|
(define
|
|
browser-reload
|
|
(fn () (host-call (host-get (dom-window) "location") "reload")))
|
|
(define
|
|
browser-navigate
|
|
(fn (url) (host-set! (host-get (dom-window) "location") "href" url)))
|
|
(define
|
|
local-storage-get
|
|
(fn
|
|
(key)
|
|
(host-call (host-get (dom-window) "localStorage") "getItem" key)))
|
|
(define
|
|
local-storage-set
|
|
(fn
|
|
(key val)
|
|
(host-call (host-get (dom-window) "localStorage") "setItem" key val)))
|
|
(define
|
|
local-storage-remove
|
|
(fn
|
|
(key)
|
|
(host-call (host-get (dom-window) "localStorage") "removeItem" key)))
|
|
(define
|
|
set-timeout
|
|
(fn
|
|
(fn-val ms)
|
|
(host-call (dom-window) "setTimeout" (host-callback fn-val) ms)))
|
|
(define
|
|
set-interval
|
|
(fn
|
|
(fn-val ms)
|
|
(host-call (dom-window) "setInterval" (host-callback fn-val) ms)))
|
|
(define
|
|
clear-timeout
|
|
(fn (id) (host-call (dom-window) "clearTimeout" id)))
|
|
(define
|
|
clear-interval
|
|
(fn (id) (host-call (dom-window) "clearInterval" id)))
|
|
(define
|
|
request-animation-frame
|
|
(fn
|
|
(fn-val)
|
|
(host-call
|
|
(dom-window)
|
|
"requestAnimationFrame"
|
|
(host-callback fn-val))))
|
|
(define
|
|
fetch-request
|
|
(fn (url opts) (host-call (dom-window) "fetch" url opts)))
|
|
(define new-abort-controller (fn () (host-new "AbortController")))
|
|
(define
|
|
controller-signal
|
|
(fn (controller) (host-get controller "signal")))
|
|
(define
|
|
controller-abort
|
|
(fn (controller) (host-call controller "abort")))
|
|
(define
|
|
promise-then
|
|
(fn
|
|
(p on-resolve on-reject)
|
|
(let
|
|
((cb-resolve (host-callback on-resolve))
|
|
(cb-reject (if on-reject (host-callback on-reject) nil)))
|
|
(if
|
|
cb-reject
|
|
(host-call (host-call p "then" cb-resolve) "catch" cb-reject)
|
|
(host-call p "then" cb-resolve)))))
|
|
(define
|
|
promise-resolve
|
|
(fn (val) (host-call (host-global "Promise") "resolve" val)))
|
|
(define
|
|
promise-delayed
|
|
(fn
|
|
(ms val)
|
|
(host-new
|
|
"Promise"
|
|
(host-callback
|
|
(fn
|
|
(resolve)
|
|
(set-timeout (fn () (host-call resolve "call" nil val)) ms))))))
|
|
(define
|
|
browser-confirm
|
|
(fn (msg) (host-call (dom-window) "confirm" msg)))
|
|
(define
|
|
browser-prompt
|
|
(fn (msg default) (host-call (dom-window) "prompt" msg default)))
|
|
(define
|
|
browser-media-matches?
|
|
(fn
|
|
(query)
|
|
(host-get (host-call (dom-window) "matchMedia" query) "matches")))
|
|
(define json-parse (fn (s) (host-call (host-global "JSON") "parse" s)))
|
|
(define
|
|
log-info
|
|
(fn
|
|
(msg)
|
|
(host-call (host-global "console") "log" (str "[sx] " msg))))
|
|
(define
|
|
log-warn
|
|
(fn
|
|
(msg)
|
|
(host-call (host-global "console") "warn" (str "[sx] " msg))))
|
|
(define
|
|
console-log
|
|
(fn
|
|
(msg)
|
|
(host-call (host-global "console") "log" (str "[sx] " msg))))
|
|
(define now-ms (fn () (host-call (host-global "Date") "now")))
|
|
(define
|
|
schedule-idle
|
|
(fn
|
|
(f)
|
|
(let
|
|
((cb (host-callback (fn (_deadline) (f)))))
|
|
(if
|
|
(host-get (dom-window) "requestIdleCallback")
|
|
(host-call (dom-window) "requestIdleCallback" cb)
|
|
(set-timeout cb 0)))))
|
|
(define
|
|
set-cookie
|
|
(fn
|
|
(name value days)
|
|
(let
|
|
((d (or days 365))
|
|
(expires
|
|
(host-call
|
|
(host-new
|
|
"Date"
|
|
(+ (host-call (host-global "Date") "now") (* d 86400000)))
|
|
"toUTCString")))
|
|
(host-set!
|
|
(dom-document)
|
|
"cookie"
|
|
(str
|
|
name
|
|
"="
|
|
(host-call nil "encodeURIComponent" value)
|
|
";expires="
|
|
expires
|
|
";path=/;SameSite=Lax")))))
|
|
(define
|
|
get-cookie
|
|
(fn
|
|
(name)
|
|
(let
|
|
((cookies (host-get (dom-document) "cookie"))
|
|
(match
|
|
(host-call
|
|
cookies
|
|
"match"
|
|
(host-new "RegExp" (str "(?:^|;\\s*)" name "=([^;]*)")))))
|
|
(if
|
|
match
|
|
(host-call nil "decodeURIComponent" (host-get match 1))
|
|
nil))))))
|
|
|
|
;; Re-export to global env
|
|
(define
|
|
json-stringify
|
|
(fn (v) (host-call (host-global "JSON") "stringify" v)))
|
|
|
|
(import (sx browser))
|