performance work on ocamlnet_lite

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

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 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
@@ -34,18 +32,63 @@ 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)
-      s
+  let[@inline] is_preserved_by_url_encode = function
+    | 'A'..'Z' | 'a'..'z' | '0'..'9' | '_' | '.' | '!' | '*' | '-' -> true
+    | _ -> false
+
+  let encode ?(plus=true) s =
+    let has_space_to_plus = ref false in
+    let additional_bytes = ref 0 in
+
+    for i = 0 to String.length s-1 do
+      let c = String.unsafe_get s i in
+
+      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 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 =
     let s_l = String.length s in
@@ -437,6 +480,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 =

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 :

test.ml

@@ -536,6 +536,132 @@ let () = test "Web.htmlencode" @@ fun () ->
   assert_equal (Web.htmlencode "A <p> tag & a <div> tag.") "A &lt;p&gt; tag &amp; a &lt;div&gt; tag.";
   ()
 
+let () = test "Web.htmlencode resize" @@ fun () ->
+  assert_equal
+    (Web.htmlencode "&&&&&&&&&&&")
+    "&amp;&amp;&amp;&amp;&amp;&amp;&amp;&amp;&amp;&amp;&amp;";
+  ()
+
+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";
   ()

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 *)