Reload msg to client list infra with css test

actionshrimp · Apr 16, 2018 · 186b0e6 · 186b0e6
1 parent faca68e
commit 186b0e6
Show file tree

Hide file tree

Showing 2 changed files with 125 additions and 77 deletions.
diff --git a/src/livereload.ml b/src/livereload.ml
@@ -15,50 +15,79 @@ let hello =
   "serverName": "ocaml-livereload"
 }|}
 
-let alert =
+let reload path = Printf.sprintf
 {|{
-  "command": "alert",
-  "message": "HEY!"
-}|}
+  "command": "reload",
+  "path": "%s",
+  "liveCss": true
+}|} path
+
+module ByConn = CCMap.Make(struct
+    type t = Cohttp.Connection.t
+    let compare = Cohttp.Connection.compare
+  end)
 
-let handler
-    (conn : Conduit_lwt_unix.flow * Cohttp.Connection.t)
-    (req  : Cohttp_lwt_unix.Request.t)
-    (body : Cohttp_lwt.Body.t)
+let make_handler
     (next : Conduit_lwt_unix.flow * Cohttp.Connection.t -> Cohttp_lwt_unix.Request.t -> Cohttp_lwt.Body.t  -> (Cohttp.Response.t * Cohttp_lwt.Body.t) Lwt.t)
-  : ((Cohttp.Response.t * Cohttp_lwt.Body.t) Lwt.t)
+  : ((string -> unit Lwt.t) *
+     (Conduit_lwt_unix.flow * Cohttp.Connection.t -> Cohttp_lwt_unix.Request.t -> Cohttp_lwt.Body.t -> (Cohttp.Response.t * Cohttp_lwt.Body.t) Lwt.t))
   =
-  let open Frame in
-  let uri = Cohttp.Request.uri req in
-  match Uri.path uri with
-  | "/livereload.js" ->
-    Cohttp_lwt_unix.Server.respond_string
-      ~headers: (Cohttp.Header.add (Cohttp.Header.init ()) "Content-Type" "application/javascript")
-      ~status:`OK
-      ~body: [%blob "../static/livereload.js"]
-      ()
-  | "/livereload" ->
-    Lwt_io.eprintf "[livereload] /livereload\n%!"
-    >>= fun () ->
-    Cohttp_lwt.Body.drain_body body
-    >>= fun () ->
-    Websocket_cohttp_lwt.upgrade_connection req (fst conn) (
-      fun f ->
-        match f.opcode with
-        | Opcode.Close ->
-          Printf.eprintf "[RECV] CLOSE\n%!"
-        | _ ->
-          Printf.eprintf "[RECV] %s\n%!" f.content
-    )
-    >>= fun (resp, body, frames_out_fn) ->
-    (* send a message to the client every second *)
-    Lwt_io.eprintf "[SEND] hello\n%!"
-    >>= fun () ->
-    Lwt.wrap1 frames_out_fn @@
-    Some (Frame.create ~content:hello ())
-    >>= fun () ->
-    Lwt.wrap1 frames_out_fn @@
-    Some (Frame.create ~content:alert ())
-    >>= fun () ->
-    Lwt.return (resp, (body :> Cohttp_lwt.Body.t))
-  | _ -> next conn req body
+  let conn_update_handlers = Lwt_mvar.create ByConn.empty in
+  (fun path ->
+     Lwt_mvar.take conn_update_handlers
+     >>= fun handlers ->
+     Lwt_mvar.put conn_update_handlers handlers
+     >>= fun () ->
+     Lwt.return @@
+     (handlers |> ByConn.iter (fun c handler ->
+          Printf.eprintf "[livereload] Telling %s about update to %s\n%!"
+            (Cohttp.Connection.to_string c) path;
+          handler @@ Some (Frame.create ~content:(reload path) ())
+        ));
+  ),
+  (fun conn req body ->
+     let open Frame in
+     let uri = Cohttp.Request.uri req in
+     match Uri.path uri with
+     | "/livereload.js" ->
+       Lwt_io.eprintf "[livereload] /livereload.js\n%!"
+       >>= fun () ->
+       Cohttp_lwt_unix.Server.respond_string
+         ~headers: (Cohttp.Header.add (Cohttp.Header.init ()) "Content-Type" "application/javascript")
+         ~status:`OK
+         ~body: [%blob "../static/livereload.js"]
+         ()
+     | "/livereload" ->
+       Lwt_io.eprintf "[livereload] /livereload\n%!"
+       >>= fun () ->
+       Cohttp_lwt.Body.drain_body body
+       >>= fun () ->
+       Websocket_cohttp_lwt.upgrade_connection req (fst conn) (
+         fun f ->
+           match f.opcode with
+           | Opcode.Close ->
+             Printf.eprintf "[RECV] CLOSE\n%!";
+             Lwt.async (fun () ->
+                 Lwt_io.eprintf "[livereload] Removing client %s \n%!"
+                   (snd conn |> Cohttp.Connection.to_string) >>= fun () ->
+                 Lwt_mvar.take conn_update_handlers
+                 >>= fun handlers ->
+                 let updated = ByConn.remove (snd conn) handlers in
+                 Lwt_mvar.put conn_update_handlers updated)
+
+           | _ ->
+             Printf.eprintf "[RECV] %s\n%!" f.content
+       )
+       >>= fun (resp, body, frames_out_fn) ->
+       Lwt_io.eprintf "[livereload] Adding client %s \n%!"
+         (snd conn |> Cohttp.Connection.to_string) >>= fun () ->
+       Lwt_mvar.take conn_update_handlers
+       >>= fun handlers ->
+       let updated = (ByConn.add (snd conn) frames_out_fn handlers) in
+       Lwt_mvar.put conn_update_handlers updated
+       >>= fun () ->
+       Lwt.wrap1 frames_out_fn @@
+       Some (Frame.create ~content:hello ())
+       >>= fun () ->
+       Lwt.return (resp, (body :> Cohttp_lwt.Body.t))
+     | _ -> next conn req body)
diff --git a/test/test_server.ml b/test/test_server.ml
@@ -16,40 +16,59 @@ let index = Printf.sprintf {|
 </body>
 </html> |} port
 
