From 434f00f784f45af2e7a61be7cfc974771c5a9088 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Tue, 25 Aug 2026 14:00:19 -0400 Subject: [PATCH 1/8] perf: avoid doubling size of buffer when not needed last iteration of the loop unconditionally resizes the buffer for no reason --- ocamlnet_lite/netconversion.ml | 36 +++++++++++++++++++--------------- 1 file changed, 20 insertions(+), 16 deletions(-) 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 From a9a6c0253bc175c14788e556957f76ba5ff64130 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Tue, 25 Aug 2026 14:02:02 -0400 Subject: [PATCH 2/8] basic test for resizing --- test.ml | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/test.ml b/test.ml index 213c1d6..d0e2226 100644 --- a/test.ml +++ b/test.ml @@ -536,6 +536,12 @@ 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 "Web.urldecode" @@ fun () -> assert_equal (Web.urldecode "Hello+G%C3%BCnter") "Hello Günter"; () From 190c724687b019e4d10be3bbc90c276bc77f9142 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Tue, 25 Aug 2026 14:37:37 -0400 Subject: [PATCH 3/8] netencoding: fast path for encode_utf8 --- ocamlnet_lite/netencoding.ml | 36 +++++++++++++++++++++++++++++++++++ ocamlnet_lite/netencoding.mli | 3 +++ 2 files changed, 39 insertions(+) diff --git a/ocamlnet_lite/netencoding.ml b/ocamlnet_lite/netencoding.ml index b238bbd..b11dc03 100644 --- a/ocamlnet_lite/netencoding.ml +++ b/ocamlnet_lite/netencoding.ml @@ -437,6 +437,42 @@ 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 + for i = 0 to String.length s-1 do + let c = String.unsafe_get s i in + let code_c = Char.code c in + + if code_c >= 128 then Buffer.add_char buf c + else if safe_array.(code_c) then Buffer.add_char buf c + else ( + let escaped = escape_char code_c in + Buffer.add_string buf escaped + ) + done; + 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 : From 30e239d12ea409bdbfaee37c0ef5088e7867df15 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Tue, 25 Aug 2026 14:38:21 -0400 Subject: [PATCH 4/8] use encode_utf8 in Web --- ocamlnet_lite/netencoding.ml | 16 +++++++++++----- web.ml | 2 +- 2 files changed, 12 insertions(+), 6 deletions(-) diff --git a/ocamlnet_lite/netencoding.ml b/ocamlnet_lite/netencoding.ml index b11dc03..5471a34 100644 --- a/ocamlnet_lite/netencoding.ml +++ b/ocamlnet_lite/netencoding.ml @@ -459,17 +459,23 @@ module Html = struct then s else ( let buf = Buffer.create (String.length s + 16) in - for i = 0 to String.length s-1 do - let c = String.unsafe_get s i 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 then Buffer.add_char buf c - else if safe_array.(code_c) then Buffer.add_char buf c + 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 + 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 ) 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 *) From 75c1237f5985843e12c99190af2cd2702072bea2 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Tue, 25 Aug 2026 14:38:49 -0400 Subject: [PATCH 5/8] compat tests for Netencoding.Html.encode/encode_utf8 a bit of special cases, a bit of proptest --- test.ml | 54 ++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 54 insertions(+) diff --git a/test.ml b/test.ml index d0e2226..b73dabc 100644 --- a/test.ml +++ b/test.ml @@ -542,6 +542,60 @@ let () = test "Web.htmlencode resize" @@ fun () -> "&&&&&&&&&&&"; () +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")) + let () = test "Web.urldecode" @@ fun () -> assert_equal (Web.urldecode "Hello+G%C3%BCnter") "Hello Günter"; () From b52a333a1359399cd701486e261c39fdcc3576b6 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Tue, 25 Aug 2026 15:31:36 -0400 Subject: [PATCH 6/8] perf: improve urlencode avoid regex, just do it directly --- ocamlnet_lite/netencoding.ml | 55 ++++++++++++++++++++++++++---------- 1 file changed, 40 insertions(+), 15 deletions(-) diff --git a/ocamlnet_lite/netencoding.ml b/ocamlnet_lite/netencoding.ml index 5471a34..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 From feced9926385555c8f81a5518a54e2cad2784be6 Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Tue, 25 Aug 2026 15:31:42 -0400 Subject: [PATCH 7/8] regression test for urlencode --- test.ml | 66 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 66 insertions(+) diff --git a/test.ml b/test.ml index b73dabc..c7d5659 100644 --- a/test.ml +++ b/test.ml @@ -596,6 +596,72 @@ 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"; () From 581ed24794d85d0c3f14b02918724e1a991f5dea Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Tue, 25 Aug 2026 22:32:37 -0400 Subject: [PATCH 8/8] perf: only allocate the final buffer, exact size, in urlencode --- ocamlnet_lite/netencoding.ml | 78 ++++++++++++++++++++++-------------- 1 file changed, 48 insertions(+), 30 deletions(-) diff --git a/ocamlnet_lite/netencoding.ml b/ocamlnet_lite/netencoding.ml index fdaa474..7b2101a 100644 --- a/ocamlnet_lite/netencoding.ml +++ b/ocamlnet_lite/netencoding.ml @@ -21,9 +21,9 @@ module Url = struct |] (** 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 bytes_set_hex2 bs i k = + Bytes.set bs i hex_digits.((k lsr 4) land 0xf); + Bytes.set bs (i+1) hex_digits.(k land 0xf) let of_hex1 c = match c with @@ -39,37 +39,55 @@ module Url = struct | _ -> false let encode ?(plus=true) s = - let buf = lazy (Buffer.create (String.length s + 10)) in + let has_space_to_plus = ref false in + let additional_bytes = ref 0 in - let i = ref 0 in - let run_start = ref 0 in + for i = 0 to String.length s-1 do + let c = String.unsafe_get s i 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 - ) + if is_preserved_by_url_encode c then () + else if c = ' ' && plus then has_space_to_plus := true + else additional_bytes := !additional_bytes + 2 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 + if not !has_space_to_plus && !additional_bytes = 0 then s + else ( + (* we know the exact length *) + let res = Bytes.create (String.length s + !additional_bytes) in + let off_res = ref 0 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 *) + if !i > !run_start then ( + Bytes.blit_string s !run_start res !off_res (!i - !run_start); + off_res := !off_res + (!i - !run_start) + ); + + if c = ' ' && plus then ( + Bytes.set res !off_res '+'; + incr off_res + ) else ( + Bytes.set res !off_res '%'; + bytes_set_hex2 res (!off_res + 1) (Char.code c); + off_res := !off_res + 3 + ); + incr i; + run_start := !i + ) + done; + if !i > !run_start then ( + Bytes.blit_string s !run_start res !off_res (!i - !run_start); + off_res := !off_res + (!i - !run_start) + ); + assert (!off_res = Bytes.length res); + + Bytes.unsafe_to_string res ) let decode ?(plus = true) ?(pos = 0) ?len s =