package cascade

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

Source file browser_compare.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
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
let ( // ) = Filename.concat

module Css = Cascade.Css
module Html = Cascade_html.Html
module Prune = Cascade.Prune.Make (Cascade_html.Html_node)

type render = {
  viewport : string;
  state : string;
  x : int;
  y : int;
  width : int;
  height : int;
  first_size : string;
  second_size : string;
}

type difference = {
  viewport : string;
  state : string;
  element : string;
  pseudo : string;
  property : string;
  first : string;
  second : string;
}

type t = {
  meta : (string * string) list;
  renders : render list;
  differences : difference list;
}

(* The job the driver reads is JSON. It holds strings alone, so a string escaper
   is the whole writer: a quote, a backslash and a control byte are escaped, and
   bytes at or above 0x80 pass through as the UTF-8 they are part of. *)
let add_json_string buf s =
  let hex = "0123456789abcdef" in
  Buffer.add_char buf '"';
  String.iter
    (fun c ->
      match c with
      | '"' -> Buffer.add_string buf "\\\""
      | '\\' -> Buffer.add_string buf "\\\\"
      | '\n' -> Buffer.add_string buf "\\n"
      | '\r' -> Buffer.add_string buf "\\r"
      | '\t' -> Buffer.add_string buf "\\t"
      | c when Char.code c < 0x20 ->
          Buffer.add_string buf "\\u00";
          Buffer.add_char buf hex.[Char.code c lsr 4];
          Buffer.add_char buf hex.[Char.code c land 0xf]
      | c -> Buffer.add_char buf c)
    s;
  Buffer.add_char buf '"'

let add_sheets buf key sheets =
  Buffer.add_string buf (String.concat "" [ ",\""; key; "\":[" ]);
  List.iteri
    (fun i (name, css) ->
      if i > 0 then Buffer.add_char buf ',';
      Buffer.add_string buf "{\"name\":";
      add_json_string buf name;
      Buffer.add_string buf ",\"css\":";
      add_json_string buf css;
      Buffer.add_char buf '}')
    sheets;
  Buffer.add_char buf ']'

(* [sampling] is what the driver reads the widths and states off; [sheets] is
   what it renders. *)
let job_json ~html ~sampling sheets =
  let buf = Buffer.create 4096 in
  Buffer.add_string buf "{\"html\":";
  add_json_string buf html;
  add_sheets buf "sheets" sheets;
  add_sheets buf "sampling" sampling;
  Buffer.add_char buf '}';
  Buffer.contents buf

(* ===== The page and what it can use ===== *)

let is_space c = c = ' ' || c = '\t' || c = '\n' || c = '\r' || c = '\012'

(* The driver's own test: the source opens, after whitespace, with [<!doctype],
   in any case. *)
let has_doctype html =
  let n = String.length html in
  let rec first i = if i < n && is_space html.[i] then first (i + 1) else i in
  let i = first 0 in
  i + 9 <= n
  && String.equal (String.lowercase_ascii (String.sub html i 9)) "<!doctype"

let is_stylesheet_link (e : Html.element) =
  String.equal e.tag "link"
  &&
  match Html.attribute e "rel" with
  | None -> false
  | Some rel ->
      String.lowercase_ascii rel
      |> String.map (fun c -> if is_space c then ' ' else c)
      |> String.split_on_char ' ' |> List.mem "stylesheet"

(* The document's own [<style>] elements and stylesheet links go, wherever they
   stand, so the sheets compared are the only ones in effect. *)
let rec strip_styles removed nodes =
  List.filter
    (function
      | Html.Element e when String.equal e.tag "style" || is_stylesheet_link e
        ->
          incr removed;
          false
      | Html.Element e ->
          e.children <- strip_styles removed e.children;
          true
      | Html.Text _ | Html.Comment _ | Html.Doctype _ -> true)
    nodes

type page = {
  document : string;  (** What the browser renders. *)
  roots : Html.element list;  (** The same page, as the matcher reads it. *)
  styles_removed : int;
  doctype_added : bool;
}

(* The page is prepared once, here, and the browser is handed that same tree
   printed back: pruning a sheet to the page is only sound over the elements the
   browser builds, so the two must not prepare the page apart. *)
let prepare html =
  let doctype_added = not (has_doctype html) in
  let html =
    if doctype_added then String.concat "" [ "<!DOCTYPE html>\n"; html ]
    else html
  in
  let removed = ref 0 in
  let doc = strip_styles removed (Html.parse html) in
  {
    document = Html.to_string doc;
    roots = Html.roots doc;
    styles_removed = !removed;
    doctype_added;
  }

(* Whether every warning the reader raised cost a declaration and nothing more:
   one it stamped as a dropped declaration, or one raised while reading a
   declaration, which the reader recovers from inside the rule it belongs to. A
   warning raised anywhere else may have cost a whole rule, stamped or not: a
   selector the reader refuses loses its rule under an unstamped warning. *)
let drops_no_rule warnings =
  List.for_all
    (fun (w : Cascade.Error.t) ->
      match (w.recovery, w.path) with
      | Cascade.Error.Recovery.Dropped { construct = Declaration; _ }, _ -> true
      | Dropped { construct = Rule; _ }, _ -> false
      | Recovered, "read_declaration" :: _ -> true
      | Recovered, _ -> false)
    warnings

(* What the driver samples a sheet for: the sheet less every rule no element of
   the page can match, as [cascade prune] removes them. A rule whose selector
   the matcher has no model for is kept, [:hover] among them, so every state a
   kept rule names is still sampled; a width named only by removed rules cannot
   change a computed value, so it is not. A sheet the reader lost a whole rule
   from is sampled as written: a dropped rule leaves nothing to say what it
   would have matched. *)
let sampling_sheet roots css =
  match Css.of_string css with
  | Ok { Css.stylesheet; warnings; _ } when drops_no_rule warnings ->
      let analysis = Prune.analyse ~sheet:stylesheet roots in
      if analysis.elements = 0 then css
      else Css.to_string ~minify:true analysis.sheet
  | Ok _ | Error _ -> css

let write_file path contents =
  Out_channel.with_open_bin path (fun oc -> output_string oc contents)

let read_lines ic =
  let rec loop acc =
    match input_line ic with
    | line -> loop (line :: acc)
    | exception End_of_file -> List.rev acc
  in
  loop []

(* The driver's TSV: [m] metadata, [r] a render that differs, [d] a computed
   value the elements under it disagree on, and [x] an error the page
   reported. *)
let parse_output lines =
  let meta, renders, differences, errors =
    List.fold_left
      (fun (meta, renders, differences, errors) line ->
        match String.split_on_char '\t' line with
        | [ "m"; key; value ] ->
            ((key, value) :: meta, renders, differences, errors)
        | [ "r"; viewport; state; x; y; width; height; first_size; second_size ]
          -> (
            match
              ( int_of_string_opt x,
                int_of_string_opt y,
                int_of_string_opt width,
                int_of_string_opt height )
            with
            | Some x, Some y, Some width, Some height ->
                let r =
                  {
                    viewport;
                    state;
                    x;
                    y;
                    width;
                    height;
                    first_size;
                    second_size;
                  }
                in
                (meta, r :: renders, differences, errors)
            | _ -> (meta, renders, differences, errors))
        | [ "d"; viewport; state; element; pseudo; property; first; second ] ->
            let d =
              { viewport; state; element; pseudo; property; first; second }
            in
            (meta, renders, d :: differences, errors)
        | "x" :: rest ->
            (meta, renders, differences, String.concat "\t" rest :: errors)
        | _ -> (meta, renders, differences, errors))
      ([], [], [], []) lines
  in
  ( {
      meta = List.rev meta;
      renders = List.rev renders;
      differences = List.rev differences;
    },
    List.rev errors )

(* [browser_diff.js] is compiled into the library, so an installed cascade
   carries its own driver; it is written beside the job it runs on. *)
let run_driver ~node ~chrome ~work ~job =
  let script = work // "browser_diff.js" in
  let job_file = work // "job.json" in
  let errors = work // "driver.err" in
  write_file script Browser_diff_js.source;
  write_file job_file job;
  let cmd =
    String.concat " "
      [
        String.concat "" [ "CHROME="; Filename.quote chrome ];
        Filename.quote node;
        Filename.quote script;
        Filename.quote job_file;
        Filename.quote work;
        String.concat "" [ "2>"; Filename.quote errors ];
      ]
  in
  let ic = Unix.open_process_in cmd in
  let lines = read_lines ic in
  match Unix.close_process_in ic with
  | Unix.WEXITED 0 -> Ok (parse_output lines)
  | Unix.WEXITED _ | Unix.WSIGNALED _ | Unix.WSTOPPED _ ->
      let text = In_channel.with_open_bin errors In_channel.input_all in
      Error
        (String.concat "" [ "the browser driver failed:\n"; String.trim text ])

let mkdtemp () =
  let base = Filename.get_temp_dir_name () in
  let rec attempt n =
    let name =
      String.concat ""
        [
          "cascade-browser-";
          string_of_int (Unix.getpid ());
          "-";
          string_of_int n;
        ]
    in
    let dir = base // name in
    match Unix.mkdir dir 0o700 with
    | () -> dir
    | exception Unix.Unix_error (Unix.EEXIST, _, _) -> attempt (n + 1)
  in
  attempt 0

let meta_int report key =
  Option.bind (List.assoc_opt key report.meta) int_of_string_opt

let identical report = report.renders = []

let version chrome =
  match Browser.chrome_version chrome with
  | Some (major, minor) ->
      String.concat "" [ string_of_int major; "."; string_of_int minor ]
  | None -> "unknown"

let ( let* ) = Result.bind

let run ~html sheets =
  let* () =
    if List.length sheets = 2 then Ok ()
    else
      Error
        "the browser comparison takes exactly two sheets: the report carries \
         one first and one second, so a third has nowhere to go"
  in
  let* node =
    Option.to_result
      ~none:"no node on PATH (or in NODE); the browser comparison needs it"
      (Browser.node_binary ())
  in
  let* chrome =
    Option.to_result
      ~none:
        "no headless Chromium found (CHROME, PATH, the puppeteer and \
         playwright caches, or the macOS application); the browser comparison \
         needs one"
      (Browser.chrome_binary ())
  in
  let page = prepare html in
  let sampling =
    List.map (fun (name, css) -> (name, sampling_sheet page.roots css)) sheets
  in
  let work = mkdtemp () in
  let* report, errors =
    run_driver ~node ~chrome ~work
      ~job:(job_json ~html:page.document ~sampling sheets)
  in
  let meta =
    List.filter
      (fun (key, _) ->
        not (List.mem key [ "document_styles_removed"; "doctype_added" ]))
      report.meta
  in
  let report =
    {
      report with
      meta =
        ("browser", version chrome)
        :: ("browser_path", chrome)
        :: ("document_styles_removed", string_of_int page.styles_removed)
        :: ("doctype_added", if page.doctype_added then "1" else "0")
        :: meta;
    }
  in
  match (errors, meta_int report "captures") with
  | _ :: _, _ -> Error (String.concat "\n" ("the page reported:" :: errors))
  | [], Some n when n > 0 -> Ok report
  | [], _ -> Error "the browser rendered nothing, so nothing was compared"

(* ===== The report for a reader ===== *)

let add_header ~first ~second ~html report buf =
  let add = Buffer.add_string buf in
  let meta key = Option.value ~default:"?" (List.assoc_opt key report.meta) in
  add
    (String.concat "" [ "Rendered "; html; " under "; first; " and "; second ]);
  add "\n";
  add
    (String.concat ""
       [
         "Browser: ";
         meta "browser";
         "; viewports: ";
         meta "viewports";
         "; states: ";
         meta "states";
         "\n";
       ]);
  add
    (String.concat ""
       [
         "Captured ";
         meta "captures";
         " renders of ";
         meta "elements";
         " elements";
         "\n";
       ]);
  (match meta_int report "document_styles_removed" with
  | Some n when n > 0 ->
      add
        (String.concat ""
           [
             "The document's own ";
             string_of_int n;
             " style element(s) or stylesheet link(s) were removed\n";
           ])
  | _ -> ());
  if List.assoc_opt "doctype_added" report.meta = Some "1" then
    add "The document had no doctype; one was added for standards mode\n";
  add
    (String.concat ""
       [
         "Renders that differ: ";
         string_of_int (List.length report.renders);
         "\n";
       ])

(* Where a render differs: the box the differing pixels span, or the two page
   sizes when the page laid out to different extents. *)
let add_renders report buf =
  List.iter
    (fun (r : render) ->
      Buffer.add_string buf
        (String.concat ""
           [
             "  ";
             r.viewport;
             " ";
             r.state;
             ": ";
             (if String.equal r.first_size r.second_size then
                String.concat ""
                  [
                    string_of_int r.width;
                    "x";
                    string_of_int r.height;
                    " pixels differ at (";
                    string_of_int r.x;
                    ",";
                    string_of_int r.y;
                    ")";
                  ]
              else
                String.concat ""
                  [
                    "the page is ";
                    r.first_size;
                    " under the first sheet and ";
                    r.second_size;
                    " under the second";
                  ]);
             "\n";
           ]))
    report.renders

(* One difference is reported once with the contexts it holds in, since most
   hold under every viewport and state. *)
type context = string * string

let key d = (d.element, d.pseudo, d.property, d.first, d.second)

let group_differences report =
  List.fold_left
    (fun acc d ->
      let k = key d in
      let seen = try List.assoc k acc with Not_found -> [] in
      (k, (d.viewport, d.state) :: seen) :: List.remove_assoc k acc)
    [] report.differences
  |> List.rev_map (fun (k, ctxs) -> (k, List.sort_uniq compare ctxs))

(* A context set that is every viewport under some states, or every state at
   some viewports, is named by the states or the viewports alone; the whole set
   is named by nothing. *)
let where ~(contexts : context list) (ctxs : context list) =
  let viewports = List.sort_uniq compare (List.map fst contexts) in
  let states = List.sort_uniq compare (List.map snd contexts) in
  let own_states = List.sort_uniq compare (List.map snd ctxs) in
  let own_viewports = List.sort_uniq compare (List.map fst ctxs) in
  let product xs ys =
    List.concat_map (fun x -> List.map (fun y -> (x, y)) ys) xs
  in
  let is_product pairs =
    List.length ctxs = List.length pairs
    && List.for_all (fun c -> List.mem c ctxs) pairs
  in
  let names =
    if List.length ctxs = List.length contexts then []
    else if is_product (product viewports own_states) then own_states
    else if is_product (product own_viewports states) then own_viewports
    else List.map (fun (v, st) -> String.concat " " [ v; st ]) ctxs
  in
  match names with
  | [] -> ""
  | names -> String.concat "" [ "  ["; String.concat ", " names; "]" ]

(* The heading over the computed values, with how many there were and, when the
   listing stopped short, how many are listed. *)
let add_differences_heading report buf =
  match report.differences with
  | [] -> ()
  | _ :: _ ->
      Buffer.add_string buf
        (String.concat ""
           [
             "\nComputed values the elements under those pixels disagree on (";
             Option.value ~default:"?"
               (List.assoc_opt "differences" report.meta);
             (match List.assoc_opt "truncated" report.meta with
             | Some n -> String.concat "" [ ", listing the first "; n ]
             | None -> "");
             "):\n";
           ])

(* A pseudo-element repeating its element's difference in the same contexts
   inherits it, and is counted rather than listed. *)
let add_differences report buf =
  let add = Buffer.add_string buf in
  add_differences_heading report buf;
  let contexts =
    List.sort_uniq compare
      (List.map (fun d -> (d.viewport, d.state)) report.differences)
  in
  let grouped = group_differences report in
  let element_has (element, _, property, first, second) ctxs =
    List.exists
      (fun ((e, ps, pr, f, sc), c) ->
        String.equal e element && String.equal ps "" && String.equal pr property
        && String.equal f first && String.equal sc second && c = ctxs)
      grouped
  in
  let inherited = ref 0 in
  let last = ref "" in
  List.iter
    (fun (((element, pseudo, property, first, second) as k), ctxs) ->
      if pseudo <> "" && element_has k ctxs then incr inherited
      else
        let head = String.concat "" [ element; pseudo ] in
        if head <> !last then (
          last := head;
          add (String.concat "" [ "\n"; head; "\n" ]));
        add
          (String.concat ""
             [
               "  ";
               property;
               ": ";
               first;
               " -> ";
               second;
               where ~contexts ctxs;
               "\n";
             ]))
    grouped;
  if !inherited > 0 then
    add
      (String.concat ""
         [
           "\n";
           string_of_int !inherited;
           " pseudo-element value(s) repeat their element's difference\n";
         ])

let pp ppf report =
  let buf = Buffer.create 1024 in
  add_renders report buf;
  add_differences report buf;
  Format.pp_print_string ppf (Buffer.contents buf)

let to_string ~first ~second ~html report =
  let buf = Buffer.create 1024 in
  add_header ~first ~second ~html report buf;
  add_renders report buf;
  add_differences report buf;
  Buffer.contents buf