giles
869f49bc01
- 7 new test files (~268 tests): stdlib, adapter-html, adapter-dom, boot-helpers, page-helpers, layout, tw-layout - Fix component-pure? transitive scan, render-target crash on unknown components, &rest param binding (String vs Symbol), swap! extra args - Fix 5 Playwright marshes tests: timing + test logic - 2522/2522 OCaml tests, 173/173 Playwright tests Co-Authored-By: Claude Opus 4.6 (1M context) <noreply@anthropic.com> # Conflicts: # shared/static/wasm/sx/orchestration.sxbc # shared/static/wasm/sx_browser.bc.js # shared/static/wasm/sx_browser.bc.wasm.js # sx/sx/not-found.sx # tests/playwright/isomorphic.spec.js
1569 lines
51 KiB
Plaintext
1569 lines
51 KiB
Plaintext
(define _preload-cache (dict))
|
|
|
|
(define
|
|
dispatch-trigger-events
|
|
:effects (mutation io)
|
|
(fn
|
|
(el (header-val :as string))
|
|
(when
|
|
header-val
|
|
(let
|
|
((parsed (try-parse-json header-val)))
|
|
(if
|
|
parsed
|
|
(for-each
|
|
(fn ((key :as string)) (dom-dispatch el key (get parsed key)))
|
|
(keys parsed))
|
|
(for-each
|
|
(fn
|
|
((name :as string))
|
|
(let
|
|
((trimmed (trim name)))
|
|
(when
|
|
(not (empty? trimmed))
|
|
(dom-dispatch el trimmed (dict)))))
|
|
(split header-val ",")))))))
|
|
|
|
(define
|
|
execute-request
|
|
:effects (mutation io)
|
|
(fn
|
|
(el (verbInfo :as dict) (extraParams :as dict))
|
|
(let
|
|
((info (or (get-verb-info el) verbInfo)))
|
|
(if
|
|
(nil? info)
|
|
(promise-resolve nil)
|
|
(let
|
|
((verb (get info "method")) (url (get info "url")))
|
|
(if
|
|
(let
|
|
((media (dom-get-attr el "sx-media")))
|
|
(and media (not (browser-media-matches? media))))
|
|
(promise-resolve nil)
|
|
(if
|
|
(let
|
|
((confirm-msg (dom-get-attr el "sx-confirm")))
|
|
(and confirm-msg (not (browser-confirm confirm-msg))))
|
|
(promise-resolve nil)
|
|
(let
|
|
((prompt-msg (dom-get-attr el "sx-prompt"))
|
|
(prompt-val
|
|
(if prompt-msg (browser-prompt prompt-msg) nil)))
|
|
(if
|
|
(and prompt-msg (nil? prompt-val))
|
|
(promise-resolve nil)
|
|
(if
|
|
(or
|
|
(nil? verb)
|
|
(nil? url)
|
|
(not (validate-for-request el)))
|
|
(promise-resolve nil)
|
|
(do-fetch
|
|
el
|
|
verb
|
|
verb
|
|
url
|
|
(if
|
|
prompt-val
|
|
(assoc
|
|
(or extraParams (dict))
|
|
"SX-Prompt"
|
|
prompt-val)
|
|
extraParams))))))))))))
|
|
|
|
(define
|
|
do-fetch
|
|
:effects (mutation io)
|
|
(fn
|
|
(el
|
|
(verb :as string)
|
|
(method :as string)
|
|
(url :as string)
|
|
(extraParams :as dict))
|
|
(let
|
|
((sync (dom-get-attr el "sx-sync")))
|
|
(when (= sync "replace") (abort-previous el))
|
|
(let
|
|
((target-el (resolve-target el)))
|
|
(when
|
|
(and target-el (not (identical? el target-el)))
|
|
(abort-previous-target target-el)))
|
|
(let
|
|
((ctrl (new-abort-controller)))
|
|
(track-controller el ctrl)
|
|
(let
|
|
((target-el (resolve-target el)))
|
|
(when target-el (track-controller-target target-el ctrl)))
|
|
(let
|
|
((body-info (build-request-body el method url))
|
|
(final-url (get body-info "url"))
|
|
(body (get body-info "body"))
|
|
(ct (get body-info "content-type"))
|
|
(headers (build-request-headers el (loaded-component-names)))
|
|
(csrf (csrf-token)))
|
|
(when
|
|
extraParams
|
|
(for-each
|
|
(fn
|
|
((k :as string))
|
|
(dict-set! headers k (get extraParams k)))
|
|
(keys extraParams)))
|
|
(when ct (dict-set! headers "Content-Type" ct))
|
|
(when csrf (dict-set! headers "X-CSRFToken" csrf))
|
|
(let
|
|
((cached (preload-cache-get _preload-cache final-url))
|
|
(optimistic-state (apply-optimistic el))
|
|
(indicator (show-indicator el))
|
|
(disabled-elts (disable-elements el)))
|
|
(dom-add-class el "sx-request")
|
|
(dom-set-attr el "aria-busy" "true")
|
|
(dom-dispatch
|
|
el
|
|
"sx:beforeRequest"
|
|
(dict "url" final-url "method" method))
|
|
(fetch-request
|
|
(dict
|
|
"url"
|
|
final-url
|
|
"method"
|
|
method
|
|
"headers"
|
|
headers
|
|
"body"
|
|
body
|
|
"signal"
|
|
(controller-signal ctrl)
|
|
"cross-origin"
|
|
(cross-origin? final-url)
|
|
"preloaded"
|
|
cached)
|
|
(fn
|
|
((resp-ok :as boolean)
|
|
(status :as number)
|
|
get-header
|
|
(text :as string))
|
|
(do
|
|
(clear-loading-state el indicator disabled-elts)
|
|
(revert-optimistic optimistic-state)
|
|
(if
|
|
(not resp-ok)
|
|
(do
|
|
(dom-dispatch
|
|
el
|
|
"sx:responseError"
|
|
(dict "status" status "text" text))
|
|
(if
|
|
(and text (> (len text) 0))
|
|
(handle-fetch-success
|
|
el
|
|
final-url
|
|
verb
|
|
extraParams
|
|
get-header
|
|
text)
|
|
(handle-retry el verb method final-url extraParams)))
|
|
(do
|
|
(dom-dispatch
|
|
el
|
|
"sx:afterRequest"
|
|
(dict "status" status))
|
|
(handle-fetch-success
|
|
el
|
|
final-url
|
|
verb
|
|
extraParams
|
|
get-header
|
|
text)))))
|
|
(fn
|
|
(err)
|
|
(do
|
|
(clear-loading-state el indicator disabled-elts)
|
|
(revert-optimistic optimistic-state)
|
|
(when
|
|
(not (abort-error? err))
|
|
(log-warn
|
|
(str "sx:fetch error " method " " final-url " — " err))
|
|
(dom-dispatch el "sx:requestError" (dict "error" err))))))))))))
|
|
|
|
(define
|
|
handle-fetch-success
|
|
:effects (mutation io)
|
|
(fn
|
|
(el
|
|
(url :as string)
|
|
(verb :as string)
|
|
(extraParams :as dict)
|
|
get-header
|
|
(text :as string))
|
|
(let
|
|
((resp-headers (process-response-headers get-header)))
|
|
(dispatch-trigger-events el (get resp-headers "trigger"))
|
|
(process-cache-directives el resp-headers text)
|
|
(cond
|
|
(get resp-headers "redirect")
|
|
(browser-navigate (get resp-headers "redirect"))
|
|
(get resp-headers "refresh")
|
|
(browser-reload)
|
|
(get resp-headers "location")
|
|
(fetch-location (get resp-headers "location"))
|
|
:else (let
|
|
((target-el (if (get resp-headers "retarget") (dom-query (get resp-headers "retarget")) (resolve-target el)))
|
|
(swap-spec
|
|
(parse-swap-spec
|
|
(or (get resp-headers "reswap") (dom-get-attr el "sx-swap"))
|
|
(dom-has-class? (dom-body) "sx-transitions")))
|
|
(swap-style (get swap-spec "style"))
|
|
(use-transition (get swap-spec "transition"))
|
|
(ct (or (get resp-headers "content-type") "")))
|
|
(if
|
|
(contains? ct "text/sx")
|
|
(handle-sx-response el target-el text swap-style use-transition)
|
|
(handle-html-response el target-el text swap-style use-transition))
|
|
(dispatch-trigger-events el (get resp-headers "trigger-swap"))
|
|
(handle-history el url resp-headers)
|
|
(set-timeout
|
|
(fn
|
|
()
|
|
(when
|
|
(get resp-headers "trigger-settle")
|
|
(dispatch-trigger-events
|
|
el
|
|
(get resp-headers "trigger-settle")))
|
|
(process-settle-hooks el))
|
|
20)
|
|
(dom-dispatch
|
|
el
|
|
"sx:afterSwap"
|
|
(dict "target" target-el "swap" swap-style)))))))
|
|
|
|
(define
|
|
flush-collected-styles
|
|
:effects (mutation io)
|
|
(fn
|
|
()
|
|
(let
|
|
((rules (collected "cssx")))
|
|
(when
|
|
(not (empty? rules))
|
|
(clear-collected! "cssx")
|
|
(let
|
|
((el (dom-create-element "style" nil)))
|
|
(dom-set-attr el "data-sx-css" "true")
|
|
(dom-set-prop el "textContent" (join "" rules))
|
|
(dom-append-to-head el))))))
|
|
|
|
(define
|
|
handle-sx-response
|
|
:effects (mutation io)
|
|
(fn
|
|
(el
|
|
target
|
|
(text :as string)
|
|
(swap-style :as string)
|
|
(use-transition :as boolean))
|
|
(let
|
|
((cleaned (strip-component-scripts text)))
|
|
(let
|
|
((final (extract-response-css cleaned)))
|
|
(let
|
|
((trimmed (trim final)))
|
|
(when
|
|
(not (empty? trimmed))
|
|
(let
|
|
((rendered (sx-render trimmed))
|
|
(container (dom-create-element "div" nil)))
|
|
(dom-append container rendered)
|
|
(process-oob-swaps
|
|
container
|
|
(fn
|
|
(t oob (s :as string))
|
|
(dispose-islands-in t)
|
|
(swap-dom-nodes
|
|
t
|
|
(if (= s "innerHTML") (children-to-fragment oob) oob)
|
|
s)
|
|
(post-swap t)))
|
|
(hoist-head-elements container)
|
|
(let
|
|
((select-sel (dom-get-attr el "sx-select")))
|
|
(let
|
|
((content (if select-sel (select-from-container container select-sel) (children-to-fragment container))))
|
|
(dispose-islands-in target)
|
|
(with-transition
|
|
use-transition
|
|
(fn
|
|
()
|
|
(let
|
|
((swap-result (swap-dom-nodes target content swap-style)))
|
|
(post-swap
|
|
(if
|
|
(= swap-style "outerHTML")
|
|
(dom-parent (or swap-result target))
|
|
(or swap-result target)))))))))))))))
|
|
|
|
(define
|
|
handle-html-response
|
|
:effects (mutation io)
|
|
(fn
|
|
(el
|
|
target
|
|
(text :as string)
|
|
(swap-style :as string)
|
|
(use-transition :as boolean))
|
|
(let
|
|
((doc (dom-parse-html-document text)))
|
|
(when
|
|
doc
|
|
(let
|
|
((select-sel (dom-get-attr el "sx-select")))
|
|
(dispose-islands-in target)
|
|
(if
|
|
select-sel
|
|
(let
|
|
((container (dom-create-element "div" nil)))
|
|
(dom-set-inner-html container (dom-body-inner-html doc))
|
|
(process-oob-swaps
|
|
container
|
|
(fn
|
|
(t oob (s :as string))
|
|
(dispose-islands-in t)
|
|
(swap-dom-nodes t oob s)
|
|
(post-swap t)))
|
|
(hoist-head-elements container)
|
|
(let
|
|
((html (select-from-container container select-sel)))
|
|
(with-transition
|
|
use-transition
|
|
(fn
|
|
()
|
|
(let
|
|
((swap-root (swap-dom-nodes target html swap-style)))
|
|
(log-info
|
|
(str
|
|
"swap-root: "
|
|
(if swap-root (dom-tag-name swap-root) "nil")
|
|
" target: "
|
|
(dom-tag-name target)))
|
|
(post-swap (or swap-root target)))))))
|
|
(let
|
|
((container (dom-create-element "div" nil)))
|
|
(dom-set-inner-html container (dom-body-inner-html doc))
|
|
(process-oob-swaps
|
|
container
|
|
(fn
|
|
(t oob (s :as string))
|
|
(dispose-islands-in t)
|
|
(swap-dom-nodes t oob s)
|
|
(post-swap t)))
|
|
(hoist-head-elements container)
|
|
(with-transition
|
|
use-transition
|
|
(fn
|
|
()
|
|
(swap-dom-nodes
|
|
target
|
|
(children-to-fragment container)
|
|
swap-style)
|
|
(post-swap target))))))))))
|
|
|
|
(define
|
|
handle-retry
|
|
:effects (mutation io)
|
|
(fn
|
|
(el
|
|
(verb :as string)
|
|
(method :as string)
|
|
(url :as string)
|
|
(extraParams :as dict))
|
|
(let
|
|
((retry-attr (dom-get-attr el "sx-retry"))
|
|
(spec (parse-retry-spec retry-attr)))
|
|
(when
|
|
spec
|
|
(let
|
|
((current-ms (or (dom-get-attr el "data-sx-retry-ms") (get spec "start-ms"))))
|
|
(let
|
|
((ms (parse-int current-ms (get spec "start-ms"))))
|
|
(dom-set-attr
|
|
el
|
|
"data-sx-retry-ms"
|
|
(str (next-retry-ms ms (get spec "cap-ms"))))
|
|
(set-timeout
|
|
(fn () (do-fetch el verb method url extraParams))
|
|
ms)))))))
|
|
|
|
(define
|
|
bind-triggers
|
|
:effects (mutation io)
|
|
(fn
|
|
(el (verbInfo :as dict))
|
|
(let
|
|
((triggers (or (parse-trigger-spec (dom-get-attr el "sx-trigger")) (default-trigger (dom-tag-name el)))))
|
|
(for-each
|
|
(fn
|
|
((trigger :as dict))
|
|
(let
|
|
((kind (classify-trigger trigger))
|
|
(mods (get trigger "modifiers")))
|
|
(cond
|
|
(= kind "poll")
|
|
(let
|
|
((interval-id nil))
|
|
(set!
|
|
interval-id
|
|
(set-interval
|
|
(fn
|
|
()
|
|
(if
|
|
(host-get el "isConnected")
|
|
(execute-request el nil nil)
|
|
(do
|
|
(clear-interval interval-id)
|
|
(log-info "poll stopped: element removed"))))
|
|
(get mods "interval"))))
|
|
(= kind "intersect")
|
|
(observe-intersection
|
|
el
|
|
(fn () (execute-request el nil nil))
|
|
true
|
|
(get mods "delay"))
|
|
(= kind "load")
|
|
(set-timeout
|
|
(fn () (execute-request el nil nil))
|
|
(or (get mods "delay") 0))
|
|
(= kind "revealed")
|
|
(observe-intersection
|
|
el
|
|
(fn () (execute-request el nil nil))
|
|
false
|
|
(get mods "delay"))
|
|
(= kind "event")
|
|
(bind-event el (get trigger "event") mods verbInfo))))
|
|
triggers))))
|
|
|
|
(define
|
|
bind-event
|
|
:effects (mutation io)
|
|
(fn
|
|
(el (event-name :as string) (mods :as dict) (verbInfo :as dict))
|
|
(let
|
|
((timer nil)
|
|
(last-val nil)
|
|
(listen-target
|
|
(let
|
|
((from-sel (get mods "from")))
|
|
(cond
|
|
(nil? from-sel)
|
|
el
|
|
(= from-sel "body")
|
|
(dom-body)
|
|
(= from-sel "document")
|
|
(dom-document)
|
|
(= from-sel "window")
|
|
(dom-window)
|
|
:else (dom-query from-sel)))))
|
|
(when
|
|
listen-target
|
|
(dom-add-listener
|
|
listen-target
|
|
event-name
|
|
(fn
|
|
(e)
|
|
(let
|
|
((should-fire (if (get mods "filter") (let ((f (get mods "filter"))) (let ((key-match (index-of f "key=='"))) (if (>= key-match 0) (let ((key-char (slice f (+ key-match 5) (+ key-match 6)))) (and (= (host-get e "key") key-char) (not (dom-matches? (host-get e "target") "input,textarea,select")))) true))) true)))
|
|
(when
|
|
(get mods "changed")
|
|
(let
|
|
((val element-value))
|
|
(if
|
|
(= val last-val)
|
|
(set! should-fire false)
|
|
(set! last-val val))))
|
|
(when
|
|
(and
|
|
should-fire
|
|
(not (and (= event-name "click") (event-modifier-key? e))))
|
|
(when
|
|
(or
|
|
(= event-name "submit")
|
|
(and (= event-name "click") (dom-has-attr? el "href")))
|
|
(prevent-default e))
|
|
(let
|
|
((live-info (get-verb-info el))
|
|
(is-get-link
|
|
(and
|
|
(= event-name "click")
|
|
(= (get live-info "method") "GET")
|
|
(dom-has-attr? el "href")
|
|
(not (get mods "delay"))))
|
|
(client-routed false))
|
|
(when
|
|
is-get-link
|
|
(set!
|
|
client-routed
|
|
(try-client-route
|
|
(url-pathname (get live-info "url"))
|
|
(dom-get-attr el "sx-target"))))
|
|
(if
|
|
client-routed
|
|
(do
|
|
(save-scroll-position)
|
|
(browser-push-state (get live-info "url"))
|
|
(browser-scroll-to 0 0))
|
|
(do
|
|
(when
|
|
is-get-link
|
|
(log-info
|
|
(str "sx:route server fetch " (get live-info "url"))))
|
|
(if
|
|
(get mods "delay")
|
|
(do
|
|
(clear-timeout timer)
|
|
(set!
|
|
timer
|
|
(set-timeout
|
|
(fn () (execute-request el nil nil))
|
|
(get mods "delay"))))
|
|
(execute-request el nil nil))))))))
|
|
(if (get mods "once") (dict "once" true) nil))))))
|
|
|
|
(define
|
|
post-swap
|
|
:effects (mutation io)
|
|
(fn
|
|
(root)
|
|
(log-info (str "post-swap: root=" (if root (dom-tag-name root) "nil")))
|
|
(activate-scripts root)
|
|
(sx-process-scripts root)
|
|
(sx-hydrate root)
|
|
(sx-hydrate-islands root)
|
|
(run-post-render-hooks)
|
|
(flush-collected-styles)
|
|
(process-elements root)))
|
|
|
|
(define
|
|
process-settle-hooks
|
|
:effects (mutation io)
|
|
(fn
|
|
(el)
|
|
(let
|
|
((settle-expr (dom-get-attr el "sx-on-settle")))
|
|
(when
|
|
(and settle-expr (not (empty? settle-expr)))
|
|
(let
|
|
((exprs (sx-parse settle-expr)))
|
|
(for-each (fn (expr) (cek-eval expr)) exprs))))))
|
|
|
|
(define
|
|
activate-scripts
|
|
:effects (mutation io)
|
|
(fn
|
|
(root)
|
|
(when
|
|
root
|
|
(let
|
|
((scripts (dom-query-all root "script")))
|
|
(for-each
|
|
(fn
|
|
(dead)
|
|
(when
|
|
(and
|
|
(not (dom-has-attr? dead "data-components"))
|
|
(not (dom-has-attr? dead "data-sx-activated")))
|
|
(let
|
|
((live (create-script-clone dead)))
|
|
(dom-set-attr live "data-sx-activated" "true")
|
|
(dom-replace-child (dom-parent dead) live dead))))
|
|
scripts)))))
|
|
|
|
(define
|
|
process-oob-swaps
|
|
:effects (mutation io)
|
|
(fn
|
|
(container (swap-fn :as lambda))
|
|
(let
|
|
((oobs (find-oob-swaps container)))
|
|
(for-each
|
|
(fn
|
|
((oob :as dict))
|
|
(let
|
|
((target-id (get oob "target-id"))
|
|
(target (dom-query-by-id target-id))
|
|
(oob-el (get oob "element"))
|
|
(swap-type (get oob "swap-type")))
|
|
(when
|
|
(dom-parent oob-el)
|
|
(dom-remove-child (dom-parent oob-el) oob-el))
|
|
(when target (swap-fn target oob-el swap-type))))
|
|
oobs))))
|
|
|
|
(define
|
|
hoist-head-elements
|
|
:effects (mutation io)
|
|
(fn
|
|
(container)
|
|
(for-each
|
|
(fn
|
|
(style)
|
|
(when
|
|
(dom-parent style)
|
|
(dom-remove-child (dom-parent style) style))
|
|
(dom-append-to-head style))
|
|
(dom-query-all container "style[data-sx-css]"))
|
|
(for-each
|
|
(fn
|
|
(link)
|
|
(when (dom-parent link) (dom-remove-child (dom-parent link) link))
|
|
(dom-append-to-head link))
|
|
(dom-query-all container "link[rel=\"stylesheet\"]"))))
|
|
|
|
(define
|
|
process-boosted
|
|
:effects (mutation io)
|
|
(fn
|
|
(root)
|
|
(for-each
|
|
(fn (container) (boost-descendants container))
|
|
(dom-query-all (or root (dom-body)) "[sx-boost]"))))
|
|
|
|
(define
|
|
boost-descendants
|
|
:effects (mutation io)
|
|
(fn
|
|
(container)
|
|
(let
|
|
((boost-target (dom-get-attr container "sx-boost")))
|
|
(for-each
|
|
(fn
|
|
(link)
|
|
(when
|
|
(and
|
|
(not (is-processed? link "boost"))
|
|
(should-boost-link? link))
|
|
(mark-processed! link "boost")
|
|
(when
|
|
(and
|
|
(not (dom-has-attr? link "sx-target"))
|
|
boost-target
|
|
(not (= boost-target "true")))
|
|
(dom-set-attr link "sx-target" boost-target))
|
|
(when
|
|
(not (dom-has-attr? link "sx-swap"))
|
|
(dom-set-attr link "sx-swap" "innerHTML"))
|
|
(when
|
|
(not (dom-has-attr? link "sx-push-url"))
|
|
(dom-set-attr link "sx-push-url" "true"))
|
|
(bind-client-route-link link (dom-get-attr link "href"))))
|
|
(dom-query-all container "a[href]"))
|
|
(for-each
|
|
(fn
|
|
(form)
|
|
(when
|
|
(and
|
|
(not (is-processed? form "boost"))
|
|
(should-boost-form? form))
|
|
(mark-processed! form "boost")
|
|
(let
|
|
((method (upper (or (dom-get-attr form "method") "GET")))
|
|
(action
|
|
(or (dom-get-attr form "action") (browser-location-href))))
|
|
(when
|
|
(and
|
|
(not (dom-has-attr? form "sx-target"))
|
|
boost-target
|
|
(not (= boost-target "true")))
|
|
(dom-set-attr form "sx-target" boost-target))
|
|
(when
|
|
(not (dom-has-attr? form "sx-swap"))
|
|
(dom-set-attr form "sx-swap" "innerHTML"))
|
|
(bind-boost-form form method action))))
|
|
(dom-query-all container "form")))))
|
|
|
|
(define _page-data-cache (dict))
|
|
|
|
(define _page-data-cache-ttl 30000)
|
|
|
|
(define
|
|
page-data-cache-key
|
|
:effects ()
|
|
(fn
|
|
((page-name :as string) (params :as dict))
|
|
(let
|
|
((base page-name))
|
|
(if
|
|
(or (nil? params) (empty? (keys params)))
|
|
base
|
|
(let
|
|
((parts (list)))
|
|
(for-each
|
|
(fn
|
|
((k :as string))
|
|
(append! parts (str k "=" (get params k))))
|
|
(keys params))
|
|
(str base ":" (join "&" parts)))))))
|
|
|
|
(define
|
|
page-data-cache-get
|
|
:effects (mutation io)
|
|
(fn
|
|
((cache-key :as string))
|
|
(let
|
|
((entry (get _page-data-cache cache-key)))
|
|
(if
|
|
(nil? entry)
|
|
nil
|
|
(if
|
|
(> (- (now-ms) (get entry "ts")) _page-data-cache-ttl)
|
|
(do (dict-set! _page-data-cache cache-key nil) nil)
|
|
(get entry "data"))))))
|
|
|
|
(define
|
|
page-data-cache-set
|
|
:effects (mutation io)
|
|
(fn
|
|
((cache-key :as string) data)
|
|
(dict-set! _page-data-cache cache-key {:data data :ts (now-ms)})))
|
|
|
|
(define
|
|
invalidate-page-cache
|
|
:effects (mutation io)
|
|
(fn
|
|
((page-name :as string))
|
|
(for-each
|
|
(fn
|
|
((k :as string))
|
|
(when
|
|
(or (= k page-name) (starts-with? k (str page-name ":")))
|
|
(dict-set! _page-data-cache k nil)))
|
|
(keys _page-data-cache))
|
|
(sw-post-message {:type "invalidate" :page page-name})
|
|
(log-info (str "sx:cache invalidate " page-name))))
|
|
|
|
(define
|
|
invalidate-all-page-cache
|
|
:effects (mutation io)
|
|
(fn
|
|
()
|
|
(set! _page-data-cache (dict))
|
|
(sw-post-message {:type "invalidate" :page "*"})
|
|
(log-info "sx:cache invalidate *")))
|
|
|
|
(define
|
|
update-page-cache
|
|
:effects (mutation io)
|
|
(fn
|
|
((page-name :as string) data)
|
|
(let
|
|
((cache-key (page-data-cache-key page-name (dict))))
|
|
(page-data-cache-set cache-key data)
|
|
(log-info (str "sx:cache update " page-name)))))
|
|
|
|
(define
|
|
process-cache-directives
|
|
:effects (mutation io)
|
|
(fn
|
|
(el (resp-headers :as dict) (response-text :as string))
|
|
(let
|
|
((el-invalidate (dom-get-attr el "sx-cache-invalidate")))
|
|
(when
|
|
el-invalidate
|
|
(if
|
|
(= el-invalidate "*")
|
|
(invalidate-all-page-cache)
|
|
(invalidate-page-cache el-invalidate))))
|
|
(let
|
|
((hdr-invalidate (get resp-headers "cache-invalidate")))
|
|
(when
|
|
hdr-invalidate
|
|
(if
|
|
(= hdr-invalidate "*")
|
|
(invalidate-all-page-cache)
|
|
(invalidate-page-cache hdr-invalidate))))
|
|
(let
|
|
((hdr-update (get resp-headers "cache-update")))
|
|
(when
|
|
hdr-update
|
|
(let
|
|
((data (parse-sx-data response-text)))
|
|
(when data (update-page-cache hdr-update data)))))))
|
|
|
|
(define _optimistic-snapshots (dict))
|
|
|
|
(define
|
|
optimistic-cache-update
|
|
:effects (mutation)
|
|
(fn
|
|
((cache-key :as string) (mutator :as lambda))
|
|
(let
|
|
((cached (page-data-cache-get cache-key)))
|
|
(when
|
|
cached
|
|
(let
|
|
((predicted (mutator cached)))
|
|
(dict-set! _optimistic-snapshots cache-key cached)
|
|
(page-data-cache-set cache-key predicted)
|
|
predicted)))))
|
|
|
|
(define
|
|
optimistic-cache-revert
|
|
:effects (mutation)
|
|
(fn
|
|
((cache-key :as string))
|
|
(let
|
|
((snapshot (get _optimistic-snapshots cache-key)))
|
|
(when
|
|
snapshot
|
|
(page-data-cache-set cache-key snapshot)
|
|
(dict-delete! _optimistic-snapshots cache-key)
|
|
snapshot))))
|
|
|
|
(define
|
|
optimistic-cache-confirm
|
|
:effects (mutation)
|
|
(fn
|
|
((cache-key :as string))
|
|
(dict-delete! _optimistic-snapshots cache-key)))
|
|
|
|
(define
|
|
submit-mutation
|
|
:effects (mutation io)
|
|
(fn
|
|
((page-name :as string)
|
|
(params :as dict)
|
|
(action-name :as string)
|
|
payload
|
|
(mutator-fn :as lambda)
|
|
(on-complete :as lambda))
|
|
(let
|
|
((cache-key (page-data-cache-key page-name params))
|
|
(predicted (optimistic-cache-update cache-key mutator-fn)))
|
|
(when predicted (try-rerender-page page-name params predicted))
|
|
(execute-action
|
|
action-name
|
|
payload
|
|
(fn
|
|
(result)
|
|
(when result (page-data-cache-set cache-key result))
|
|
(optimistic-cache-confirm cache-key)
|
|
(when result (try-rerender-page page-name params result))
|
|
(log-info (str "sx:optimistic confirmed " page-name))
|
|
(when on-complete (on-complete "confirmed")))
|
|
(fn
|
|
((error :as string))
|
|
(let
|
|
((reverted (optimistic-cache-revert cache-key)))
|
|
(when reverted (try-rerender-page page-name params reverted))
|
|
(log-warn (str "sx:optimistic reverted " page-name ": " error))
|
|
(when on-complete (on-complete "reverted"))))))))
|
|
|
|
(define _is-online true)
|
|
|
|
(define _offline-queue (list))
|
|
|
|
(define offline-is-online? :effects (io) (fn () _is-online))
|
|
|
|
(define
|
|
offline-set-online!
|
|
:effects (mutation)
|
|
(fn ((val :as boolean)) (set! _is-online val)))
|
|
|
|
(define
|
|
offline-queue-mutation
|
|
:effects (mutation io)
|
|
(fn
|
|
((action-name :as string)
|
|
payload
|
|
(page-name :as string)
|
|
(params :as dict)
|
|
(mutator-fn :as lambda))
|
|
(let
|
|
((cache-key (page-data-cache-key page-name params))
|
|
(entry
|
|
(dict
|
|
"action"
|
|
action-name
|
|
"payload"
|
|
payload
|
|
"page"
|
|
page-name
|
|
"params"
|
|
params
|
|
"timestamp"
|
|
(now-ms)
|
|
"status"
|
|
"pending")))
|
|
(append! _offline-queue entry)
|
|
(let
|
|
((predicted (optimistic-cache-update cache-key mutator-fn)))
|
|
(when predicted (try-rerender-page page-name params predicted)))
|
|
(log-info
|
|
(str
|
|
"sx:offline queued "
|
|
action-name
|
|
" ("
|
|
(len _offline-queue)
|
|
" pending)"))
|
|
entry)))
|
|
|
|
(define
|
|
offline-sync
|
|
:effects (mutation io)
|
|
(fn
|
|
()
|
|
(let
|
|
((pending (filter (fn ((e :as dict)) (= (get e "status") "pending")) _offline-queue)))
|
|
(when
|
|
(not (empty? pending))
|
|
(log-info (str "sx:offline syncing " (len pending) " mutations"))
|
|
(for-each
|
|
(fn
|
|
((entry :as dict))
|
|
(execute-action
|
|
(get entry "action")
|
|
(get entry "payload")
|
|
(fn
|
|
(result)
|
|
(dict-set! entry "status" "synced")
|
|
(log-info (str "sx:offline synced " (get entry "action"))))
|
|
(fn
|
|
((error :as string))
|
|
(dict-set! entry "status" "failed")
|
|
(log-warn
|
|
(str
|
|
"sx:offline sync failed "
|
|
(get entry "action")
|
|
": "
|
|
error)))))
|
|
pending)))))
|
|
|
|
(define
|
|
offline-pending-count
|
|
:effects (io)
|
|
(fn
|
|
()
|
|
(len
|
|
(filter
|
|
(fn ((e :as dict)) (= (get e "status") "pending"))
|
|
_offline-queue))))
|
|
|
|
(define
|
|
offline-aware-mutation
|
|
:effects (mutation io)
|
|
(fn
|
|
((page-name :as string)
|
|
(params :as dict)
|
|
(action-name :as string)
|
|
payload
|
|
(mutator-fn :as lambda)
|
|
(on-complete :as lambda))
|
|
(if
|
|
_is-online
|
|
(submit-mutation
|
|
page-name
|
|
params
|
|
action-name
|
|
payload
|
|
mutator-fn
|
|
on-complete)
|
|
(do
|
|
(offline-queue-mutation
|
|
action-name
|
|
payload
|
|
page-name
|
|
params
|
|
mutator-fn)
|
|
(when on-complete (on-complete "queued"))))))
|
|
|
|
(define
|
|
current-page-layout
|
|
:effects (io)
|
|
(fn
|
|
()
|
|
(let
|
|
((pathname (url-pathname (browser-location-href)))
|
|
(match (find-matching-route pathname _page-routes)))
|
|
(if (nil? match) "" (or (get match "layout") "")))))
|
|
|
|
(define
|
|
swap-rendered-content
|
|
:effects (mutation io)
|
|
(fn
|
|
(target rendered (pathname :as string))
|
|
(let
|
|
((container (dom-create-element "div" nil)))
|
|
(dom-append container rendered)
|
|
(process-oob-swaps
|
|
container
|
|
(fn
|
|
(t oob (s :as string))
|
|
(dispose-islands-in t)
|
|
(swap-dom-nodes
|
|
t
|
|
(if (= s "innerHTML") (children-to-fragment oob) oob)
|
|
s)
|
|
(post-swap t)))
|
|
(let
|
|
((target-id (dom-get-attr target "id")))
|
|
(let
|
|
((inner (if target-id (dom-query container (str "#" target-id)) nil)))
|
|
(let
|
|
((content (if inner (children-to-fragment inner) (children-to-fragment container))))
|
|
(dispose-islands-in target)
|
|
(dom-set-text-content target "")
|
|
(dom-append target content)
|
|
(hoist-head-elements-full target)
|
|
(process-elements target)
|
|
(sx-hydrate-elements target)
|
|
(sx-hydrate-islands target)
|
|
(run-post-render-hooks)
|
|
(dom-dispatch target "sx:clientRoute" (dict "pathname" pathname))
|
|
(log-info (str "sx:route client " pathname))))))))
|
|
|
|
(define
|
|
resolve-route-target
|
|
:effects (io)
|
|
(fn
|
|
((target-sel :as string))
|
|
(if
|
|
(and target-sel (not (= target-sel "true")))
|
|
(dom-query target-sel)
|
|
nil)))
|
|
|
|
(define
|
|
deps-satisfied?
|
|
:effects (io)
|
|
(fn
|
|
((match :as dict))
|
|
(let
|
|
((deps (get match "deps")) (loaded (loaded-component-names)))
|
|
(if
|
|
(or (nil? deps) (empty? deps))
|
|
true
|
|
(every? (fn ((dep :as string)) (contains? loaded dep)) deps)))))
|
|
|
|
(define
|
|
try-client-route
|
|
:effects (mutation io)
|
|
(fn
|
|
((pathname :as string) (target-sel :as string))
|
|
(let
|
|
((match (find-matching-route pathname _page-routes)))
|
|
(if
|
|
(nil? match)
|
|
(do
|
|
(log-info
|
|
(str
|
|
"sx:route no match ("
|
|
(len _page-routes)
|
|
" routes) "
|
|
pathname))
|
|
false)
|
|
(let
|
|
((target-layout (or (get match "layout") ""))
|
|
(cur-layout (current-page-layout)))
|
|
(if
|
|
(not (= target-layout cur-layout))
|
|
(do
|
|
(log-info
|
|
(str
|
|
"sx:route server (layout: "
|
|
cur-layout
|
|
" -> "
|
|
target-layout
|
|
") "
|
|
pathname))
|
|
false)
|
|
(let
|
|
((content-src (get match "content"))
|
|
(closure (or (get match "closure") {}))
|
|
(params (get match "params"))
|
|
(page-name (get match "name")))
|
|
(if
|
|
(or (nil? content-src) (empty? content-src))
|
|
(do
|
|
(log-warn (str "sx:route no content for " pathname))
|
|
false)
|
|
(let
|
|
((target (resolve-route-target target-sel)))
|
|
(if
|
|
(nil? target)
|
|
(do
|
|
(log-warn
|
|
(str "sx:route target not found: " target-sel))
|
|
false)
|
|
(if
|
|
(not (deps-satisfied? match))
|
|
(do
|
|
(log-info (str "sx:route deps miss for " page-name))
|
|
false)
|
|
(let
|
|
((io-deps (get match "io-deps"))
|
|
(has-io (and io-deps (not (empty? io-deps))))
|
|
(render-plan (get match "render-plan")))
|
|
(when
|
|
render-plan
|
|
(let
|
|
((srv (or (get render-plan "server") (list)))
|
|
(cli (or (get render-plan "client") (list))))
|
|
(log-info
|
|
(str
|
|
"sx:route plan "
|
|
page-name
|
|
" — "
|
|
(len srv)
|
|
" server, "
|
|
(len cli)
|
|
" client"))))
|
|
(when has-io (register-io-deps io-deps))
|
|
(if
|
|
(get match "stream")
|
|
(do
|
|
(log-info (str "sx:route streaming " pathname))
|
|
(fetch-streaming
|
|
target
|
|
pathname
|
|
(build-request-headers
|
|
target
|
|
(loaded-component-names)))
|
|
true)
|
|
(if
|
|
(get match "has-data")
|
|
(let
|
|
((cache-key (page-data-cache-key page-name params))
|
|
(cached (page-data-cache-get cache-key)))
|
|
(if
|
|
cached
|
|
(let
|
|
((env (merge closure params cached)))
|
|
(if
|
|
has-io
|
|
(do
|
|
(log-info
|
|
(str
|
|
"sx:route client+cache+async "
|
|
pathname))
|
|
(try-async-eval-content
|
|
content-src
|
|
env
|
|
(fn
|
|
(rendered)
|
|
(if
|
|
(nil? rendered)
|
|
(do
|
|
(log-warn
|
|
(str
|
|
"sx:route cache+async eval failed for "
|
|
pathname
|
|
" — server fallback"))
|
|
(fetch-and-restore
|
|
target
|
|
pathname
|
|
(build-request-headers
|
|
target
|
|
(loaded-component-names))
|
|
0))
|
|
(swap-rendered-content
|
|
target
|
|
rendered
|
|
pathname))))
|
|
true)
|
|
(let
|
|
((rendered (try-eval-content content-src env)))
|
|
(if
|
|
(nil? rendered)
|
|
(do
|
|
(log-warn
|
|
(str
|
|
"sx:route cached eval failed for "
|
|
pathname))
|
|
false)
|
|
(do
|
|
(log-info
|
|
(str
|
|
"sx:route client+cache "
|
|
pathname))
|
|
(swap-rendered-content
|
|
target
|
|
rendered
|
|
pathname)
|
|
true)))))
|
|
(do
|
|
(log-info
|
|
(str "sx:route client+data " pathname))
|
|
(resolve-page-data
|
|
page-name
|
|
params
|
|
(fn
|
|
((data :as dict))
|
|
(page-data-cache-set cache-key data)
|
|
(let
|
|
((env (merge closure params data)))
|
|
(if
|
|
has-io
|
|
(try-async-eval-content
|
|
content-src
|
|
env
|
|
(fn
|
|
(rendered)
|
|
(if
|
|
(nil? rendered)
|
|
(do
|
|
(log-warn
|
|
(str
|
|
"sx:route data+async eval failed for "
|
|
pathname
|
|
" — server fallback"))
|
|
(fetch-and-restore
|
|
target
|
|
pathname
|
|
(build-request-headers
|
|
target
|
|
(loaded-component-names))
|
|
0))
|
|
(swap-rendered-content
|
|
target
|
|
rendered
|
|
pathname))))
|
|
(let
|
|
((rendered (try-eval-content content-src env)))
|
|
(if
|
|
(nil? rendered)
|
|
(do
|
|
(log-warn
|
|
(str
|
|
"sx:route data eval failed for "
|
|
pathname
|
|
" — server fallback"))
|
|
(fetch-and-restore
|
|
target
|
|
pathname
|
|
(build-request-headers
|
|
target
|
|
(loaded-component-names))
|
|
0))
|
|
(swap-rendered-content
|
|
target
|
|
rendered
|
|
pathname)))))))
|
|
true)))
|
|
(if
|
|
has-io
|
|
(do
|
|
(log-info
|
|
(str "sx:route client+async " pathname))
|
|
(try-async-eval-content
|
|
content-src
|
|
(merge closure params)
|
|
(fn
|
|
(rendered)
|
|
(if
|
|
(nil? rendered)
|
|
(do
|
|
(log-warn
|
|
(str
|
|
"sx:route async eval failed for "
|
|
pathname
|
|
" — server fallback"))
|
|
(fetch-and-restore
|
|
target
|
|
pathname
|
|
(build-request-headers
|
|
target
|
|
(loaded-component-names))
|
|
0))
|
|
(swap-rendered-content
|
|
target
|
|
rendered
|
|
pathname))))
|
|
true)
|
|
(let
|
|
((env (merge closure params))
|
|
(rendered
|
|
(try-eval-content content-src env)))
|
|
(if
|
|
(nil? rendered)
|
|
(do
|
|
(log-info
|
|
(str
|
|
"sx:route server (eval failed) "
|
|
pathname))
|
|
false)
|
|
(do
|
|
(swap-rendered-content
|
|
target
|
|
rendered
|
|
pathname)
|
|
true))))))))))))))))))
|
|
|
|
(define
|
|
bind-client-route-link
|
|
:effects (mutation io)
|
|
(fn
|
|
(link (href :as string))
|
|
(bind-client-route-click link href (fn () (bind-boost-link link href)))))
|
|
|
|
(define
|
|
process-sse
|
|
:effects (mutation io)
|
|
(fn
|
|
(root)
|
|
(for-each
|
|
(fn
|
|
(el)
|
|
(when
|
|
(not (is-processed? el "sse"))
|
|
(mark-processed! el "sse")
|
|
(bind-sse el)))
|
|
(dom-query-all (or root (dom-body)) "[sx-sse]"))))
|
|
|
|
(define
|
|
bind-sse
|
|
:effects (mutation io)
|
|
(fn
|
|
(el)
|
|
(let
|
|
((url (dom-get-attr el "sx-sse")))
|
|
(when
|
|
url
|
|
(let
|
|
((source (event-source-connect url el))
|
|
(event-name (parse-sse-swap el)))
|
|
(event-source-listen
|
|
source
|
|
event-name
|
|
(fn ((data :as string)) (bind-sse-swap el data))))))))
|
|
|
|
(define
|
|
bind-sse-swap
|
|
:effects (mutation io)
|
|
(fn
|
|
(el (data :as string))
|
|
(let
|
|
((target (resolve-target el))
|
|
(swap-spec
|
|
(parse-swap-spec
|
|
(dom-get-attr el "sx-swap")
|
|
(dom-has-class? (dom-body) "sx-transitions")))
|
|
(swap-style (get swap-spec "style"))
|
|
(use-transition (get swap-spec "transition"))
|
|
(trimmed (trim data)))
|
|
(when
|
|
(not (empty? trimmed))
|
|
(dispose-islands-in target)
|
|
(if
|
|
(starts-with? trimmed "(")
|
|
(let
|
|
((rendered (sx-render trimmed))
|
|
(container (dom-create-element "div" nil)))
|
|
(dom-append container rendered)
|
|
(with-transition
|
|
use-transition
|
|
(fn
|
|
()
|
|
(swap-dom-nodes
|
|
target
|
|
(children-to-fragment container)
|
|
swap-style)
|
|
(post-swap target))))
|
|
(with-transition
|
|
use-transition
|
|
(fn
|
|
()
|
|
(swap-html-string target trimmed swap-style)
|
|
(post-swap target))))))))
|
|
|
|
(define
|
|
bind-inline-handlers
|
|
:effects (mutation io)
|
|
(fn
|
|
(root)
|
|
(for-each
|
|
(fn
|
|
(el)
|
|
(for-each
|
|
(fn
|
|
((attr :as list))
|
|
(let
|
|
((name (first attr)) (body (nth attr 1)))
|
|
(when
|
|
(starts-with? name "sx-on:")
|
|
(let
|
|
((event-name (let ((raw (slice name 6))) (if (or (starts-with? raw "after") (starts-with? raw "before")) (str "sx:" raw) raw))))
|
|
(when
|
|
(not (is-processed? el (str "on:" event-name)))
|
|
(mark-processed! el (str "on:" event-name))
|
|
(dom-on
|
|
el
|
|
event-name
|
|
(if
|
|
(contains? body ".")
|
|
(fn
|
|
(e)
|
|
(host-call
|
|
(host-call (dom-window) "Function" "event" body)
|
|
"call"
|
|
el
|
|
e))
|
|
(let
|
|
((exprs (parse body)))
|
|
(fn
|
|
(e)
|
|
(let
|
|
((handler-env (make-env)))
|
|
(env-bind! handler-env "event" e)
|
|
(env-bind! handler-env "this" el)
|
|
(env-bind!
|
|
handler-env
|
|
"detail"
|
|
(event-detail e))
|
|
(for-each
|
|
(fn (expr) (eval-expr expr handler-env))
|
|
exprs)))))))))))
|
|
(dom-attr-list el)))
|
|
(dom-query-all (or root (dom-body)) "[sx-on\\:]"))))
|
|
|
|
(define
|
|
bind-preload-for
|
|
:effects (mutation io)
|
|
(fn
|
|
(el)
|
|
(let
|
|
((preload-attr (dom-get-attr el "sx-preload")))
|
|
(when
|
|
preload-attr
|
|
(let
|
|
((events (if (= preload-attr "mousedown") (list "mousedown" "touchstart") (list "mouseover")))
|
|
(debounce-ms (if (= preload-attr "mousedown") 0 100)))
|
|
(bind-preload
|
|
el
|
|
events
|
|
debounce-ms
|
|
(fn
|
|
()
|
|
(let
|
|
((info (get-verb-info el)))
|
|
(when
|
|
info
|
|
(do-preload
|
|
(get info "url")
|
|
(build-request-headers el (loaded-component-names))))))))))))
|
|
|
|
(define
|
|
do-preload
|
|
:effects (mutation io)
|
|
(fn
|
|
((url :as string) (headers :as dict))
|
|
(when
|
|
(nil? (preload-cache-get _preload-cache url))
|
|
(fetch-preload url headers _preload-cache))))
|
|
|
|
(define
|
|
VERB_SELECTOR
|
|
(str "[sx-get],[sx-post],[sx-put],[sx-delete],[sx-patch]"))
|
|
|
|
(define
|
|
process-elements
|
|
:effects (mutation io)
|
|
(fn
|
|
(root)
|
|
(let
|
|
((els (dom-query-all (or root (dom-body)) VERB_SELECTOR)))
|
|
(for-each
|
|
(fn
|
|
(el)
|
|
(when
|
|
(not (is-processed? el "verb"))
|
|
(process-one el)
|
|
(mark-processed! el "verb")))
|
|
els))
|
|
(process-boosted root)
|
|
(process-sse root)
|
|
(bind-inline-handlers root)
|
|
(process-emit-elements root)))
|
|
|
|
(define
|
|
process-one
|
|
:effects (mutation io)
|
|
(fn
|
|
(el)
|
|
(let
|
|
((verb-info (get-verb-info el)))
|
|
(when
|
|
verb-info
|
|
(when
|
|
(not (dom-has-attr? el "sx-disable"))
|
|
(do (bind-triggers el verb-info) (bind-preload-for el))
|
|
(bind-preload-for el))))))
|
|
|
|
(define
|
|
process-emit-elements
|
|
:effects (mutation io)
|
|
(fn
|
|
(root)
|
|
(let
|
|
((els (dom-query-all (or root (dom-body)) "[data-sx-emit]")))
|
|
(for-each
|
|
(fn
|
|
(el)
|
|
(when
|
|
(not (is-processed? el "emit"))
|
|
(mark-processed! el "emit")
|
|
(let
|
|
((event-name (dom-get-attr el "data-sx-emit")))
|
|
(when
|
|
event-name
|
|
(dom-on
|
|
el
|
|
"click"
|
|
(fn
|
|
(e)
|
|
(let
|
|
((detail-json (dom-get-attr el "data-sx-emit-detail"))
|
|
(detail
|
|
(if detail-json (json-parse detail-json) (dict))))
|
|
(dom-dispatch el event-name detail))))))))
|
|
els))))
|
|
|
|
(define
|
|
save-scroll-position
|
|
:effects (io)
|
|
(fn
|
|
()
|
|
(let
|
|
((scrollY (host-get (dom-window) "scrollY")))
|
|
(browser-replace-state
|
|
(dict "scrollY" scrollY)
|
|
""
|
|
(browser-location-href)))))
|
|
|
|
(define
|
|
handle-popstate
|
|
:effects (mutation io)
|
|
(fn
|
|
(scrollY)
|
|
(let
|
|
((url (browser-location-href))
|
|
(boost-el (dom-query "[sx-boost]"))
|
|
(target-sel
|
|
(if
|
|
boost-el
|
|
(let
|
|
((attr (dom-get-attr boost-el "sx-boost")))
|
|
(if (and attr (not (= attr "true"))) attr "#sx-content"))
|
|
"#sx-content"))
|
|
(target (dom-query target-sel))
|
|
(pathname (url-pathname url)))
|
|
(when
|
|
target
|
|
(let
|
|
((headers (dict "SX-Request" "true")))
|
|
(fetch-and-restore target url headers scrollY))))))
|
|
|
|
(define
|
|
engine-init
|
|
:effects (mutation io)
|
|
(fn
|
|
()
|
|
(do (sx-process-scripts nil) (sx-hydrate nil) (process-elements nil))))
|