rose-ash/web/engine.sx

(define ENGINE_VERBS (list "get" "post" "put" "delete" "patch"))

(define DEFAULT_SWAP "outerHTML")

(define
  parse-time
  :effects ()
  (fn
    ((s :as string))
    (if
      (nil? s)
      0
      (if
        (ends-with? s "ms")
        (parse-int s 0)
        (if
          (ends-with? s "s")
          (* (parse-int (replace s "s" "") 0) 1000)
          (parse-int s 0))))))

(define
  parse-trigger-spec
  :effects ()
  (fn
    ((spec :as string))
    (if
      (nil? spec)
      nil
      (let
        ((raw-parts (split spec ",")))
        (filter
          (fn (x) (not (nil? x)))
          (map
            (fn
              ((part :as string))
              (let
                ((tokens (split (trim part) " ")))
                (if
                  (empty? tokens)
                  nil
                  (if
                    (and (= (first tokens) "every") (>= (len tokens) 2))
                    (dict
                      "event"
                      "every"
                      "modifiers"
                      (dict "interval" (parse-time (nth tokens 1))))
                    (let
                      ((mods (dict)))
                      (for-each
                        (fn
                          ((tok :as string))
                          (cond
                            (= tok "once")
                            (dict-set! mods "once" true)
                            (= tok "changed")
                            (dict-set! mods "changed" true)
                            (starts-with? tok "delay:")
                            (dict-set!
                              mods
                              "delay"
                              (parse-time (slice tok 6)))
                            (starts-with? tok "from:")
                            (dict-set! mods "from" (slice tok 5))))
                        (rest tokens))
                      (let
                        ((raw-event (first tokens)))
                        (let
                          ((bracket-idx (index-of raw-event "[")))
                          (if
                            (>= bracket-idx 0)
                            (do
                              (dict-set!
                                mods
                                "filter"
                                (slice
                                  raw-event
                                  (+ bracket-idx 1)
                                  (- (len raw-event) 1)))
                              (dict
                                "event"
                                (slice raw-event 0 bracket-idx)
                                "modifiers"
                                mods))
                            (dict "event" raw-event "modifiers" mods)))))))))
            raw-parts))))))

(define
  default-trigger
  :effects ()
  (fn
    ((tag-name :as string))
    (cond
      (= tag-name "form")
      (list (dict "event" "submit" "modifiers" (dict)))
      (or
        (= tag-name "input")
        (= tag-name "select")
        (= tag-name "textarea"))
      (list (dict "event" "change" "modifiers" (dict)))
      :else (list (dict "event" "click" "modifiers" (dict))))))

(define
  get-verb-info
  :effects (io)
  (fn
    (el)
    (some
      (fn
        (verb)
        (let
          ((url (dom-get-attr el (str "sx-" verb))))
          (if url (dict "method" (upper verb) "url" url) nil)))
      ENGINE_VERBS)))

(define
  build-request-headers
  :effects (io)
  (fn
    (el (loaded-components :as list))
    (let
      ((headers (dict "SX-Request" "true" "SX-Current-URL" (browser-location-href))))
      (let
        ((target-sel (dom-get-attr el "sx-target")))
        (when target-sel (dict-set! headers "SX-Target" target-sel)))
      (let
        ((comp-hash (dom-get-attr (dom-query "script[data-components][data-hash]") "data-hash")))
        (when comp-hash (dict-set! headers "SX-Components-Hash" comp-hash)))
      (let
        ((extra-h (dom-get-attr el "sx-headers")))
        (when
          extra-h
          (let
            ((parsed (parse-header-value extra-h)))
            (when
              parsed
              (for-each
                (fn
                  ((key :as string))
                  (dict-set! headers key (str (get parsed key))))
                (keys parsed))))))
      headers)))

(define
  process-response-headers
  :effects ()
  (fn
    ((get-header :as lambda))
    (dict
      "redirect"
      (get-header "SX-Redirect")
      "refresh"
      (get-header "SX-Refresh")
      "trigger"
      (get-header "SX-Trigger")
      "retarget"
      (get-header "SX-Retarget")
      "reswap"
      (get-header "SX-Reswap")
      "location"
      (get-header "SX-Location")
      "replace-url"
      (get-header "SX-Replace-Url")
      "trigger-swap"
      (get-header "SX-Trigger-After-Swap")
      "trigger-settle"
      (get-header "SX-Trigger-After-Settle")
      "content-type"
      (get-header "Content-Type")
      "cache-invalidate"
      (get-header "SX-Cache-Invalidate")
      "cache-update"
      (get-header "SX-Cache-Update"))))

