Source file livereload.ml

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
(* This file is part of Dream, released under the MIT license. See LICENSE.md
   for details, or visit https://github.com/aantron/dream.

   Copyright 2021-2023 Thibaut Mattio, Anton Bachin *)



module Message = Dream_pure.Message



let route =
  "/_livereload"

let retry_interval_ms =
  500



let script = Printf.sprintf
    {js|
var socketUrl = "ws://" + location.host + "%s";
var s = new WebSocket(socketUrl);

s.onopen = function(even) {
  console.debug("Live reload: WebSocket connection open");
};

s.onclose = function(even) {
  console.debug("Live reload: WebSocket connection closed");

  var retryIntervalMs = %i;

  function reload() {
    s2 = new WebSocket(socketUrl);

    s2.onerror = function(event) {
      setTimeout(reload, retryIntervalMs);
    };

    s2.onopen = function(event) {
      location.reload();
    };
  };

  reload();
};

s.onerror = function(event) {
  console.debug("Live reload: WebSocket error:", event);
};
|js}
    route retry_interval_ms



let livereload next_handler request =

  match Message.target request with
  | target when target = route ->
    Helpers.websocket @@ fun socket ->
    let%lwt _ = Helpers.receive socket in
    Message.close_websocket socket

  | _ ->
    let%lwt response = next_handler request in
    match Message.header response "Content-Type" with
    | Some ("text/html" | "text/html; charset=utf-8") ->
      let%lwt body = Message.body response in
      let soup =
        Markup.string body
        |> Markup.parse_html ~context:`Document
        |> Markup.signals
        |> Soup.from_signals
      in
      begin match Soup.Infix.(soup $? "head") with
      | None ->
        Lwt.return response
      | Some head ->
        Soup.create_element "script" ~inner_text:script
        |> Soup.append_child head;
        soup
        |> Soup.to_string
        |> Message.set_body response;
        Lwt.return response
      end

    | _ -> Lwt.return response