xapi-stdext-std: Remove String.escaped, add String.replaced

String.replaced is an alias of map_unlikely. This names makes the intent
of the function clearer. Because a function to replace the characters is
exposed, users are less likely to fall into the pitfall of using lists.

Lists not only are very slow, but allow users to have more than one
replacement rule per character, possibly introducing mistakes.

If a plain match function cannot be produced and a list needs to be used,
users can convert it to a Char.Map and do the match with a find_opt.
This approach ends up being ~60-70% faster than using plain lists.

The benchmark comparing the new approach with the old one:

  String size 100:
    Optimized: 236.556 μs
    Reference: 1861.600 μs
    Improvement: 87.3% faster

  String size 500:
    Optimized: 1099.030 μs
    Reference: 9665.405 μs
    Improvement: 88.6% faster

  String size 1000:
    Optimized: 2198.777 μs
    Reference: 19115.019 μs
    Improvement: 88.5% faster

Signed-off-by: Pau Ruiz Safont <pau.safont@vates.tech>

Author: psafont

ocaml/idl/markdown_backend.ml

@@ -43,41 +43,41 @@ let compare_case_ins x y =
   compare (String.lowercase_ascii x) (String.lowercase_ascii y)
 
 let escape s =
-  let esc_char = function
+  let replace = function
     | '\\' ->
-        "\"
+        Some "\"
     | '*' ->
-        "*"
+        Some "*"
     | '_' ->
-        "_"
+        Some "_"
     | '{' ->
-        "{"
+        Some "{"
     | '}' ->
-        "}"
+        Some "}"
     | '[' ->
-        "["
+        Some "["
     | ']' ->
-        "]"
+        Some "]"
     | '(' ->
-        "("
+        Some "("
     | ')' ->
-        ")"
+        Some ")"
     | '>' ->
-        ">"
+        Some ">"
     | '<' ->
-        "&lt;"
+        Some "&lt;"
     | '#' ->
-        "&#35;"
+        Some "&#35;"
     | '+' ->
-        "&#43;"
+        Some "&#43;"
     | '-' ->
-        "&#45;"
+        Some "&#45;"
     | '!' ->
-        "&#33;"
-    | c ->
-        String.make 1 c
+        Some "&#33;"
+    | _ ->
+        None
   in
-  String.to_seq s |> Seq.map esc_char |> List.of_seq |> String.concat ""
+  Xapi_stdext_std.Xstringext.String.replaced ~replace s
 
 let rec of_ty_verbatim = function
   | SecretString | String ->

ocaml/libs/http-lib/dune

@@ -63,6 +63,7 @@
   xapi-backtrace
   xapi-log
   xapi-stdext-pervasives
+  xapi-stdext-std
   xapi-stdext-threads
   xapi-stdext-unix))
 

ocaml/libs/http-lib/http_svr.ml

@@ -331,28 +331,22 @@ module Server = struct
       x.handlers []
 end
 
-let escape uri =
-  (* from xapi-stdext-std xstringext *)
-  let escaped ~rules string =
-    let aux h t =
-      ( if List.mem_assoc h rules then
-          List.assoc h rules
-        else
-          Astring.String.of_char h
+let escape_html uri =
+  Xapi_stdext_std.Xstringext.String.replaced
+    ~replace:(function
+      | '<' ->
+          Some "&lt;"
+      | '>' ->
+          Some "&gt;"
+      | '\'' ->
+          Some "&apos;"
+      | '"' ->
+          Some "&quot;"
+      | '&' ->
+          Some "&amp;"
+      | _ ->
+          None
       )
-      :: t
-    in
-    String.concat "" (Astring.String.fold_right aux string [])
-  in
-  escaped
-    ~rules:
-      [
-        ('<', "&lt;")
-      ; ('>', "&gt;")
-      ; ('\'', "&apos;")
-      ; ('"', "&quot;")
-      ; ('&', "&amp;")
-      ]
     uri
 
 exception Generic_error of string
@@ -508,7 +502,7 @@ let read_request ?proxy_seen ~read_timeout ~total_timeout ~max_length fd =
                 )
         | exc ->
             response_internal_error exc fd
-              ~extra:(escape (Printexc.to_string exc))
+              ~extra:(escape_html (Printexc.to_string exc))
     ) ;
     (None, None)
 
@@ -557,7 +551,7 @@ let handle_one (x : 'a Server.t) ss context req =
                 )
         | exc ->
             response_internal_error ~req exc ss