(define
  parse-swap-spec
  :effects ()
  (fn
    ((raw-swap :as string) (global-transitions? :as boolean))
    (let
      ((parts (split (or raw-swap DEFAULT_SWAP) " "))
        (style (first parts))
        (use-transition global-transitions?))
      (for-each
        (fn
          ((p :as string))
          (cond
            (= p "transition:true")
            (set! use-transition true)
            (= p "transition:false")
            (set! use-transition false)))
        (rest parts))
      (dict "style" style "transition" use-transition))))

(define
  parse-retry-spec
  :effects ()
  (fn
    ((retry-attr :as string))
    (if
      (nil? retry-attr)
      nil
      (let
        ((parts (split retry-attr ":")))
        (dict
          "strategy"
          (first parts)
          "start-ms"
          (parse-int (nth parts 1) 1000)
          "cap-ms"
          (parse-int (nth parts 2) 30000))))))

(define
  next-retry-ms
  :effects ()
  (fn
    ((current-ms :as number) (cap-ms :as number))
    (min (* current-ms 2) cap-ms)))

(define
  filter-params
  :effects ()
  (fn
    ((params-spec :as string) (all-params :as list))
    (if
      (nil? params-spec)
      all-params
      (if
        (= params-spec "none")
        (list)
        (if
          (= params-spec "*")
          all-params
          (if
            (starts-with? params-spec "not ")
            (let
              ((excluded (map trim (split (slice params-spec 4) ","))))
              (filter
                (fn ((p :as list)) (not (contains? excluded (first p))))
                all-params))
            (let
              ((allowed (map trim (split params-spec ","))))
              (filter
                (fn ((p :as list)) (contains? allowed (first p)))
                all-params))))))))

(define
  resolve-target
  :effects (io)
  (fn
    (el)
    (let
      ((sel (dom-get-attr el "sx-target")))
      (cond
        (or (nil? sel) (= sel "this"))
        el
        (= sel "closest")
        (dom-parent el)
        :else (dom-query sel)))))

(define
  apply-optimistic
  :effects (mutation io)
  (fn
    (el)
    (let
      ((directive (dom-get-attr el "sx-optimistic")))
      (if
        (nil? directive)
        nil
        (let
          ((target (or (resolve-target el) el))
            (state (dict "target" target "directive" directive)))
          (cond
            (= directive "remove")
            (do
              (dict-set! state "opacity" (dom-get-style target "opacity"))
              (dom-set-style target "opacity" "0")
              (dom-set-style target "pointer-events" "none"))
            (= directive "disable")
            (do
              (dict-set! state "disabled" (dom-get-prop target "disabled"))
              (dom-set-prop target "disabled" true))
            (starts-with? directive "add-class:")
            (let
              ((cls (slice directive 10)))
              (dict-set! state "add-class" cls)
              (dom-add-class target cls)))
          state)))))

(define
  revert-optimistic
  :effects (mutation io)
  (fn
    ((state :as dict))
    (when
      state
      (let
        ((target (get state "target")) (directive (get state "directive")))
        (cond
          (= directive "remove")
          (do
            (dom-set-style target "opacity" (or (get state "opacity") ""))
            (dom-set-style target "pointer-events" ""))
          (= directive "disable")
          (dom-set-prop target "disabled" (or (get state "disabled") false))
          (get state "add-class")
          (dom-remove-class target (get state "add-class")))))))

(define
  find-oob-swaps
  :effects (mutation io)
  (fn
    (container)
    (let
      ((results (list)))
      (for-each
        (fn
          ((attr :as string))
          (let
            ((oob-els (dom-query-all container (str "[" attr "]"))))
            (for-each
              (fn
                (oob)
                (let
                  ((swap-type (or (dom-get-attr oob attr) "outerHTML"))
                    (target-id (dom-id oob)))
                  (dom-remove-attr oob attr)
                  (when
                    target-id
                    (append!
                      results
                      (dict
                        "element"
                        oob
                        "swap-type"
                        swap-type
                        "target-id"
                        target-id)))))
              oob-els)))
        (list "sx-swap-oob" "hx-swap-oob"))
      results)))

