XSA-474 fix: Simplify UTF-8 decoding (#6659)

* Use the decoder from the OCaml standard library instead of our own
implementation, which this patch removes.
* Validate UTF-8/XML conformance for maps and sets, in addition to
strings.

This is XSA-474 / CVE-2025-58146.

Reviewed-by: Edwin Török <edwin.torok@cloud.com>

Patch from: https://xenbits.xen.org/xsa/advisory-474.html

Author: robhoes

ocaml/database/db_cache_impl.ml

@@ -67,9 +67,7 @@ let read_field t tblname fldname objref =
     occurs. *)
 let ensure_utf8_xml string =
   let length = String.length string in
-  let prefix =
-    Xapi_stdext_encodings.Encodings.UTF8_XML.longest_valid_prefix string
-  in
+  let prefix = Xapi_stdext_encodings.Utf8.XML.longest_valid_prefix string in
   if length > String.length prefix then
     warn "string truncated to: '%s'." prefix ;
   prefix
@@ -86,20 +84,32 @@ let write_field_locked t tblname objref fldname newval =
       (get_database t)
   )
 
+(** Ensure a value is conforming to UTF-8 with XML restrictions *)
+let is_valid v =
+  let valid = Xapi_stdext_encodings.Utf8.XML.is_valid in
+  let valid_pair (x, y) = valid x && valid y in
+  match v with
+  | Schema.Value.String s ->
+      valid s
+  | Schema.Value.Set ss ->
+      List.for_all valid ss
+  | Schema.Value.Pairs pairs ->
+      List.for_all valid_pair pairs
+
+let share_string = function
+  | Schema.Value.String s ->
+      Schema.Value.String (Share.merge s)
+  | v ->
+      (* we assume strings in the tree have been shared already *)
+      v
+
 let write_field t tblname objref fldname newval =
-  let newval =
-    match newval with
-    | Schema.Value.String s ->
-        (* the other caller of write_field_locked only uses sets and maps,
-           so we only need to check for String here
-        *)
-        if not (Xapi_stdext_encodings.Encodings.UTF8_XML.is_valid s) then
-          raise Invalid_value ;
-        Schema.Value.String (Share.merge s)
-    | _ ->
-        newval
-  in
-  with_lock (fun () -> write_field_locked t tblname objref fldname newval)
+  if not @@ is_valid newval then
+    raise Invalid_value
+  else
+    with_lock (fun () ->
+        write_field_locked t tblname objref fldname (share_string newval)
+    )
 
 let touch_row t tblname objref =
   update_database t (touch tblname objref) ;

ocaml/database/string_marshall_helper.ml

@@ -22,9 +22,7 @@ module D = Debug.Make (struct let name = __MODULE__ end)
 
 let ensure_utf8_xml string =
   let length = String.length string in
-  let prefix =
-    Xapi_stdext_encodings.Encodings.UTF8_XML.longest_valid_prefix string
-  in
+  let prefix = Xapi_stdext_encodings.Utf8.XML.longest_valid_prefix string in
   if length > String.length prefix then
     D.warn "Whilst doing 'set' of structured field, string truncated to: '%s'."
       prefix ;

ocaml/idl/ocaml_backend/gen_server.ml

@@ -457,7 +457,7 @@ let gen_module api : O.Module.t =
                ([
                   "let __call, __params = call.Rpc.name, call.Rpc.params in"
                 ; "List.iter (fun p -> let s = Rpc.to_string p in if not \
-                   (Xapi_stdext_encodings.Encodings.UTF8_XML.is_valid s) then"
+                   (Xapi_stdext_encodings.Utf8.is_valid s) then"
                 ; "raise (Api_errors.Server_error(Api_errors.invalid_value, \
                    [\"Invalid UTF-8 string in parameter\"; s])))  __params;"
                 ; "let __label = __call in"

ocaml/libs/xapi-stdext/lib/xapi-stdext-encodings/bench/bench_encodings.ml

@@ -1,5 +1,5 @@
 open Bechamel
-open Xapi_stdext_encodings.Encodings
+open Xapi_stdext_encodings
 
 let test name f =
   Test.make_indexed_with_resource ~name ~args:[10; 1000; 10000]
@@ -10,6 +10,6 @@ let test name f =
 
 let benchmarks =
   Test.make_grouped ~name:"Encodings.validate"
-    [test "UTF8_XML" UTF8_XML.validate]
+    [test "UTF8.XML" Utf8.XML.is_valid]
 
 let () = Bechamel_simple_cli.cli benchmarks

ocaml/libs/xapi-stdext/lib/xapi-stdext-encodings/dune

@@ -1,12 +1,6 @@
 (library
   (name xapi_stdext_encodings)
   (public_name xapi-stdext-encodings)
-  (modules :standard \ test)
+  (modules :standard)
 )
 
-(test
-  (name test)
-  (package xapi-stdext-encodings)
-  (modules test)
-  (libraries alcotest xapi-stdext-encodings)
-)