-              ~extra:(escape (Printexc.to_string exc))
+              ~extra:(escape_html (Printexc.to_string exc))
     ) ;
     !finished
 

ocaml/libs/http-lib/http_svr.mli

@@ -68,6 +68,9 @@ val start :
 
 val handle_one : 'a Server.t -> Unix.file_descr -> 'a -> Http.Request.t -> bool
 
+val escape_html : string -> string
+(** Escapes HTML: replaces characters with their character references *)
+
 exception Socket_not_found
 
 val stop : socket -> unit

ocaml/libs/xapi-stdext/lib/xapi-stdext-std/bench/bench_xstringext.ml

@@ -8,36 +8,42 @@ let make_string len = String.init len (fun i -> Char.chr (33 + (i mod 94)))
 let escape_rules =
   [('a', "[A]"); ('e', "[E]"); ('i', "[I]"); ('o', "[O]"); ('u', "[U]")]
 
-(* Reference implementation from xstringext_test.ml *)
-let escaped_spec ?rules string =
-  match rules with
-  | None ->
-      String.escaped string
-  | Some rules ->
-      let apply_rules char =
-        match List.assoc_opt char rules with
-        | None ->
-            Seq.return char
-        | Some replacement ->
-            String.to_seq replacement
-      in
-      string |> String.to_seq |> Seq.concat_map apply_rules |> String.of_seq
+let replace = function
+  | 'a' ->
+      Some "[A]"
+  | 'e' ->
+      Some "[E]"
+  | 'i' ->
+      Some "[I]"
+  | 'o' ->
+      Some "[O]"
+  | 'u' ->
+      Some "[U]"
+  | _ ->
+      None
+
+(* Reference implementation using lists *)
+let replaced_spec ~rules string =
+  let apply_rules char = List.assoc_opt char rules in
+  XString.replaced ~replace:apply_rules string
 
-let escaped_benchmark n =
+let replaced ~rules string = XString.replaced ~replace:rules string
+
+let replaced_benchmark n =
   let s = make_string n in
-  Staged.stage @@ fun () -> ignore (XString.escaped ~rules:escape_rules s)
+  Staged.stage @@ fun () -> ignore (replaced ~rules:replace s)
 
-let escaped_spec_benchmark n =
+let replaced_spec_benchmark n =
   let s = make_string n in
-  Staged.stage @@ fun () -> ignore (escaped_spec ~rules:escape_rules s)
+  Staged.stage @@ fun () -> ignore (replaced_spec ~rules:escape_rules s)
 
-let test_escaped =
-  Test.make_indexed ~name:"escaped" ~fmt:"%s %d" ~args:[100; 500; 1000]
-    escaped_benchmark
+let test_replaced =
+  Test.make_indexed ~name:"replaced" ~fmt:"%s %d" ~args:[100; 500; 1000]
+    replaced_benchmark
 
-let test_escaped_spec =
-  Test.make_indexed ~name:"escaped-spec" ~fmt:"%s %d" ~args:[100; 500; 1000]
-    escaped_spec_benchmark
+let test_replaced_spec =
+  Test.make_indexed ~name:"replaced-spec" ~fmt:"%s %d" ~args:[100; 500; 1000]
+    replaced_spec_benchmark
 
 let benchmark () =
   let ols =
@@ -50,8 +56,8 @@ let benchmark () =
     Benchmark.cfg ~limit:2000 ~quota:(Time.second 0.5) ~kde:(Some 1000) ()
   in
   let test =
-    Test.make_grouped ~name:"escaped-comparison"
-      [test_escaped; test_escaped_spec]
+    Test.make_grouped ~name:"replaced-comparison"
+      [test_replaced; test_replaced_spec]
   in
   let raw_results = Benchmark.all cfg instances test in
   let results =
@@ -97,8 +103,10 @@ let () =
   List.iter
     (fun size ->
       Printf.printf "String size %s:\n" size ;
-      let opt_test = Printf.sprintf "escaped-comparison/escaped %s" size in
-      let ref_test = Printf.sprintf "escaped-comparison/escaped-spec %s" size in
+      let opt_test = Printf.sprintf "replaced-comparison/replaced %s" size in
+      let ref_test =
+        Printf.sprintf "replaced-comparison/replaced-spec %s" size
+      in
       match (get_timing opt_test, get_timing ref_test) with
       | Some opt_time, Some ref_time ->
           let improvement = (ref_time -. opt_time) /. ref_time *. 100.0 in

ocaml/libs/xapi-stdext/lib/xapi-stdext-std/xstringext.ml

@@ -143,10 +143,5 @@ module String = struct
     ) else
       s
 