(define
  morph-node
  :effects (mutation io)
  (fn
    (old-node new-node)
    (cond
      (or
        (dom-has-attr? old-node "sx-preserve")
        (dom-has-attr? old-node "sx-ignore"))
      nil
      (and
        (dom-has-attr? old-node "data-sx-island")
        (is-processed? old-node "island-hydrated")
        (dom-has-attr? new-node "data-sx-island")
        (=
          (dom-get-attr old-node "data-sx-island")
          (dom-get-attr new-node "data-sx-island")))
      (let
        ((old-state (dom-get-attr old-node "data-sx-state"))
          (new-state (dom-get-attr new-node "data-sx-state")))
        (sync-attrs old-node new-node)
        (if
          (and new-state (not (= old-state new-state)))
          (do (dispose-island old-node) (hydrate-island old-node))
          (morph-island-children old-node new-node)))
      (or
        (not (= (dom-node-type old-node) (dom-node-type new-node)))
        (not (= (dom-node-name old-node) (dom-node-name new-node))))
      (dom-replace-child
        (dom-parent old-node)
        (dom-clone new-node true)
        old-node)
      (or (= (dom-node-type old-node) 3) (= (dom-node-type old-node) 8))
      (when
        (not (= (dom-text-content old-node) (dom-text-content new-node)))
        (dom-set-text-content old-node (dom-text-content new-node)))
      (= (dom-node-type old-node) 1)
      (do
        (when
          (and
            (dom-has-attr? old-node "data-sx-island")
            (dom-has-attr? new-node "data-sx-island")
            (not
              (=
                (dom-get-attr old-node "data-sx-island")
                (dom-get-attr new-node "data-sx-island"))))
          (dispose-island old-node)
          (dispose-islands-in old-node))
        (sync-attrs old-node new-node)
        (when
          (not
            (and
              (dom-is-active-element? old-node)
              (dom-is-input-element? old-node)))
          (morph-children old-node new-node))))))

(define
  sync-attrs
  :effects (mutation io)
  (fn
    (old-el new-el)
    (let
      ((ra-str (or (dom-get-attr old-el "data-sx-reactive-attrs") ""))
        (reactive-attrs (if (empty? ra-str) (list) (split ra-str ","))))
      (for-each
        (fn
          ((attr :as list))
          (let
            ((name (first attr)) (val (nth attr 1)))
            (when
              (and
                (not (= (dom-get-attr old-el name) val))
                (not (contains? reactive-attrs name)))
              (dom-set-attr old-el name val))))
        (dom-attr-list new-el))
      (for-each
        (fn
          ((attr :as list))
          (let
            ((aname (first attr)))
            (when
              (and
                (not (dom-has-attr? new-el aname))
                (not (contains? reactive-attrs aname))
                (not (= aname "data-sx-reactive-attrs")))
              (dom-remove-attr old-el aname))))
        (dom-attr-list old-el)))))

(define
  morph-children
  :effects (mutation io)
  (fn
    (old-parent new-parent)
    (let
      ((old-kids (dom-child-list old-parent))
        (new-kids (dom-child-list new-parent))
        (old-by-id (dict))
        (old-idx-by-id (dict))
        (consumed (dict))
        (oi 0)
        (idx 0))
      (for-each
        (fn
          (kid)
          (let
            ((id (dom-id kid)))
            (when
              (and id (not (empty? id)))
              (dict-set! old-by-id id kid)
              (dict-set! old-idx-by-id id idx)))
          (set! idx (inc idx)))
        old-kids)
      (for-each
        (fn
          (new-child)
          (let
            ((raw-id (dom-id new-child))
              (match-id (if (and raw-id (not (empty? raw-id))) raw-id nil))
              (match-by-id (if match-id (dict-get old-by-id match-id) nil)))
            (cond
              (and match-by-id (not (nil? match-by-id)))
              (do
                (let
                  ((matched-idx (dict-get old-idx-by-id match-id)))
                  (when
                    matched-idx
                    (dict-set! consumed (str matched-idx) true)))
                (when
                  (and
                    (< oi (len old-kids))
                    (not (= match-by-id (nth old-kids oi))))
                  (dom-insert-before
                    old-parent
                    match-by-id
                    (if (< oi (len old-kids)) (nth old-kids oi) nil)))
                (morph-node match-by-id new-child)
                (set! oi (inc oi)))
              (< oi (len old-kids))
              (let
                ((old-child (nth old-kids oi)))
                (let
                  ((old-id (dom-id old-child)))
                  (if
                    (and old-id (not (empty? old-id)) (not match-id))
                    (dom-insert-before
                      old-parent
                      (dom-clone new-child true)
                      old-child)
                    (do
                      (dict-set! consumed (str oi) true)
                      (morph-node old-child new-child)
                      (set! oi (inc oi))))))
              :else (dom-append old-parent (dom-clone new-child true)))))
        new-kids)
      (for-each
        (fn
          (i)
          (when
            (not (dict-get consumed (str i)))
            (let
              ((leftover (nth old-kids i)))
              (when
                (and
                  (dom-is-child-of? leftover old-parent)
                  (not (dom-has-attr? leftover "sx-preserve"))
                  (not (dom-has-attr? leftover "sx-ignore")))
                (dom-remove-child old-parent leftover)))))
        (range 0 (len old-kids))))))

