Merge branch 'hs-e36-websocket' into loops/hs

lib/hyperscript/runtime.sx

@@ -2592,3 +2592,113 @@
           node
           (walk (hs-node-get node (first keys)) (rest keys)))))
     (hs-line-for (walk (hs-parse-ast src-str) path))))
+
+;; ── WebSocket / socket feature ───────────────────────────────────
+
+(define
+  hs-try-json-parse
+  (fn (s) (host-call (host-global "JSON") "parse" s)))
+
+(define
+  hs-socket-resolve-rpc!
+  (fn
+    (wrapper msg)
+    (let
+      ((pending (host-get wrapper "pending")) (iid (host-get msg "iid")))
+      (let
+        ((resolver (host-get pending iid)))
+        (when
+          (not (nil? resolver))
+          (if
+            (not (nil? (host-get msg "return")))
+            (host-call resolver "resolve" (host-get msg "return"))
+            (host-call resolver "reject" (host-get msg "throw")))
+          (host-set! pending iid nil))))))
+
+(define
+  hs-socket-register!
+  (fn
+    (name-path url timeout-ms handler json?)
+    (let
+      ((ws-url (cond ((or (starts-with? url "ws://") (starts-with? url "wss://")) url) (true (let ((proto (host-get (host-global "location") "protocol")) (h (host-get (host-global "location") "host"))) (str (if (= proto "https:") "wss:" "ws:") "//" h url))))))
+      (let
+        ((ws (host-new "WebSocket" ws-url)))
+        (let
+          ((wrapper (host-new "Object")))
+          (host-set! wrapper "raw" ws)
+          (host-set! wrapper "url" ws-url)
+          (host-set! wrapper "timeout" timeout-ms)
+          (host-set! wrapper "pending" (host-new "Object"))
+          (host-set! wrapper "handler" handler)
+          (host-set! wrapper "json?" json?)
+          (host-set! wrapper "closed?" false)
+          (host-set! wrapper "closedFlag" nil)
+          (let
+            ((proxy-factory (host-global "_hs_make_rpc_proxy")))
+            (when
+              proxy-factory
+              (host-set!
+                wrapper
+                "rpc"
+                (host-call proxy-factory "call" nil wrapper))))
+          (host-set!
+            ws
+            "onmessage"
+            (host-callback
+              (fn
+                (event)
+                (let
+                  ((data (host-get event "data")))
+                  (let
+                    ((parsed (hs-try-json-parse data)))
+                    (cond
+                      ((and (not (nil? parsed)) (not (nil? (host-get parsed "iid"))))
+                        (hs-socket-resolve-rpc! wrapper parsed))
+                      ((not (nil? handler))
+                        (if
+                          json?
+                          (if
+                            (not (nil? parsed))
+                            (handler parsed)
+                            (error "Received non-JSON message"))
+                          (handler event)))))))))
+          (host-call
+            ws
+            "addEventListener"
+            "close"
+            (host-callback
+              (fn
+                (evt)
+                (host-set! wrapper "closedFlag" "1"))))
+          (host-set!
+            wrapper
+            "dispatchEvent"
+            (host-callback
+              (fn
+                (evt)
+                (let
+                  ((payload (host-new "Object")))
+                  (host-set! payload "type" (host-get evt "type"))
+                  (host-call
+                    (host-get wrapper "raw")
+                    "send"
+                    (host-call
+                      (host-global "JSON")
+                      "stringify"
+                      payload))))))
+          (define
+            bind-path!
+            (fn
+              (obj path)
+              (if
+                (= (len path) 1)
+                (host-set! obj (first path) wrapper)
+                (let
+                  ((key (first path)) (rest-path (rest path)))
+                  (let
+                    ((next (or (host-get obj key) (host-new "Object"))))
+                    (host-set! obj key next)
+                    (bind-path! next rest-path))))))
+          (bind-path! (host-global "window") name-path)
+          wrapper)))))
+