-  let escaped ?rules s =
-    match rules with
-    | None ->
-        String.escaped s
-    | Some rules ->
-        map_unlikely s (fun c -> List.assoc_opt c rules)
+  let replaced ~replace s = map_unlikely s replace
 end

ocaml/libs/xapi-stdext/lib/xapi-stdext-std/xstringext.mli

@@ -15,10 +15,10 @@ module String : sig
   val isspace : char -> bool
   (** True if the character is whitespace *)
 
-  val escaped : ?rules:(char * string) list -> string -> string
-  (** Backward-compatible string escaping, defaulting to the built-in
-      	OCaml string escaping but allowing an arbitrary mapping from characters
-      	to strings. *)
+  val replaced : replace:(char -> string option) -> string -> string
+  (** [replaced ~replacement str] applies [replace] to all characters in [str]
+      and when it returns [Some rep] the character is replaced with [rep] in
+      the resulting string *)
 
   val split_f : (char -> bool) -> string -> string list
   (** Take a predicate and a string, return a list of strings separated by

ocaml/libs/xapi-stdext/lib/xapi-stdext-std/xstringext_test.ml

@@ -114,42 +114,6 @@ let test_rtrim =
   in
   ("rtrim", List.map test spec)
 
-(** Simple implementation of escaped for testing against *)
-let escaped_spec ?rules string =
-  match rules with
-  | None ->
-      String.escaped string
-  | Some rules ->
-      let apply_rules char =
-        match List.assoc_opt char rules with
-        | None ->
-            Seq.return char
-        | Some replacement ->
-            String.to_seq replacement
-      in
-      string |> String.to_seq |> Seq.concat_map apply_rules |> String.of_seq
-
-let test_escaped =
-  let open QCheck2 in
-  (* Generator for escape rules: list of (char, string) mappings *)
-  let gen_rules =
-    let open Gen in
-    let gen_rule = pair char (string_size (int_range 0 5) ~gen:char) in
-    list gen_rule
-  in
-  (* Generator for test input: string and optional rules *)
-  let gen_input = Gen.pair Gen.string (Gen.opt gen_rules) in
-  let property (s, rules) =
-    let expected = escaped_spec ?rules s in
-    let actual = XString.escaped ?rules s in
-    String.equal expected actual
-  in
-  let test =
-    Test.make ~name:"escaped matches reference implementation" ~count:1000
-      gen_input property
-  in
-  ("escaped", [QCheck_alcotest.to_alcotest test])
-
 let () =
   Alcotest.run "Xstringext"
-    [test_split; test_split_f; test_has_substr; test_rtrim; test_escaped]
+    [test_split; test_split_f; test_has_substr; test_rtrim]

ocaml/xapi-cli-server/cli_printer.ml

@@ -47,9 +47,15 @@ let rec multi_line_record r =
 
 (* Used to escape commas in --minimal mode *)
 let escape_commas x =
-  (* Escaping rules: *)
-  let rules = [(',', "\\,"); (* , -> \, *) ('\\', "\\\\") (* \ -> \\ *)] in
-  Xapi_stdext_std.Xstringext.String.escaped ~rules x
+  let replace = function
+    | ',' ->
+        Some "\\,"
+    | '\\' ->
+        Some "\\\\"
+    | _ ->
+        None
+  in
+  Xapi_stdext_std.Xstringext.String.replaced ~replace x
 
 let make_printer sock minimal =
   let buffer = ref [] in

ocaml/xapi/fileserver.ml

@@ -22,23 +22,11 @@ module D = Debug.Make (struct let name = "fileserver" end)
 
 open D
 
-let escape uri =
-  Xstringext.escaped
-    ~rules:
-      [
-        ('<', "&lt;")
-      ; ('>', "&gt;")
-      ; ('\'', "&apos;")
-      ; ('"', "&quot;")
-      ; ('&', "&amp;")
-      ]
-    uri
-
 let missing uri =
   "<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML 2.0//EN\"> <html><head> \
    <title>404 Not Found</title> </head><body> <h1>Not Found</h1> <p>The \
    requested URL "
-  ^ escape uri
+  ^ Http_svr.escape_html uri
   ^ " was not found on this server.</p> <hr><address>Xapi \
      Server</address></body></html>"