package bonsai

  1. Overview
  2. Docs
package bonsai
Legend:
Page
Library
Module
Module type
Parameter
Class
Class type
Source

Source file bonsai_web_ui_url_var.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
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
open! Core
open! Bonsai_web
module History = Html5_history.Opinionated

let get_uri () =
  let open Js_of_ocaml in
  Dom_html.window##.location##.href |> Js.to_string |> Uri.of_string
;;

module Components = struct
  type t =
    { path : string
    ; query : string list String.Map.t
    ; fragment : string option
    }
  [@@deriving sexp, equal]

  let create ?(path = "") ?(query = String.Map.empty) ?(fragment = None) () =
    { path; query; fragment }
  ;;

  let empty = create ()

  let to_path_and_query { path; query; fragment } =
    let uri = get_uri () in
    uri
    |> Fn.flip Uri.with_path path
    |> Fn.flip Uri.with_query (Map.to_alist query)
    |> Fn.flip Uri.with_fragment fragment
  ;;

  let of_uri uri =
    let path = Uri.path uri |> String.chop_prefix_if_exists ~prefix:"/" in
    let query =
      uri
      |> Uri.query
      |> String.Map.of_alist_multi
      |> Map.filter_map ~f:(function
        | [ value ] -> Some value
        | _ -> None)
    in
    let fragment = Uri.fragment uri in
    { path; query; fragment }
  ;;
end

module type T = sig
  type t [@@deriving sexp, equal]
end

module type S = sig
  include T

  val parse_exn : Components.t -> t
  val unparse : t -> Components.t
end

module type S_via_sexp = sig
  type t [@@deriving sexp, equal]
end

module Literally_just_a_gigantic_sexp (M : S_via_sexp) : S with type t = M.t = struct
  include M

  let query_param_name = "query"

  let parse_exn { Components.query; _ } =
    Map.find_exn query query_param_name |> List.hd_exn |> Sexp.of_string |> [%of_sexp: t]
  ;;

  let unparse t =
    let uri = get_uri () in
    let param = Sexp.to_string ([%sexp_of: t] t) in
    { Components.path = Uri.path uri
    ; query = String.Map.singleton query_param_name [ param ]
    ; fragment = Uri.fragment uri
    }
  ;;
end

module Original_components = Components

type 'a t =
  { var : 'a Bonsai.Var.t
  ; history : 'a History.t
  }

let create_exn' (type a) (module S : S with type t = a) ~on_bad_uri =
  let module Uri_routing = struct
    include S

    let parse uri =
      let components = Components.of_uri uri in
      match parse_exn components with
      | a -> Ok a
      | exception e ->
        eprint_s [%message "couldn't parse uri" (components : Components.t) (e : exn)];
        Error `Not_found
    ;;

    let to_path_and_query uri = Components.to_path_and_query (unparse uri)
  end
  in
  let module History_state = struct
    type uri_routing = a

    include S

    include Binable.Of_sexpable_with_uuid (struct
        include S

        let caller_identity =
          Bin_prot.Shape.Uuid.of_string "918e794b-02c3-4f27-ad86-3f406a41fc4b"
        ;;
      end)

    let to_uri_routing = Fn.id
    let of_uri_routing = Fn.id
  end
  in
  let t =
    History.init_exn
      ~log_s:(ignore : Sexp.t -> unit)
      (module History_state)
      (module Uri_routing)
      ~on_bad_uri
  in
  let value = History.current t in
  let var = Bonsai.Var.create value in
  Bus.iter_exn (History.changes_bus t) [%here] ~f:(Bonsai.Var.set var);
  { var; history = t }
;;

let create_exn (type a) (module S : S with type t = a) ~fallback =
  create_exn' (module S) ~on_bad_uri:(`Default_state fallback)
;;

