Source file dream_html.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
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
(* Copyright 2023 Yawar Amin

   This file is part of dream-html.

   dream-html is free software: you can redistribute it and/or modify it
   under the terms of the GNU General Public License as published by the Free
   Software Foundation, either version 3 of the License, or (at your option) any
   later version.

   dream-html is distributed in the hope that it will be useful, but
   WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
   FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more
   details.

   You should have received a copy of the GNU General Public License along with
   dream-html. If not, see <https://www.gnu.org/licenses/>. *)

include Pure_html
module Form = Form

let form f ?csrf req =
  req
  |> Dream.form ?csrf
  |> Lwt.map @@ function
     | `Ok values -> (
       match Form.validate f values with
       | Ok a -> `Ok a
       | Error list -> `Invalid list)
     | `Expired (values, float) -> (
       match Form.validate f values with
       | Ok a -> `Expired (a, float)
       | Error list -> `Invalid list)
     | `Wrong_session values -> (
       match Form.validate f values with
       | Ok a -> `Wrong_session a
       | Error list -> `Invalid list)
     | `Invalid_token values -> (
       match Form.validate f values with
       | Ok a -> `Invalid_token a
       | Error list -> `Invalid list)
     | `Missing_token values -> (
       match Form.validate f values with
       | Ok a -> `Missing_token a
       | Error list -> `Invalid list)
     | `Many_tokens values -> (
       match Form.validate f values with
       | Ok a -> `Many_tokens a
       | Error list -> `Invalid list)
     | `Wrong_content_type -> `Wrong_content_type

let query f req =
  match Form.validate f (Dream.all_queries req) with
  | Ok a -> `Ok a
  | Error list -> `Invalid list

let respond ?status ?code ?headers node =
  Dream.html ?status ?code ?headers (to_string node)

let send ?text_or_binary ?end_of_message websocket node =
  Dream.send ?text_or_binary ?end_of_message websocket (to_string node)

let set_body resp node =
  Dream.set_body resp (to_string node);
  Dream.set_header resp "Content-Type" "text/html"

let write stream node = Dream.write stream (to_string node)

let csrf_tag req =
  let open HTML in
  input [name "dream.csrf"; type_ "hidden"; value "%s" (Dream.csrf_token req)]

module Path = Path

type ('r, 'p) path = ('r, 'p) Path.t
type ('r, 'p) route = ('r, 'p) Path.t -> (Dream.request -> 'r) -> Dream.route

let path rfmt afmt = { Path.rfmt; afmt }
let path_attr attr { Path.afmt; _ } = attr afmt
let pp_path f path = Format.pp_print_string f (string_of_format path.Path.rfmt)

let dream_method meth path func =
  meth (Path.to_dream path.Path.rfmt) (Path.handler path.rfmt func)

let get path = dream_method Dream.get path
let post path = dream_method Dream.post path
let put path = dream_method Dream.put path
let delete path = dream_method Dream.delete path
let head path = dream_method Dream.head path
let connect path = dream_method Dream.connect path
let options path = dream_method Dream.options path
let trace path = dream_method Dream.trace path
let patch path = dream_method Dream.patch path
let any path = dream_method Dream.any path
let use = Dream.scope "/"

let static_asset path =
  get path (fun req ->
      let pathfmt = string_of_format path.rfmt in
      (* Serve the route [/foo/bar] from the local file [foo/bar]. *)
      let filepath =
        StringLabels.sub pathfmt ~pos:1 ~len:(String.length pathfmt - 1)
      in
      let open Lwt.Syntax in
      let+ resp = Dream.from_filesystem "" filepath req in

      (* We don't want to cache an error response *)
      if Dream.status_codes_equal (Dream.status resp) `OK then
        (* Cache successful response for a year. *)
        Dream.set_header resp "Cache-Control"
          "public, max-age=31536000, immutable";
      resp)

module Livereload = struct
  let enabled =
    match Sys.getenv "LIVERELOAD" with
    | "1" -> true
    | _ | (exception _) -> false

  let endpoint = "/_livereload"

  let script =
    if enabled then
      HTML.script []
        {|
(() => {
  const retryIntervalMs = 500;
  const socketUrl = `ws://${location.host}%s`;
  const s = new WebSocket(socketUrl);

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

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

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

      s2.onerror = _evt => {
        setTimeout(reload, retryIntervalMs);
      };

      s2.onopen = _evt => {
        location.reload();
      };
    };

    reload();
  };

  s.onerror = evt => {
    console.debug("Live reload: WebSocket error:", evt);
  };
})()
  |}
        endpoint
    else
      HTML.null []

  let route =
    if enabled then
      Dream.get endpoint (fun _ ->
          Dream.websocket (fun sock ->
              Lwt.bind (Dream.receive sock) (fun _ ->
                  Dream.close_websocket sock)))
    else
      Dream.no_route
end