-let cssmain = "body { background-color: red }"
+let cssmain color = Printf.sprintf "body { background-color: %s }" color
 
-let handler
-    (conn : Conduit_lwt_unix.flow * Cohttp.Connection.t)
-    (req  : Cohttp_lwt_unix.Request.t)
-    (body : Cohttp_lwt.Body.t) =
-  Lwt_io.eprintf "[CONN] %s\n%!" (Cohttp.Connection.to_string @@ snd conn)
-  >>= fun _ ->
-  let uri = Cohttp.Request.uri req in
-  let _ = Lwt_io.eprintf "[PATH] %s\n%!" (Uri.path uri) in
-
-  Livereload.handler conn req body
-    (fun conn req body ->
-       let uri = Cohttp.Request.uri req in
-       match Uri.path uri with
-       | "/main.css" ->
-         Cohttp_lwt_unix.Server.respond_string
-           ~headers: (Cohttp.Header.add (Cohttp.Header.init ()) "Content-Type" "text/css")
-           ~status:`OK
-           ~body: cssmain
-           ()
-       | "/" ->
-         Cohttp_lwt_unix.Server.respond_string
-           ~status:`OK
-           ~body: index
-           ()
-       | _ ->
-         Lwt_io.eprintf "[PATH] Catch-all\n%!"
-         >>= fun () ->
-         Cohttp_lwt_unix.Server.respond_string
-           ~status:`Not_found
-           ~body:(Sexplib.Sexp.to_string_hum (Cohttp.Request.sexp_of_t req))
-           ()
-    )
+let make_handler () =
+  let css_content = Lwt_mvar.create (cssmain "red") in
+  let next = fun conn req body ->
+        let uri = Cohttp.Request.uri req in
+        match Uri.path uri with
+        | "/main.css" ->
+          Lwt_mvar.take css_content
+          >>= fun content ->
+          Lwt_mvar.put css_content content
+          >>= fun () ->
+          Cohttp_lwt_unix.Server.respond_string
+            ~headers: (Cohttp.Header.add (Cohttp.Header.init ()) "Content-Type" "text/css")
+            ~status:`OK
+            ~body: content
+            ()
+        | "/" ->
+          Cohttp_lwt_unix.Server.respond_string
+            ~status:`OK
+            ~body: index
+            ()
+        | _ ->
+          Lwt_io.eprintf "[PATH] Catch-all\n%!"
+          >>= fun () ->
+          Cohttp_lwt_unix.Server.respond_string
+            ~status:`Not_found
+            ~body:(Sexplib.Sexp.to_string_hum (Cohttp.Request.sexp_of_t req))
+            ()
+  in
+  let send_update_fn, handler = Livereload.make_handler next in
+  let _ =
+    let rec go (c : string) =
+      Lwt_io.eprintf "[SERV] Switching color to %s\n%!" c
+      >>= fun () ->
+      Lwt_mvar.take css_content
+      >>= fun content ->
+      Lwt_mvar.put css_content (cssmain c)
+      >>= fun () ->
+      send_update_fn "/main.css"
+      >>= fun () ->
+      Lwt_unix.sleep 3.
+      >>= fun () ->
+      go (if c = "red" then "green" else "red")
+    in
+    Lwt.async (fun () -> (go "green"))
+  in
+  fun conn req body ->
+    Lwt_io.eprintf "[CONN] %s\n%!" (Cohttp.Connection.to_string @@ snd conn)
+    >>= fun _ ->
+    let uri = Cohttp.Request.uri req in
+    let _ = Lwt_io.eprintf "[PATH] %s\n%!" (Uri.path uri) in
+    handler conn req body
 
 let start_server host port () =
   let conn_closed (ch,_) =
@@ -59,7 +78,7 @@ let start_server host port () =
   Lwt_io.eprintf "[SERV] Listening for HTTP on port %d\n%!" port >>= fun () ->
   Cohttp_lwt_unix.Server.create
     ~mode:(`TCP (`Port port))
-    (Cohttp_lwt_unix.Server.make ~callback:handler ~conn_closed ())
+    (Cohttp_lwt_unix.Server.make ~callback:(make_handler ()) ~conn_closed ())
 
 (* main *)
 let () =