let set ?(how : [ `Push | `Replace ] option) { var; history } a =
  let how = Option.value how ~default:`Push in
  (match how with
   | `Push -> History.update history a
   | `Replace -> History.replace history a);
  Bonsai.Var.set var a
;;

let value { var; history = _ } = Bonsai.Var.value var
let incr { var; history = _ } = Ui_incr.Var.watch (Bonsai.Var.incr_var var)

let update ?how ({ var; history = _ } as t) ~f =
  Bonsai.Var.update var ~f:(fun old ->
    let new_ = f old in
    set ?how t new_;
    new_)
;;

let get { var; _ } = Bonsai.Var.get var
let set_effect ?how t = Effect.of_sync_fun (fun a -> set ?how t a)

let update_effect ?how url_var ~f =
  Effect.of_sync_fun (fun () -> update ?how url_var ~f) ()
;;

type 'a url_var = 'a t

module Typed = struct
  module Components = struct
    include Uri_parsing.Components

    let slash_regexp = Re.Str.regexp "/"
    let unicode_slash_regexp = Re.Str.regexp "%2F"

    let sanitize_slashes s =
      let url_unicode_slash = "%2F" in
      Re.Str.global_replace slash_regexp url_unicode_slash s
    ;;

    let parse_unicode_slashes s = Re.Str.global_replace unicode_slash_regexp "/" s

    let of_original_components (original : Components.t) =
      let split_path =
        match original.path with
        | "" -> []
        | path -> String.split ~on:'/' path |> List.map ~f:parse_unicode_slashes
      in
      { Uri_parsing.Components.path = split_path; query = original.query }
    ;;

    let to_original_components (typed_components : t) =
      { Components.path =
          String.concat ~sep:"/" (List.map typed_components.path ~f:sanitize_slashes)
      ; query = typed_components.query
      ; fragment = None
      }
    ;;
  end

  module Projection = Uri_parsing.Projection
  module Parser = Uri_parsing.Parser

  module Versioned_parser = struct
    include Uri_parsing.Versioned_parser

    let of_non_typed_parser
          ~(parse_exn : Original_components.t -> 'a)
          ~(unparse : 'a -> Original_components.t)
      =
      let projection =
        let parse_exn components =
          parse_exn (Components.to_original_components components)
        in
        let unparse result = Components.of_original_components (unparse result) in
        { Projection.parse_exn; unparse }
      in
      Uri_parsing.Versioned_parser.of_non_typed_parser projection
    ;;
  end

  let make'
        (type a)
        (parser : a Uri_parsing.Versioned_parser.t)
        ~(fallback : Exn.t -> Original_components.t -> a)
        ~on_fallback_raises
    =
    let projection = Uri_parsing.Versioned_parser.eval parser in
    let try_with_backup ~f =
      try f () with
      | e -> Option.value_or_thunk on_fallback_raises ~default:(fun () -> raise e)
    in
    let parse_exn (components : Original_components.t) =
      try
        let typed_components = Components.of_original_components components in
        let result : a Uri_parsing.Parse_result.t =
          projection.parse_exn typed_components
        in
        match result.remaining.path with
        | [] -> result.result
        | unparsed_path ->
          raise_s
            [%message "Part of the path was left unparsed!" (unparsed_path : string list)]
      with
      | e -> try_with_backup ~f:(fun () -> fallback e components)
    in
    let unparse (t : a) =
      let typed_components =
        projection.unparse
          { Uri_parsing.Parse_result.result = t
          ; remaining = Uri_parsing.Components.empty
          }
      in
      Components.to_original_components typed_components
    in
    { Projection.parse_exn; unparse }
  ;;

  let make
        (type a)
        ?on_fallback_raises
        (module T : T with type t = a)
        (parser : a Uri_parsing.Versioned_parser.t)
        ~(fallback : Exn.t -> Original_components.t -> a)
    : a url_var
    =
    let projection = make' parser ~fallback ~on_fallback_raises in
    let module S = struct
      include T

      let parse_exn = projection.parse_exn
      let unparse = projection.unparse
    end
    in
    create_exn' (module S) ~on_bad_uri:`Raise
  ;;

  let make_projection
        (type a)
        ?on_fallback_raises
        (parser : a Uri_parsing.Versioned_parser.t)
        ~(fallback : Exn.t -> Original_components.t -> a)
    =
    make' parser ~fallback ~on_fallback_raises
  ;;

  module Value_parser = Uri_parsing.Value_parser

  let to_url_string (type a) (parser : a Parser.t) a =
    let projection = Parser.eval parser in
    let components =
      projection.unparse
        { Uri_parsing.Parse_result.result = a; remaining = Components.empty }
    in
    let with_query = Uri.add_query_params Uri.empty (Map.to_alist components.query) in
    let with_path = Uri.with_path with_query (String.concat ~sep:"/" components.path) in
    Uri.to_string with_path
  ;;
end

module For_testing = struct
  module Parse_result = Uri_parsing.Parse_result

  module Projection = struct
    type 'a t = (Typed.Components.t, 'a Parse_result.t) Uri_parsing.Projection.t

    let slash_regexp = Re.Str.regexp "/"
    let unicode_slash_regexp = Re.Str.regexp "%2F"

    let sanitize_slashes s =
      let url_unicode_slash = "%2F" in
      Re.Str.global_replace slash_regexp url_unicode_slash s
    ;;

    let parse_unicode_slashes s = Re.Str.global_replace unicode_slash_regexp "/" s

    let make (parser : 'a Typed.Parser.t) =
      let projection = Typed.Parser.eval parser in
      let parse_exn (components : Typed.Components.t) =
        projection.parse_exn
          { components with path = List.map ~f:parse_unicode_slashes components.path }
      in
      let unparse (result : 'a Parse_result.t) =
        let components = projection.unparse result in
        { components with path = List.map ~f:sanitize_slashes components.path }
      in
      { Uri_parsing.Projection.parse_exn; unparse }
    ;;

    let make_of_versioned_parser (versioned_parser : 'a Typed.Versioned_parser.t) =
      Uri_parsing.Versioned_parser.eval versioned_parser
    ;;

    let parse_exn (projection : 'a t) = projection.parse_exn
    let unparse (projection : 'a t) = projection.unparse
  end
end
OCaml

Innovation. Community. Security.

GitHub Discord Twitter Peertube RSS
About
Changelog Releases Industrial Users Academic Users Why OCaml
Ecosystem
Packages Community Events OCaml Planet Jobs
Resources
Install OCaml Get Started Platform Tools Language Manual Standard Library API Books Exercises Papers OCaml Playground Logo
Policies
Carbon Footprint Governance Privacy Code of Conduct