diff --git a/.gitignore b/.gitignore index 28be17e..3a0f3b2 100644 --- a/.gitignore +++ b/.gitignore @@ -7,3 +7,4 @@ _build TAGS *.install +/bench/__pycache__ diff --git a/Makefile b/Makefile index 2c8fd7d..46c31fd 100644 --- a/Makefile +++ b/Makefile @@ -1,5 +1,5 @@ -.PHONY: build lib doc clean install uninstall test gen gen_ragel gen_metaocaml archive +.PHONY: build lib doc clean install uninstall test gen gen_ragel gen_metaocaml archive bench-compare OCAMLBUILD=ocamlbuild -use-ocamlfind -no-links -j 0 @@ -27,6 +27,9 @@ top: test: dune runtest $(DUNEFLAGS) +bench-compare: + ./bench/compare.sh $(BENCH_ARGS) + doc: dune build $(DUNEFLAGS) @doc diff --git a/bench/README.md b/bench/README.md new file mode 100644 index 0000000..d664656 --- /dev/null +++ b/bench/README.md @@ -0,0 +1,73 @@ +# Performance benchmarks + +The suite covers the performance-sensitive changes on +`sc/perf-work-2026-08`: + +- URL encoding with and without `+` substitution; +- UTF-8 HTML encoding through `Web.htmlencode`; +- UTF-8 `Netconversion.convert`; +- UTF-8 `Netconversion.ustring_of_uarray`. + +## Compare the branch with its fixed reference + +```sh +make bench-compare +``` + +The default runs 100 measured batches and one warmup batch per benchmark. To +change that or select a benchmark group: + +```sh +make bench-compare BENCH_ARGS='--iterations 500 --warmup-iterations 2' +make bench-compare BENCH_ARGS='--iterations 500 --path url.plus_true' +make bench-compare BENCH_ARGS='--path netconversion.convert_utf8.ascii_5000' +``` + +The comparison uses the exact same benchmark source in the current checkout +and in a temporary worktree at the fixed merge-base commit +`d1e80c727ec9ebbf83df8757af7e358af9a1b7a5`. Dune's cache is disabled for both +builds. + +The command prints old/new timing, throughput, allocation and collection +tables. It leaves the raw reports at: + +```text +_build/bench-compare/reference.json +_build/bench-compare/current.json +``` + +To regenerate only the comparison table from existing reports: + +```sh +python3 bench/compare.py \ + _build/bench-compare/reference.json \ + _build/bench-compare/current.json +``` + +## Run only the current checkout + +List benchmark names: + +```sh +dune exec bench/bench_perf.exe -- --list +``` + +Create a report: + +```sh +dune exec bench/bench_perf.exe -- \ + --revision current \ + --iterations 500 \ + --path html \ + --output /tmp/html-bench.json +``` + +Each benchmark processes inputs in batches of approximately 64 KiB so short +function calls are not dominated by the measurement loop. Every JSON object +records the batch size, measured batch count and resulting total operation +count. + +Timing uses `Unix.gettimeofday` and `Unix.times`. Allocation counters use +`Gc.counters`, converted from words to bytes. `major_allocated_bytes_direct` +is total major allocation minus promoted allocation. Collection counts come +from `Gc.quick_stat` snapshots. diff --git a/bench/bench_perf.ml b/bench/bench_perf.ml new file mode 100644 index 0000000..ec1679a --- /dev/null +++ b/bench/bench_perf.ml @@ -0,0 +1,261 @@ +open Ocamlnet_lite +open Devkit + +let output_file = ref "bench-results.json" +let revision = ref "unknown" +let iterations = ref 100 +let warmup_iterations = ref 1 +let paths = ref [] +let list_only = ref false +let sink = ref 0 + +let repeat_to_at_least pattern target = + let pattern_len = String.length pattern in + if pattern_len = 0 then invalid_arg "repeat_to_at_least"; + let count = max 1 ((target + pattern_len - 1) / pattern_len) in + let buf = Buffer.create (count * pattern_len) in + for _ = 1 to count do + Buffer.add_string buf pattern + done; + Buffer.contents buf + +let repeat_array_to_at_least pattern target = + let pattern_len = Array.length pattern in + if pattern_len = 0 then invalid_arg "repeat_array_to_at_least"; + let count = max 1 ((target + pattern_len - 1) / pattern_len) in + Array.init (count * pattern_len) (fun i -> pattern.(i mod pattern_len)) + +let batch_for_length len = max 1 (65536 / max 1 len) + +type benchmark_case = { + name : string; + input_size : int; + batch_size : int; + run_batch : unit -> unit; +} + +let make_string_case ~prefix ~profile ~target ~pattern f = + let input = repeat_to_at_least pattern target in + let batch_size = batch_for_length (String.length input) in + let run_batch () = + let total = ref 0 in + for _ = 1 to batch_size do + total := !total + String.length (f input) + done; + sink := !sink lxor !total + in + { + name = Printf.sprintf "%s.%s_%d" prefix profile target; + input_size = String.length input; + batch_size; + run_batch; + } + +let make_array_case ~prefix ~profile ~target ~pattern f = + let input = repeat_array_to_at_least pattern target in + let batch_size = batch_for_length (Array.length input) in + let run_batch () = + let total = ref 0 in + for _ = 1 to batch_size do + total := !total + String.length (f input) + done; + sink := !sink lxor !total + in + { + name = Printf.sprintf "%s.%s_%d" prefix profile target; + input_size = Array.length input; + batch_size; + run_batch; + } + +let regular_targets = [ 64; 4096; 65536 ] +let conversion_targets = [ 64; 4096; 4999; 5000; 5001; 10000; 10001; 65536 ] + +let string_cases ~prefix ~targets profiles f = + List.concat + (List.map + (fun (profile, pattern) -> + List.map + (fun target -> + make_string_case ~prefix ~profile ~target ~pattern f) + targets) + profiles) + +let array_cases ~prefix ~targets profiles f = + List.concat + (List.map + (fun (profile, pattern) -> + List.map + (fun target -> + make_array_case ~prefix ~profile ~target ~pattern f) + targets) + profiles) + +let url_profiles = + [ + ("safe_ascii", "Az09_.!*-safe"); + ("spaces", "word word word "); + ("sparse_escape", "abcdefghijklmnopqrstuvwxyz0123456789&"); + ("dense_escape", " /%~&=+\000\255"); + ("utf8", "café/世界?x=🙂 y"); + ] + +let html_profiles = + [ + ("safe_ascii", "The quick brown fox 123."); + ("safe_utf8", "café 世界 🙂 "); + ("sparse_escape", "abcdefghijklmnopqrstuvwxyz0123456789<"); + ("dense_escape", "<>&\""); + ("mixed", "café 世界 & 🙂"); + ] + +let conversion_profiles = + [ + ("ascii", "abcdefghijklmnop"); + ("utf8_2byte", "é"); + ("utf8_4byte", "🙂"); + ("mixed", "ascii-é-世界-🙂-"); + ] + +let uarray_profiles = + [ + ("ascii", [| 0x41 |]); + ("utf8_2byte", [| 0xe9 |]); + ("utf8_4byte", [| 0x1f642 |]); + ("mixed", [| 0x41; 0xe9; 0x4e16; 0x1f642 |]); + ] + +let benchmarks () = + List.concat + [ + string_cases ~prefix:"url.plus_true" ~targets:regular_targets + url_profiles (Netencoding.Url.encode ~plus:true); + string_cases ~prefix:"url.plus_false" ~targets:regular_targets + url_profiles (Netencoding.Url.encode ~plus:false); + string_cases ~prefix:"html" ~targets:regular_targets html_profiles + Web.htmlencode; + string_cases ~prefix:"netconversion.convert_utf8" + ~targets:conversion_targets conversion_profiles + (Netconversion.convert ~in_enc:`Enc_utf8 ~out_enc:`Enc_utf8); + array_cases ~prefix:"netconversion.ustring_of_uarray" + ~targets:conversion_targets uarray_profiles + (Netconversion.ustring_of_uarray `Enc_utf8); + ] + +let has_path_prefix prefix name = + let prefix_len = String.length prefix in + String.length name >= prefix_len + && String.sub name 0 prefix_len = prefix + && (String.length name = prefix_len || name.[prefix_len] = '.') + +let selected case = + !paths = [] || List.exists (fun path -> has_path_prefix path case.name) !paths + +type snapshot = { + wall : float; + user : float; + system : float; + minor_words : float; + promoted_words : float; + major_words : float; + minor_collections : int; + major_collections : int; + compactions : int; +} + +let snapshot () = + let gc = Gc.quick_stat () in + let minor_words, promoted_words, major_words = Gc.counters () in + let times = Unix.times () in + { + wall = Unix.gettimeofday (); + user = times.Unix.tms_utime; + system = times.Unix.tms_stime; + minor_words; + promoted_words; + major_words; + minor_collections = gc.Gc.minor_collections; + major_collections = gc.Gc.major_collections; + compactions = gc.Gc.compactions; + } + +let run_times n f = + for _ = 1 to n do + f () + done + +let json_float n = `Float n +let json_int n = `Int n + +let measure case = + run_times !warmup_iterations case.run_batch; + Gc.full_major (); + let before = snapshot () in + run_times !iterations case.run_batch; + let after = snapshot () in + let bytes_per_word = float_of_int (Sys.word_size / 8) in + let minor_bytes = (after.minor_words -. before.minor_words) *. bytes_per_word in + let promoted_bytes = + (after.promoted_words -. before.promoted_words) *. bytes_per_word + in + let major_bytes = (after.major_words -. before.major_words) *. bytes_per_word in + let operations = !iterations * case.batch_size in + `Assoc + [ + ("name", `String case.name); + ("revision", `String !revision); + ("input_size", json_int case.input_size); + ("batch_size", json_int case.batch_size); + ("iterations", json_int !iterations); + ("operations", json_int operations); + ("wall_seconds", json_float (after.wall -. before.wall)); + ("user_seconds", json_float (after.user -. before.user)); + ("system_seconds", json_float (after.system -. before.system)); + ("minor_allocated_bytes", json_float minor_bytes); + ( "major_allocated_bytes_including_promoted", + json_float major_bytes ); + ("major_allocated_bytes_direct", json_float (major_bytes -. promoted_bytes)); + ("promoted_bytes", json_float promoted_bytes); + ( "minor_collections", + json_int (after.minor_collections - before.minor_collections) ); + ( "major_collections", + json_int (after.major_collections - before.major_collections) ); + ("compactions", json_int (after.compactions - before.compactions)); + ("checksum", json_int !sink); + ] + +let () = + let options = + [ + ("--output", Arg.Set_string output_file, "FILE write results as JSON"); + ("--revision", Arg.Set_string revision, "LABEL revision stored in JSON"); + ("--iterations", Arg.Set_int iterations, "N measured batches per benchmark"); + ( "--warmup-iterations", + Arg.Set_int warmup_iterations, + "N unmeasured warmup batches per benchmark" ); + ( "--path", + Arg.String (fun path -> paths := path :: !paths), + "PREFIX select a benchmark or benchmark group" ); + ("--list", Arg.Set list_only, "list benchmark names without running them"); + ] + in + Arg.parse options (fun arg -> raise (Arg.Bad ("unexpected argument: " ^ arg))) + "bench_perf [OPTIONS]"; + if !iterations <= 0 then raise (Arg.Bad "--iterations must be positive"); + if !warmup_iterations < 0 then + raise (Arg.Bad "--warmup-iterations must be non-negative"); + let cases = List.filter selected (benchmarks ()) in + if cases = [] then raise (Arg.Bad "no benchmarks match the selected paths"); + if !list_only then List.iter (fun case -> print_endline case.name) cases + else ( + let results = + List.map + (fun case -> + Printf.eprintf "[%s] %s\n%!" !revision case.name; + measure case) + cases + in + Yojson.Safe.to_file !output_file (`List results); + Printf.eprintf "wrote %d results to %s\n%!" (List.length results) + !output_file); + ignore (Sys.opaque_identity !sink) diff --git a/bench/compare.py b/bench/compare.py new file mode 100755 index 0000000..c508ce5 --- /dev/null +++ b/bench/compare.py @@ -0,0 +1,178 @@ +#!/usr/bin/env python3 +"""Compare JSON reports produced by bench_perf.exe.""" + +import argparse +import json +import math +import sys +from pathlib import Path + +GROUPS = [ + ("URL encoding (+)", "url.plus_true."), + ("URL encoding (%20)", "url.plus_false."), + ("HTML encoding", "html."), + ("Netconversion.convert", "netconversion.convert_utf8."), + ("Netconversion.ustring_of_uarray", "netconversion.ustring_of_uarray."), +] + +MATCH_FIELDS = ("input_size", "batch_size", "iterations", "operations") + + +def load(path: Path): + with path.open(encoding="utf-8") as handle: + data = json.load(handle) + if not isinstance(data, list): + raise ValueError(f"{path}: expected a top-level JSON array") + indexed = {} + for item in data: + if not isinstance(item, dict) or not isinstance(item.get("name"), str): + raise ValueError(f"{path}: every entry must be an object with a name") + name = item["name"] + if name in indexed: + raise ValueError(f"{path}: duplicate benchmark {name!r}") + indexed[name] = item + return indexed + + +def format_time(seconds): + if seconds < 1e-6: + return f"{seconds * 1e9:.1f} ns" + if seconds < 1e-3: + return f"{seconds * 1e6:.1f} us" + return f"{seconds * 1e3:.1f} ms" + + +def format_bytes(value): + if abs(value) < 1024: + return f"{value:.1f} B" + if abs(value) < 1024**2: + return f"{value / 1024:.1f} KiB" + return f"{value / 1024**2:.1f} MiB" + + +def per_operation(item, field): + return float(item[field]) / int(item["operations"]) + + +def speedup(old, new): + old_time = per_operation(old, "wall_seconds") + new_time = per_operation(new, "wall_seconds") + return old_time / new_time + + +def validate(reference, current): + old_names = set(reference) + new_names = set(current) + if old_names != new_names: + missing = sorted(old_names - new_names) + extra = sorted(new_names - old_names) + details = [] + if missing: + details.append("missing from current: " + ", ".join(missing)) + if extra: + details.append("missing from reference: " + ", ".join(extra)) + raise ValueError("benchmark sets differ; " + "; ".join(details)) + for name in sorted(old_names): + old = reference[name] + new = current[name] + for field in MATCH_FIELDS: + if old.get(field) != new.get(field): + raise ValueError( + f"{name}: {field} differs: {old.get(field)!r} != {new.get(field)!r}" + ) + + +def print_performance(rows): + name_width = max(9, max(len(name) for name, _, _ in rows)) + print( + f"{'benchmark':<{name_width}} {'reference':>11} {'current':>11}" + f" {'time delta':>10} {'speedup':>8} {'old MiB/s':>10} {'new MiB/s':>10}" + ) + for name, old, new in rows: + operations = int(old["operations"]) + old_time = float(old["wall_seconds"]) / operations + new_time = float(new["wall_seconds"]) / operations + delta = (new_time / old_time - 1.0) * 100.0 + ratio = old_time / new_time + input_bytes = int(old["input_size"]) * operations + old_mibs = input_bytes / float(old["wall_seconds"]) / 1024**2 + new_mibs = input_bytes / float(new["wall_seconds"]) / 1024**2 + print( + f"{name:<{name_width}} {format_time(old_time):>11}" + f" {format_time(new_time):>11} {delta:>+9.1f}%" + f" {ratio:>7.2f}x {old_mibs:>10.1f} {new_mibs:>10.1f}" + ) + + +def print_allocations(rows): + name_width = max(9, max(len(name) for name, _, _ in rows)) + print( + f"{'benchmark':<{name_width}} {'minor B/op reference -> current':>32}" + f" {'minor delta':>11} {'major B/op reference -> current':>32}" + f" {'GC m/M old -> new':>17}" + ) + for name, old, new in rows: + minor_old = per_operation(old, "minor_allocated_bytes") + minor_new = per_operation(new, "minor_allocated_bytes") + major_old = per_operation(old, "major_allocated_bytes_direct") + major_new = per_operation(new, "major_allocated_bytes_direct") + minor_delta = ( + f"{(minor_new / minor_old - 1.0) * 100.0:+.1f}%" + if minor_old != 0.0 + else "n/a" + ) + old_gc = f"{old['minor_collections']}/{old['major_collections']}" + new_gc = f"{new['minor_collections']}/{new['major_collections']}" + print( + f"{name:<{name_width}} " + f"{format_bytes(minor_old) + ' -> ' + format_bytes(minor_new):>32} " + f"{minor_delta:>11} " + f"{format_bytes(major_old) + ' -> ' + format_bytes(major_new):>32} " + f"{old_gc + ' -> ' + new_gc:>17}" + ) + + +def geometric_mean(values): + return math.exp(sum(math.log(value) for value in values) / len(values)) + + +def main(): + parser = argparse.ArgumentParser() + parser.add_argument("reference", type=Path) + parser.add_argument("current", type=Path) + args = parser.parse_args() + + try: + reference = load(args.reference) + current = load(args.current) + validate(reference, current) + except (OSError, ValueError, json.JSONDecodeError) as error: + print(f"error: {error}", file=sys.stderr) + return 2 + + all_ratios = [] + summaries = [] + for title, prefix in GROUPS: + names = sorted(name for name in reference if name.startswith(prefix)) + if not names: + continue + rows = [(name, reference[name], current[name]) for name in names] + ratios = [speedup(old, new) for _, old, new in rows] + all_ratios.extend(ratios) + summaries.append((title, geometric_mean(ratios), len(rows))) + print(f"\n== {title} ==\n") + print_performance(rows) + print("\nAllocations and collections:\n") + print_allocations(rows) + + print("\n== Summary ==\n") + print(f"{'group':<38} {'benchmarks':>10} {'geomean speedup':>17}") + for title, ratio, count in summaries: + print(f"{title:<38} {count:>10} {ratio:>16.2f}x") + if all_ratios: + print(f"{'Overall':<38} {len(all_ratios):>10} {geometric_mean(all_ratios):>16.2f}x") + return 0 + + +if __name__ == "__main__": + raise SystemExit(main()) diff --git a/bench/compare.sh b/bench/compare.sh new file mode 100755 index 0000000..f14cc8e --- /dev/null +++ b/bench/compare.sh @@ -0,0 +1,51 @@ +#!/usr/bin/env bash +set -euo pipefail + +# Keep the two builds independent; cached artifacts would invalidate the +# old-versus-new comparison. +export DUNE_CACHE=disabled + +# This is the merge base of sc/perf-work-2026-08 and master when the +# benchmark suite was added. Keep it fixed so comparisons stay reproducible. +readonly REFERENCE_COMMIT=d1e80c727ec9ebbf83df8757af7e358af9a1b7a5 + +root=$(git rev-parse --show-toplevel) +current_commit=$(git -C "$root" rev-parse HEAD) +results_dir="$root/_build/bench-compare" +reference_json="$results_dir/reference.json" +current_json="$results_dir/current.json" +worktree=$(mktemp -d "${TMPDIR:-/tmp}/devkit-bench-reference.XXXXXX") +rmdir "$worktree" + +cleanup() { + git -C "$root" worktree remove --force "$worktree" >/dev/null 2>&1 || true +} +trap cleanup EXIT +trap 'exit 130' INT +trap 'exit 143' TERM + +git -C "$root" cat-file -e "${REFERENCE_COMMIT}^{commit}" +git -C "$root" worktree add --detach "$worktree" "$REFERENCE_COMMIT" >/dev/null + +# The benchmark only uses APIs that exist at the reference commit. Copying the +# exact same source into the worktree avoids benchmarking two different suites. +cp -R "$root/bench" "$worktree/bench" +mkdir -p "$results_dir" + +printf 'Building reference %s\n' "$REFERENCE_COMMIT" +dune build --root "$worktree" bench/bench_perf.exe +printf 'Building current %s\n' "$current_commit" +dune build --root "$root" bench/bench_perf.exe + +printf '\nRunning reference benchmarks\n' +"$worktree/_build/default/bench/bench_perf.exe" \ + --revision "$REFERENCE_COMMIT" --output "$reference_json" "$@" + +printf '\nRunning current benchmarks\n' +"$root/_build/default/bench/bench_perf.exe" \ + --revision "$current_commit" --output "$current_json" "$@" + +printf '\nComparing results\n' +python3 "$root/bench/compare.py" "$reference_json" "$current_json" + +printf '\nRaw reports:\n %s\n %s\n' "$reference_json" "$current_json" diff --git a/bench/dune b/bench/dune new file mode 100644 index 0000000..89b9230 --- /dev/null +++ b/bench/dune @@ -0,0 +1,3 @@ +(executable + (name bench_perf) + (libraries devkit ocamlnet_lite unix yojson)) diff --git a/ocamlnet_lite/netconversion.ml b/ocamlnet_lite/netconversion.ml index fe42963..13e1652 100644 --- a/ocamlnet_lite/netconversion.ml +++ b/ocamlnet_lite/netconversion.ml @@ -632,14 +632,16 @@ let convert_poly : *) k_in := !k_in + k_in_inc; k_out := !k_out + k_out_inc; - (* double the size of out_buf: *) - let size' = min Sys.max_string_length (!size + !size) in - if size' < !size + multibyte_limit then - failwith "Netconversion.convert: string too long"; - let out_buf' = Bytes.create size' in - Bytes.blit !out_buf 0 out_buf' 0 !k_out; - out_buf := out_buf'; - size := size' + (* double the size of out_buf if we stopped for lack of space: *) + if !k_in < range_len then ( + let size' = min Sys.max_string_length (!size + !size) in + if size' < !size + multibyte_limit then + failwith "Netconversion.convert: string too long"; + let out_buf' = Bytes.create size' in + Bytes.blit !out_buf 0 out_buf' 0 !k_out; + out_buf := out_buf'; + size := size' + ) done; match out_kind with | Netstring_tstring.String_kind -> Bytes.sub_string !out_buf 0 !k_out @@ -725,14 +727,16 @@ let ustring_of_uarray_poly out_kind k_in := !k_in + k_in_inc; k_out := !k_out + k_out_inc; - (* double the size of out_buf: *) - let size' = min Sys.max_string_length (!size + !size) in - if size' < !size + multibyte_limit then - failwith "Netconversion.ustring_of_uarray: string too long"; - let out_buf' = Bytes.create size' in - Bytes.blit !out_buf 0 out_buf' 0 !k_out; - out_buf := out_buf'; - size := size' + (* double the size of out_buf if we stopped too early: *) + if !k_in < len then ( + let size' = min Sys.max_string_length (!size + !size) in + if size' < !size + multibyte_limit then + failwith "Netconversion.ustring_of_uarray: string too long"; + let out_buf' = Bytes.create size' in + Bytes.blit !out_buf 0 out_buf' 0 !k_out; + out_buf := out_buf'; + size := size' + ) done; Netstring_tstring.bytes_subpoly out_kind !out_buf 0 !k_out diff --git a/ocamlnet_lite/netencoding.ml b/ocamlnet_lite/netencoding.ml index b238bbd..fdaa474 100644 --- a/ocamlnet_lite/netencoding.ml +++ b/ocamlnet_lite/netencoding.ml @@ -20,12 +20,10 @@ module Url = struct 'F'; |] - let to_hex2 k = - (* Converts k to a 2-digit hex string *) - let s = Bytes.create 2 in - Bytes.set s 0 hex_digits.((k lsr 4) land 15); - Bytes.set s 1 hex_digits.(k land 15); - Bytes.unsafe_to_string s + (** Converts k to a 2-digit hex string, added to [buf] *) + let buffer_add_hex2 buf k = + Buffer.add_char buf hex_digits.((k lsr 4) land 0xf); + Buffer.add_char buf hex_digits.(k land 0xf) let of_hex1 c = match c with @@ -34,18 +32,45 @@ module Url = struct | 'a' .. 'f' -> Char.code c - Char.code 'a' + 10 | _ -> raise Not_found - let url_encoding_re = Netstring_str.regexp "[^A-Za-z0-9_.!*-]" let url_decoding_re = Netstring_str.regexp "\\+\\|%..\\|%.\\|%" - let encode ?(plus = true) s = - Netstring_str.global_substitute url_encoding_re - (fun r _ -> - match Netstring_str.matched_string r s with - | " " when plus -> "+" - | x -> - let k = Char.code x.[0] in - "%" ^ to_hex2 k) + let[@inline] is_preserved_by_url_encode = function + | 'A'..'Z' | 'a'..'z' | '0'..'9' | '_' | '.' | '!' | '*' | '-' -> true + | _ -> false + + let encode ?(plus=true) s = + let buf = lazy (Buffer.create (String.length s + 10)) in + + let i = ref 0 in + let run_start = ref 0 in + + while !i < String.length s do + let c = String.unsafe_get s !i in + if is_preserved_by_url_encode c then incr i + else ( + (* [s] needs some escaping *) + let lazy buf = buf in + if !i > !run_start then Buffer.add_substring buf s !run_start (!i - !run_start); + + if c = ' ' && plus then Buffer.add_char buf '+' + else ( + Buffer.add_char buf '%'; + buffer_add_hex2 buf (Char.code c) + ); + incr i; + run_start := !i + ) + done; + + if !run_start = 0 then ( + assert (not (Lazy.is_val buf)); s + ) else ( + (* we escaped at least one char *) + let lazy buf = buf in + if !i > !run_start then Buffer.add_substring buf s !run_start (!i - !run_start); + Buffer.contents buf + ) let decode ?(plus = true) ?(pos = 0) ?len s = let s_l = String.length s in @@ -437,6 +462,48 @@ module Html = struct let out_kind = Netstring_tstring.String_kind in encode_poly ~in_enc ~in_ops ~out_kind ?out_enc ?prefer_name ?unsafe_chars () + let encode_utf8 = + let unsafe_chars = unsafe_chars_html4 in + + (* Create the domain function: *) + let safe_array = Array.make 128 true in + String.iter (fun c -> safe_array.(Char.code c) <- false) unsafe_chars; + + (* Create the substitution function: *) + let escape_char p = + assert (p <= 255); + let name = rev_etable.(p) in + if name = "" then "&#" ^ string_of_int p ^ ";" else name + in + + (* Recode: *) + fun s -> + (* NOTE: we accept U+FFFE and U+FFFF but [encode] does not *) + if not (String.is_valid_utf_8 s) then raise Netconversion.Malformed_code; + if String.for_all (fun c -> Char.code c >= 128 || safe_array.(Char.code c)) s + then s + else ( + let buf = Buffer.create (String.length s + 16) in + let i = ref 0 in + let run_start = ref 0 in + + while !i < String.length s do + let c = String.unsafe_get s !i in + let code_c = Char.code c in + + if code_c >= 128 || safe_array.(code_c) then incr i + else ( + if !i > !run_start then Buffer.add_substring buf s !run_start (!i - !run_start); + let escaped = escape_char code_c in + Buffer.add_string buf escaped; + incr i; + run_start := !i; + ) + done; + if !i > !run_start then Buffer.add_substring buf s !run_start (!i - !run_start); + Buffer.contents buf + ) + type entity_set = [ `Html | `Xml | `Empty ] let eref_re = diff --git a/ocamlnet_lite/netencoding.mli b/ocamlnet_lite/netencoding.mli index 0969e7d..dca2c20 100644 --- a/ocamlnet_lite/netencoding.mli +++ b/ocamlnet_lite/netencoding.mli @@ -95,6 +95,9 @@ module Html : sig * ]} *) + val encode_utf8 : string -> string + (** Fast path for utf8 -> utf8, regular HTML *) + type entity_set = [ `Html | `Xml | `Empty ] val decode : diff --git a/test.ml b/test.ml index 213c1d6..c7d5659 100644 --- a/test.ml +++ b/test.ml @@ -536,6 +536,132 @@ let () = test "Web.htmlencode" @@ fun () -> assert_equal (Web.htmlencode "A