(define
  morph-island-children
  :effects (mutation io)
  (fn
    (old-island new-island)
    (let
      ((old-lakes (dom-query-all old-island "[data-sx-lake]"))
        (new-lakes (dom-query-all new-island "[data-sx-lake]"))
        (old-marshes (dom-query-all old-island "[data-sx-marsh]"))
        (new-marshes (dom-query-all new-island "[data-sx-marsh]")))
      (let
        ((new-lake-map (dict)) (new-marsh-map (dict)))
        (for-each
          (fn
            (lake)
            (let
              ((id (dom-get-attr lake "data-sx-lake")))
              (when id (dict-set! new-lake-map id lake))))
          new-lakes)
        (for-each
          (fn
            (marsh)
            (let
              ((id (dom-get-attr marsh "data-sx-marsh")))
              (when id (dict-set! new-marsh-map id marsh))))
          new-marshes)
        (for-each
          (fn
            (old-lake)
            (let
              ((id (dom-get-attr old-lake "data-sx-lake")))
              (let
                ((new-lake (dict-get new-lake-map id)))
                (when
                  new-lake
                  (sync-attrs old-lake new-lake)
                  (morph-children old-lake new-lake)))))
          old-lakes)
        (for-each
          (fn
            (old-marsh)
            (let
              ((id (dom-get-attr old-marsh "data-sx-marsh")))
              (let
                ((new-marsh (dict-get new-marsh-map id)))
                (when new-marsh (morph-marsh old-marsh new-marsh old-island)))))
          old-marshes)
        (process-signal-updates new-island)))))

(define
  morph-marsh
  :effects (mutation io)
  (fn
    (old-marsh new-marsh island-el)
    (let
      ((transform (dom-get-data old-marsh "sx-marsh-transform"))
        (env (dom-get-data old-marsh "sx-marsh-env"))
        (new-html (dom-inner-html new-marsh)))
      (if
        (and env new-html (not (empty? new-html)))
        (let
          ((parsed (parse new-html)))
          (let
            ((sx-content (if transform (cek-call transform (list parsed)) parsed)))
            (dispose-marsh-scope old-marsh)
            (with-marsh-scope
              old-marsh
              (fn
                ()
                (let
                  ((new-dom (render-to-dom sx-content env nil)))
                  (dom-remove-children-after old-marsh nil)
                  (dom-append old-marsh new-dom))))))
        (do
          (sync-attrs old-marsh new-marsh)
          (morph-children old-marsh new-marsh))))))

(define
  process-signal-updates
  :effects (mutation io)
  (fn
    (root)
    (let
      ((signal-els (dom-query-all root "[data-sx-signal]")))
      (for-each
        (fn
          (el)
          (let
            ((spec (dom-get-attr el "data-sx-signal")))
            (when
              spec
              (let
                ((colon-idx (index-of spec ":")))
                (when
                  (> colon-idx 0)
                  (let
                    ((store-name (slice spec 0 colon-idx))
                      (raw-value (slice spec (+ colon-idx 1))))
                    (let
                      ((parsed (json-parse raw-value)))
                      (reset! (use-store store-name) parsed))
                    (dom-remove-attr el "data-sx-signal")))))))
        signal-els))))

