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..7b2101a 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 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 = 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 *)