tag & a

tag.") "A <p> tag & a <div> tag."; () +let () = test "Web.htmlencode resize" @@ fun () -> + assert_equal + (Web.htmlencode "&&&&&&&&&&&") + "&&&&&&&&&&&"; + () + +let () = test "Netencoding.Html.encode_utf8 agrees with generic encoder" @@ fun () -> + let reference = + Netencoding.Html.encode ~in_enc:`Enc_utf8 ~out_enc:`Enc_utf8 () + in + (* let state = Random.State.make [| 0x51a7; 0x8f8; 1234 |] in *) + let state = Random.State.make_self_init () in + let unsafe_chars = "<>\"&\000\001\127" in + let rec random_scalar () = + let p = Random.State.int state 0x110000 in + if (p >= 0xd800 && p < 0xe000) || p = 0xfffe || p = 0xffff then + random_scalar () + else + p + in + let random_codepoint () = + match Random.State.int state 10 with + | 0 | 1 -> + Char.code + unsafe_chars.[Random.State.int state (String.length unsafe_chars)] + | 2 | 3 | 4 | 5 -> Random.State.int state 128 + | _ -> random_scalar () + in + let check case codepoints = + let input = Netconversion.ustring_of_uarray `Enc_utf8 codepoints in + assert_equal + ~msg:(sprintf "generated UTF-8 case %d (%d code points)" case + (Array.length codepoints)) + (reference input) + (Netencoding.Html.encode_utf8 input) + in + check 0 + [| 0x0000; 0x0001; 0x0022; 0x0026; 0x003c; 0x003e; 0x007f; 0x0080; + 0x07ff; 0x0800; 0xd7ff; 0xe000; 0xfffd; 0x10000; 0x10ffff |]; + let fixed_lengths = [ 0; 1; 2; 15; 16; 31; 32; 127; 249; 250; 251; 1000 ] in + List.iteri + (fun i len -> check (i + 1) (Array.init len (fun _ -> random_codepoint ()))) + fixed_lengths; + let n_iter = 500 in + for _i = 1 to n_iter do + let len = + match Random.State.int state 4 with + | 0 -> Random.State.int state 17 + | 1 -> Random.State.int state 257 + | 2 -> 249 + Random.State.int state 3 + | _ -> Random.State.int state 1025 + in + check (_i + List.length fixed_lengths) + (Array.init len (fun _ -> random_codepoint ())) + done + +let () = test "Netencoding.Html.encode_utf8 rejects invalid UTF-8" @@ fun () -> + assert_raises Netconversion.Malformed_code (fun () -> + ignore (Netencoding.Html.encode_utf8 "\xC3\x28")) + +module Reference_urlencode = struct + let hex_digits = + [| '0'; '1'; '2'; '3'; '4'; '5'; '6'; '7'; '8'; '9'; 'A'; 'B'; 'C'; 'D'; 'E'; 'F'; |] + let to_hex2 k = + let s = Bytes.create 2 in + Bytes.set s 0 hex_digits.((k lsr 4) land 15); + Bytes.set s 1 hex_digits.(k land 15); + Bytes.unsafe_to_string s + + let url_encoding_re = Netstring_str.regexp "[^A-Za-z0-9_.!*-]" + + let encode ?(plus = true) s = + Netstring_str.global_substitute url_encoding_re + (fun r _ -> + match Netstring_str.matched_string r s with + | " " when plus -> "+" + | x -> + let k = Char.code x.[0] in + "%" ^ to_hex2 k) + s +end + +let test_urlencode ~plus = + test (sprintf "Netencoding.Url.encode ~plus:%b" plus) @@ fun () -> + let state = Random.State.make_self_init () in + let safe_chars = + "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789_.!*-" + in + let unsafe_chars = " +%/~&=\000\001\127\128\255" in + let random_char () = + match Random.State.int state 10 with + | 0 | 1 | 2 | 3 -> + safe_chars.[Random.State.int state (String.length safe_chars)] + | 4 | 5 | 6 -> + unsafe_chars.[Random.State.int state (String.length unsafe_chars)] + | _ -> Char.chr (Random.State.int state 256) + in + let check case input = + assert_equal ~printer:(Printf.sprintf "%S") + ~msg:(sprintf "generated URL-encoding case %d (%d bytes)" case + (String.length input)) + (Reference_urlencode.encode ~plus input) + (Netencoding.Url.encode ~plus input) + in + check 0 (String.init 256 Char.chr); + let fixed_lengths = [ 0; 1; 2; 15; 16; 31; 32; 127; 249; 250; 251; 1000 ] in + List.iteri + (fun i len -> check (i + 1) (String.init len (fun _ -> random_char ()))) + fixed_lengths; + let n_iter = 500 in + for i = 1 to n_iter do + let len = + match Random.State.int state 4 with + | 0 -> Random.State.int state 17 + | 1 -> Random.State.int state 257 + | 2 -> 249 + Random.State.int state 3 + | _ -> Random.State.int state 1025 + in + check (i + List.length fixed_lengths) + (String.init len (fun _ -> random_char ())) + done + +let () = + test_urlencode ~plus:true; + test_urlencode ~plus:false + let () = test "Web.urldecode" @@ fun () -> assert_equal (Web.urldecode "Hello+G%C3%BCnter") "Hello Günter"; () diff --git a/web.ml b/web.ml index bbc777c..2e60683 100644 --- a/web.ml +++ b/web.ml @@ -20,7 +20,7 @@ let rawurldecode s = try Netencoding.Url.decode ~plus:false s with _ -> s (** percent-decode and convert plus into space *) let urldecode s = try Netencoding.Url.decode ~plus:true s with _ -> s -let htmlencode = Netencoding.Html.encode ~in_enc:`Enc_utf8 ~out_enc:`Enc_utf8 () +let htmlencode = Netencoding.Html.encode_utf8 let htmldecode_exn = Netencoding.Html.decode ~in_enc:`Enc_utf8 ~out_enc:`Enc_utf8 () let htmldecode = (* U+FFFD REPLACEMENT CHARACTER *)