(define
  swap-dom-nodes
  :effects (mutation io)
  (fn
    (target new-nodes (strategy :as string))
    (case
      strategy
      "innerHTML"
      (if
        (dom-is-fragment? new-nodes)
        (morph-children target new-nodes)
        (let
          ((wrapper (dom-create-element "div" nil)))
          (dom-append wrapper new-nodes)
          (morph-children target wrapper)))
      "outerHTML"
      (let
        ((parent (dom-parent target)) (new-el (dom-clone new-nodes true)))
        (if
          (dom-is-fragment? new-nodes)
          (let
            ((fc (dom-first-child new-nodes)))
            (if
              fc
              (do
                (set! new-el (dom-clone fc true))
                (dom-replace-child parent new-el target)
                (let
                  ((sib (dom-next-sibling fc)))
                  (insert-remaining-siblings parent new-el sib)))
              (dom-remove-child parent target)))
          (dom-replace-child parent new-el target))
        new-el)
      "afterend"
      (dom-insert-after target new-nodes)
      "beforeend"
      (dom-append target new-nodes)
      "afterbegin"
      (dom-prepend target new-nodes)
      "beforebegin"
      (dom-insert-before (dom-parent target) new-nodes target)
      "delete"
      (dom-remove-child (dom-parent target) target)
      "none"
      nil
      :else (if
        (dom-is-fragment? new-nodes)
        (morph-children target new-nodes)
        (let
          ((wrapper (dom-create-element "div" nil)))
          (dom-append wrapper new-nodes)
          (morph-children target wrapper))))))

(define
  insert-remaining-siblings
  :effects (mutation io)
  (fn
    (parent ref-node sib)
    (when
      sib
      (let
        ((next (dom-next-sibling sib)))
        (dom-insert-after ref-node sib)
        (insert-remaining-siblings parent sib next)))))

(define
  swap-html-string
  :effects (mutation io)
  (fn
    (target (html :as string) (strategy :as string))
    (case
      strategy
      "innerHTML"
      (dom-set-inner-html target html)
      "outerHTML"
      (let
        ((parent (dom-parent target)))
        (dom-insert-adjacent-html target "afterend" html)
        (dom-remove-child parent target)
        parent)
      "afterend"
      (dom-insert-adjacent-html target "afterend" html)
      "beforeend"
      (dom-insert-adjacent-html target "beforeend" html)
      "afterbegin"
      (dom-insert-adjacent-html target "afterbegin" html)
      "beforebegin"
      (dom-insert-adjacent-html target "beforebegin" html)
      "delete"
      (dom-remove-child (dom-parent target) target)
      "none"
      nil
      :else (dom-set-inner-html target html))))

(define
  handle-history
  :effects (io)
  (fn
    (el (url :as string) (resp-headers :as dict))
    (let
      ((push-url (dom-get-attr el "sx-push-url"))
        (replace-url (dom-get-attr el "sx-replace-url"))
        (hdr-replace (get resp-headers "replace-url")))
      (cond
        hdr-replace
        (browser-replace-state hdr-replace)
        (and push-url (not (= push-url "false")))
        (do
          (save-scroll-position)
          (browser-push-state (if (= push-url "true") url push-url)))
        (and replace-url (not (= replace-url "false")))
        (browser-replace-state (if (= replace-url "true") url replace-url))))))

(define PRELOAD_TTL 30000)

(define
  preload-cache-get
  :effects (mutation)
  (fn
    ((cache :as dict) (url :as string))
    (let
      ((entry (dict-get cache url)))
      (if
        (nil? entry)
        nil
        (if
          (> (- (now-ms) (get entry "timestamp")) PRELOAD_TTL)
          (do (dict-delete! cache url) nil)
          (do (dict-delete! cache url) entry))))))

(define
  preload-cache-set
  :effects (mutation)
  (fn
    ((cache :as dict)
      (url :as string)
      (text :as string)
      (content-type :as string))
    (dict-set!
      cache
      url
      (dict "text" text "content-type" content-type "timestamp" (now-ms)))))

(define
  classify-trigger
  :effects ()
  (fn
    ((trigger :as dict))
    (let
      ((event (get trigger "event")))
      (cond
        (= event "every")
        "poll"
        (= event "intersect")
        "intersect"
        (= event "load")
        "load"
        (= event "revealed")
        "revealed"
        :else "event"))))

(define
  should-boost-link?
  :effects (io)
  (fn
    (link)
    (let
      ((href (dom-get-attr link "href")))
      (and
        href
        (not (starts-with? href "#"))
        (not (starts-with? href "javascript:"))
        (not (starts-with? href "mailto:"))
        (browser-same-origin? href)
        (not (dom-has-attr? link "sx-get"))
        (not (dom-has-attr? link "sx-post"))
        (not (dom-has-attr? link "sx-disable"))))))

(define
  should-boost-form?
  :effects (io)
  (fn
    (form)
    (and
      (not (dom-has-attr? form "sx-get"))
      (not (dom-has-attr? form "sx-post"))
      (not (dom-has-attr? form "sx-disable")))))

(define
  parse-sse-swap
  :effects (io)
  (fn (el) (or (dom-get-attr el "sx-sse-swap") "message")))