8 files changed, 103 insertions, 1 deletions

diff --git a/dune-project b/dune-project
index 7d0b0e4..a46653c 100644
--- a/dune-project
+++ b/dune-project
@@ -30,4 +30,19 @@
  (tags
   (xmpp lwt)))
 
+(package
+ (name flesh_websockets)
+ (synopsis "WebSockets Flesh portal")
+ (description "This library implements a Flesh portal for Websockets.")
+ (depends
+   ocaml
+   dune
+   js_of_ocaml
+   js_of_ocaml-ppx
+  (flesh
+   (and (= :version)
+     :with-test)))
+ (tags
+  (xmpp flesh websockets lwt)))
+
 ; See the complete stanza docs at https://dune.readthedocs.io/en/stable/dune-files.html#dune-project
diff --git a/flesh_websockets.opam b/flesh_websockets.opam
new file mode 100644
index 0000000..553b2b3
--- /dev/null
+++ b/flesh_websockets.opam
@@ -0,0 +1,33 @@
+# This file is generated by dune, edit dune-project instead
+opam-version: "2.0"
+synopsis: "WebSockets Flesh portal"
+description: "This library implements a Flesh portal for Websockets."
+maintainer: ["Clombrong"]
+authors: ["Clombrong"]
+license: "LGPL-3.0-or-later"
+tags: ["xmpp" "flesh" "websockets" "lwt"]
+homepage: "https://forge.fsky.io/clombrong/flesh"
+bug-reports: "https://forge.fsky.io/clombrong/flesh/issues"
+depends: [
+  "ocaml"
+  "dune" {>= "3.11"}
+  "js_of_ocaml"
+  "js_of_ocaml-ppx"
+  "flesh" {= version & with-test}
+  "odoc" {with-doc}
+]
+build: [
+  ["dune" "subst"] {dev}
+  [
+    "dune"
+    "build"
+    "-p"
+    name
+    "-j"
+    jobs
+    "@install"
+    "@runtest" {with-test}
+    "@doc" {with-doc}
+  ]
+]
+dev-repo: "git+https://forge.fsky.io/clombrong/flesh.git"
diff --git a/lib/dune b/lib/flesh/dune
index af1b3ad..d79e297 100644
--- a/lib/dune
+++ b/lib/flesh/dune
@@ -1,4 +1,3 @@
 (library
  (public_name flesh)
- (name flesh)
  (libraries lwt))
diff --git a/lib/flesh.ml b/lib/flesh/flesh.ml
index 969d285..969d285 100644
--- a/lib/flesh.ml
+++ b/lib/flesh/flesh.ml
diff --git a/lib/portal/dune b/lib/portal/dune
new file mode 100644
index 0000000..47b59ce
--- /dev/null
+++ b/lib/portal/dune
@@ -0,0 +1,6 @@
+(library
+ (name portal_ws)
+ (modules portal_ws)
+ (public_name flesh_websockets)
+ (libraries lwt js_of_ocaml)
+ (preprocess (pps js_of_ocaml-ppx)))
diff --git a/lib/portal/portal_ws.ml b/lib/portal/portal_ws.ml
new file mode 100644
index 0000000..f2c0cf5
--- /dev/null
+++ b/lib/portal/portal_ws.ml
@@ -0,0 +1,24 @@
+open Lwt.Syntax
+
+open Js_of_ocaml
+let jss = Js.string
+let sjs = Js.to_string
+
+let lwt_ws (url : string) =
+  (** [lwt_ws url] returns a stream and a push function for the websocket at [url].
+      Pushing [None] closes the websocket.
+      If the websocket is closed server-side, it's up to the caller's to close the push stream. *)
+  let open Lwt_stream in
+  let handle ws incoming () =
+    let+ _ = iter (fun msg -> ws##send (jss msg)) incoming
+    in (ws##close)
+  in let stream, message = create () (* websocket -> user *)
+     and incoming, push = create () (* user -> websocket *)
+     in let (ws : WebSockets.webSocket Js.t) = new%js WebSockets.webSocket (jss url)
+        in ws##.onmessage :=
+             Dom.handler (fun x -> Some (sjs x##.data) |> message; Js._false);
+           ws##.onopen :=
+             Dom.handler (fun _ -> Lwt.async @@ handle ws incoming; Js._false);
+           ws##.onclose :=
+             Dom.handler (fun _ -> message None; Js._true);
+           stream, push
diff --git a/test/js/dune b/test/js/dune
new file mode 100644
index 0000000..d919a1e
--- /dev/null
+++ b/test/js/dune
@@ -0,0 +1,5 @@
+(test
+ (name websockets_hello)
+ (libraries portal_ws lwt js_of_ocaml)
+ (modes js)
+ (preprocess (pps js_of_ocaml-ppx)))
diff --git a/test/js/websockets_hello.ml b/test/js/websockets_hello.ml
new file mode 100644
index 0000000..41487b7
--- /dev/null
+++ b/test/js/websockets_hello.ml
@@ -0,0 +1,20 @@
+open Lwt.Syntax
+
+let () =
+  (* Echo is a websocket that... echoes you stuff. *)
+  let stream, push = Portal_ws.lwt_ws "wss://echo.websocket.org" in
+  push (Some "great text");
+  push (Some "other text");
+  push (Some "yet another text");
+  push (Some "BYE");
+  Lwt.async @@
+    fun () ->
+    let+ s = Lwt_stream.iter
+               (fun greetings ->
+                 match greetings with
+                 (* When the websocket sends "BYE", we close. *)
+                 | "BYE" -> print_endline "CLOSING BYE"; push None
+                 | hello -> print_endline ("> " ^ hello))
+               stream
+    in s
+