diff --git a/src/livereload.ml b/src/livereload.ml index adb1577..05887e8 100644 --- 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 index 49453bb..42bb578 100644 --- a/test/test_server.ml +++ b/test/test_server.ml @@ -16,40 +16,59 @@ let index = Printf.sprintf {| |} 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 () =