From 77c57b602d15b7a3e92c508eb786fd9e9f63f7cc Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Fri, 28 Nov 2025 13:18:30 +0000 Subject: [PATCH 1/3] ocaml/xapi: remove unused xmlrpc_sexpr module The methods were not safe and thankfully unused as well Signed-off-by: Pau Ruiz Safont --- ocaml/xapi/xmlrpc_sexpr.ml | 171 ------------------------------------- quality-gate.sh | 4 +- 2 files changed, 2 insertions(+), 173 deletions(-) delete mode 100644 ocaml/xapi/xmlrpc_sexpr.ml diff --git a/ocaml/xapi/xmlrpc_sexpr.ml b/ocaml/xapi/xmlrpc_sexpr.ml deleted file mode 100644 index d241491cdc3..00000000000 --- a/ocaml/xapi/xmlrpc_sexpr.ml +++ /dev/null @@ -1,171 +0,0 @@ -(* - * Copyright (C) 2006-2009 Citrix Systems Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published - * by the Free Software Foundation; version 2.1 only. with the special - * exception on linking described in file LICENSE. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - *) -(** Functions for converting between xml-rpc and a more - compact representation based on s-expressions. -*) - -open Xml -open Xapi_stdext_std.Xstringext - -(** Accepts an xml-rpc tree of type xml.xml - with contents [child1] [child2] ... [childn] - where: - tag is an xml tag. - - child is an xml tag or a pcdata. - and converts it to an sexpr tree of type SExpr.t - with contents (tag child1 child2 ... childn) - where: - tag is an SExpr.String - - child is an SExpr.t (String or Node) - exception: - - 'member' tags are not in sexpr because they - are basically redundant information inside struct children. - security notes: - 1. there is no verification that the incoming xml-rpc tree - conforms to the xml-rpc specification. an incorrect xml-rpc tree - might result in an unexpected sexpr mapping. therefore, this - function should not be used to process unsanitized/untrusted xml-rpc trees. -*) -let xmlrpc_to_sexpr (root : xml) = - let rec visit (h : int) (xml_lt : xml list) = - match (h, xml_lt) with - | _, [] -> - [] - | _, PCData text :: _ -> - let text = String.trim text in - [SExpr.String text] - (* empty s have default value '' *) - | h, Element ("value", _, []) :: siblings -> - SExpr.String "" :: visit h siblings - (* ,, tags: ignore them and go to children *) - | h, Element ("data", _, children) :: siblings - | h, Element ("value", _, children) :: siblings - | h, Element ("name", _, children) :: siblings -> - visit (h + 1) children @ visit h siblings - (* tags *) - | h, Element ("member", _, children) :: siblings -> ( - let (mychildren : SExpr.t list) = visit (h + 1) children in - let anode = SExpr.Node mychildren in - let (mysiblings : SExpr.t list) = visit h siblings in - match mychildren with - (*name & value?*) - | [SExpr.String _; _] -> - (*is name a string?*) - anode :: mysiblings - (*then add member anode*) - | _ -> - mysiblings - (*ignore incorrect member*) - ) - (*ignore incorrect member*) - (* any other element *) - | h, Element (tag, _, children) :: siblings -> - let tag = String.trim tag in - let mytag = SExpr.String tag in - let (mychildren : SExpr.t list) = visit (h + 1) children in - let anode = SExpr.Node (mytag :: mychildren) in - let (mysiblings : SExpr.t list) = visit h siblings in - anode :: mysiblings - in - List.hd (visit 0 [root]) - -(** Accepts a tree of s-expressions of type SExpr.t - with contents (tag child1 child2 ... childn) - where: - tag is an SExpr.String - - child is an SExpr.t (String or Node) - and converts it to an xml-rpc tree of type xml.xml - with contents [child1] [child2] ... [childn] - where: - tag is an xml tag. - - child is an xml tag or a pcdata. - exception: - - 'member' tags are not in sexpr because they - are redundant information inside struct children. - security notes: - 1. there is no verification that the incoming sexpr trees - conforms to the output of xmlrpc_to_sexpr. an incorrect sexpr tree - might result in an unexpected xml-rpc mapping. therefore, this - function should not be used to process unsanitized/untrusted sexpr trees. -*) -let sexpr_to_xmlrpc (root : SExpr.t) = - let encase_with (container : string) (el : xml) = - Element (container, [], [el]) - in - let is_not_empty_tag (el : xml) = - match el with Element ("", _, _) -> false | _ -> true - in - let rec visit (h : int) (parent : SExpr.t) (sexpr : SExpr.t) = - match (h, parent, sexpr) with - (* sexpr representing a struct with member tags *) - | ( h - , SExpr.Node (SExpr.String "struct" :: _) - , SExpr.Node (SExpr.String name :: avalue :: _) ) -> ( - match avalue with - | SExpr.String "" -> - Element - ( "member" - , [] - , [Element ("name", [], [PCData name]); Element ("value", [], [])] - ) - | SExpr.String value -> - Element - ( "member" - , [] - , [ - Element ("name", [], [PCData name]) - ; Element ("value", [], [PCData value]) - ] - ) - | SExpr.Node _ as somenode -> - Element - ( "member" - , [] - , [ - Element ("name", [], [PCData name]) - ; Element - ("value", [], [visit (h + 1) (SExpr.String "member") somenode]) - ] - ) - | _ -> - Element ("WRONG_SEXPR_MEMBER", [], []) - ) - (* member tag without values - wrong format - defaults to empty value *) - | _, SExpr.Node (SExpr.String "struct" :: _), SExpr.Node [SExpr.String name] - -> - Element - ( "member" - , [] - , [Element ("name", [], [PCData name]); Element ("value", [], [])] - ) - (* sexpr representing array tags *) - | h, _, SExpr.Node (SExpr.String "array" :: values) -> - let xmlvalues = List.map (visit (h + 1) sexpr) values in - Element - ( "array" - , [] - , [Element ("data", [], List.map (encase_with "value") xmlvalues)] - ) - (* sexpr representing any other tag with children *) - | h, _, SExpr.Node (SExpr.String tag :: atail) -> - let xmlvalues = List.map (visit (h + 1) sexpr) atail in - let xml_noemptytags = List.filter is_not_empty_tag xmlvalues in - Element (tag, [], xml_noemptytags) - (* sexpr representing a pcdata *) - | _, _, SExpr.String s -> - PCData s - (* sexpr representing a nameless tag *) - | _, _, SExpr.Node [] -> - Element ("EMPTY_SEXPR", [], []) - (* otherwise, we reached a senseless sexpr *) - | _ -> - Element ("WRONG_SEXPR", [], []) - in - encase_with "value" (visit 0 (SExpr.Node []) root) diff --git a/quality-gate.sh b/quality-gate.sh index 6785610ff30..50aa143ad42 100755 --- a/quality-gate.sh +++ b/quality-gate.sh @@ -3,7 +3,7 @@ set -e list-hd () { - N=268 + N=267 LIST_HD=$(git grep -r --count 'List.hd' -- **/*.ml | cut -d ':' -f 2 | paste -sd+ - | bc) if [ "$LIST_HD" -eq "$N" ]; then echo "OK counted $LIST_HD List.hd usages" @@ -25,7 +25,7 @@ verify-cert () { } mli-files () { - N=460 + N=459 X="ocaml/tests" X+="|ocaml/quicktest" X+="|ocaml/message-switch/core_test" From 36f2a476f70a4883a4dd94359b2599b75563f4c8 Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Fri, 28 Nov 2025 15:04:36 +0000 Subject: [PATCH 2/3] ocaml/libs/http-lib: remove unused mime module Signed-off-by: Pau Ruiz Safont --- ocaml/libs/http-lib/mime.ml | 57 ------------------------------------ ocaml/libs/http-lib/mime.mli | 22 -------------- quality-gate.sh | 2 +- 3 files changed, 1 insertion(+), 80 deletions(-) delete mode 100644 ocaml/libs/http-lib/mime.ml delete mode 100644 ocaml/libs/http-lib/mime.mli diff --git a/ocaml/libs/http-lib/mime.ml b/ocaml/libs/http-lib/mime.ml deleted file mode 100644 index e8dabaca132..00000000000 --- a/ocaml/libs/http-lib/mime.ml +++ /dev/null @@ -1,57 +0,0 @@ -(* - * Copyright (C) 2006-2009 Citrix Systems Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published - * by the Free Software Foundation; version 2.1 only. with the special - * exception on linking described in file LICENSE. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - *) -(* MIME handling for HTTP responses *) - -open Printf - -(** Map extension to MIME type *) -type t = (string, string) Hashtbl.t - -let lowercase = Astring.String.Ascii.lowercase - -(** Parse an Apache-format mime.types file and return mime_t *) -let mime_of_file file = - let h = Hashtbl.create 1024 in - Xapi_stdext_unix.Unixext.readfile_line - (fun line -> - if not (Astring.String.is_prefix ~affix:"#" line) then - match Astring.String.fields ~empty:false line with - | [] | [_] -> - () - | mime :: exts -> - List.iter (fun e -> Hashtbl.add h (lowercase e) mime) exts - ) - file ; - h - -let string_of_mime m = - String.concat "," (Hashtbl.fold (fun k v a -> sprintf "{%s:%s}" k v :: a) m []) - -let default_mime = "text/plain" - -(** Map a file extension to a MIME type *) -let mime_of_ext mime ext = - Option.value (Hashtbl.find_opt mime (lowercase ext)) ~default:default_mime - -(** Figure out a mime type from a full filename *) -let mime_of_file_name mime fname = - (* split filename into dot components *) - let ext = - match Astring.String.cuts ~sep:"." fname with - | [] | [_] -> - "" - | x -> - List.hd (List.rev x) - in - mime_of_ext mime ext diff --git a/ocaml/libs/http-lib/mime.mli b/ocaml/libs/http-lib/mime.mli deleted file mode 100644 index 4566fe15b0f..00000000000 --- a/ocaml/libs/http-lib/mime.mli +++ /dev/null @@ -1,22 +0,0 @@ -(* - * Copyright (C) 2006-2009 Citrix Systems Inc. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published - * by the Free Software Foundation; version 2.1 only. with the special - * exception on linking described in file LICENSE. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - *) -type t - -val mime_of_file : string -> t - -val string_of_mime : t -> string - -val mime_of_ext : t -> string -> string - -val mime_of_file_name : t -> string -> string diff --git a/quality-gate.sh b/quality-gate.sh index 50aa143ad42..018e498c85b 100755 --- a/quality-gate.sh +++ b/quality-gate.sh @@ -3,7 +3,7 @@ set -e list-hd () { - N=267 + N=266 LIST_HD=$(git grep -r --count 'List.hd' -- **/*.ml | cut -d ':' -f 2 | paste -sd+ - | bc) if [ "$LIST_HD" -eq "$N" ]; then echo "OK counted $LIST_HD List.hd usages" From 5b5631c95a6e8fd8fd507011cb2bb96a56d4545e Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Fri, 28 Nov 2025 15:50:48 +0000 Subject: [PATCH 3/3] ocaml: reduce and guard all users of Pool.get_all |> List.hd During the bringup of a new platform for XCP-ng, one of the users has raised an exception because the database doesn't have any pool record. This change makes sure that the there's more information on the exception. Also changes other places where Pool.get_all to make it obvious that the result is matched and List.hd is less likely to be used. Signed-off-by: Pau Ruiz Safont --- ocaml/tests/test_event.ml | 8 ++++---- ocaml/tests/test_ha_vm_failover.ml | 2 +- ocaml/tests/test_host.ml | 4 ++-- ocaml/tests/test_host_helpers.ml | 2 +- ocaml/tests/test_platformdata.ml | 2 +- ocaml/tests/test_vdi_cbt.ml | 2 +- ocaml/xapi/db_gc.ml | 3 +-- ocaml/xapi/dbsync_master.ml | 3 +-- ocaml/xapi/helpers.ml | 7 ++++++- ocaml/xapi/message_forwarding.ml | 9 ++++++++- ocaml/xapi/xapi_pool_patch.ml | 2 +- quality-gate.sh | 2 +- 12 files changed, 28 insertions(+), 18 deletions(-) diff --git a/ocaml/tests/test_event.ml b/ocaml/tests/test_event.ml index 821bb3bb52d..6ae77c62402 100644 --- a/ocaml/tests/test_event.ml +++ b/ocaml/tests/test_event.ml @@ -117,7 +117,7 @@ let event_next_test () = let __context, _ = event_setup_common () in let () = Xapi_event.register ~__context ~classes:["pool"] in let wait_hdl = Delay.make () in - let pool = Db.Pool.get_all ~__context |> List.hd in + let pool = Helpers.get_pool ~__context in let key = "event_next_test" in ( try Db.Pool.remove_from_other_config ~__context ~self:pool ~key with _ -> () @@ -146,7 +146,7 @@ let event_next_test () = let wait_for_pool_key __context key = let token = ref "" in let finished = ref false in - let pool = Db.Pool.get_all ~__context |> List.hd in + let pool = Helpers.get_pool ~__context in while not !finished do let events = Xapi_event.from ~__context ~classes:["pool"] ~token:!token ~timeout:10. @@ -160,7 +160,7 @@ let wait_for_pool_key __context key = let event_from_test () = let __context, _ = event_setup_common () in let wait_hdl = Delay.make () in - let pool = Db.Pool.get_all ~__context |> List.hd in + let pool = Helpers.get_pool ~__context in let key = "event_from_test" in ( try Db.Pool.remove_from_other_config ~__context ~self:pool ~key with _ -> () @@ -180,7 +180,7 @@ let event_from_test () = let event_from_parallel_test () = let __context, _ = event_setup_common () in - let pool = Db.Pool.get_all ~__context |> List.hd in + let pool = Helpers.get_pool ~__context in let key = "event_next_test" in ( try Db.Pool.remove_from_other_config ~__context ~self:pool ~key with _ -> () diff --git a/ocaml/tests/test_ha_vm_failover.ml b/ocaml/tests/test_ha_vm_failover.ml index fe915563e18..7fa1c62ceb3 100644 --- a/ocaml/tests/test_ha_vm_failover.ml +++ b/ocaml/tests/test_ha_vm_failover.ml @@ -250,7 +250,7 @@ let setup ~__context {master; slaves; ha_host_failures_to_tolerate; cluster} = let host = List.nth (Db.Host.get_all ~__context) i in Test_common.make_cluster_host ~__context ~host () |> ignore done ; - let pool = Db.Pool.get_all ~__context |> List.hd in + let pool = Helpers.get_pool ~__context in Db.Pool.set_master ~__context ~self:pool ~value:master_ref ; Db.Pool.set_ha_enabled ~__context ~self:pool ~value:true ; Db.Pool.set_ha_host_failures_to_tolerate ~__context ~self:pool diff --git a/ocaml/tests/test_host.ml b/ocaml/tests/test_host.ml index bb869d292c0..beb5588e66d 100644 --- a/ocaml/tests/test_host.ml +++ b/ocaml/tests/test_host.ml @@ -33,7 +33,7 @@ let add_host __context name = let setup_test () = (* Create an unlicensed pool *) let __context = make_test_database () in - let pool = Db.Pool.get_all ~__context |> List.hd in + let pool = Helpers.get_pool ~__context in Db.Pool.set_restrictions ~__context ~self:pool ~value:(Features.to_assoc_list []) ; (* Add hosts until we're at the maximum unlicensed pool size *) @@ -58,7 +58,7 @@ let test_host_join_restriction () = ) (fun () -> ignore (add_host __context "badhost")) ; (* License the pool *) - let pool = Db.Pool.get_all ~__context |> List.hd in + let pool = Helpers.get_pool ~__context in Db.Pool.set_restrictions ~__context ~self:pool ~value:(Features.to_assoc_list [Features.Pool_size]) ; (* Adding hosts should now work *) diff --git a/ocaml/tests/test_host_helpers.ml b/ocaml/tests/test_host_helpers.ml index d8ea5a25d0c..1b782c5a4da 100644 --- a/ocaml/tests/test_host_helpers.ml +++ b/ocaml/tests/test_host_helpers.ml @@ -149,7 +149,7 @@ let test_rpu_suppression () = let __context, calls, host1, host2, watcher, token = setup_test_oc_watcher () in - let pool = Db.Pool.get_all ~__context |> List.hd in + let pool = Helpers.get_pool ~__context in Db.Pool.add_to_other_config ~__context ~self:pool ~key:Xapi_globs.rolling_upgrade_in_progress ~value:"true" ; Db.Host.set_multipathing ~__context ~self:host1 ~value:false ; diff --git a/ocaml/tests/test_platformdata.ml b/ocaml/tests/test_platformdata.ml index 36611a5cd5a..f5d591a750e 100644 --- a/ocaml/tests/test_platformdata.ml +++ b/ocaml/tests/test_platformdata.ml @@ -97,7 +97,7 @@ module Licensing = struct let test_nested_virt_licensing (platform, should_raise) () = let __context = Test_common.make_test_database () in - let pool = Db.Pool.get_all ~__context |> List.hd in + let pool = Helpers.get_pool ~__context in let test_checks = if should_raise then Alcotest.check_raises diff --git a/ocaml/tests/test_vdi_cbt.ml b/ocaml/tests/test_vdi_cbt.ml index 54ae411ac97..4f86dc737b8 100644 --- a/ocaml/tests/test_vdi_cbt.ml +++ b/ocaml/tests/test_vdi_cbt.ml @@ -142,7 +142,7 @@ let test_cbt_enable_disable () = let test_set_metadata_of_pool_doesnt_allow_cbt_metadata_vdi () = let __context = Test_common.make_test_database () in let self = Test_common.make_vdi ~__context ~_type:`cbt_metadata () in - let pool = Db.Pool.get_all ~__context |> List.hd in + let pool = Helpers.get_pool ~__context in Alcotest.check_raises "VDI.set_metadata_of_pool should throw VDI_INCOMPATIBLE_TYPE for a \ cbt_metadata VDI" diff --git a/ocaml/xapi/db_gc.ml b/ocaml/xapi/db_gc.ml index b1bcf8fc953..12e0284125d 100644 --- a/ocaml/xapi/db_gc.ml +++ b/ocaml/xapi/db_gc.ml @@ -152,8 +152,7 @@ let detect_rolling_upgrade ~__context = Helpers.Checks.RPU.pool_has_different_host_platform_versions ~__context in (* Check the current state of the Pool as indicated by the Pool.other_config:rolling_upgrade_in_progress *) - let pools = Db.Pool.get_all ~__context in - match pools with + match Db.Pool.get_all ~__context with | [] -> debug "Ignoring absence of pool record in detect_rolling_upgrade: this is \ diff --git a/ocaml/xapi/dbsync_master.ml b/ocaml/xapi/dbsync_master.ml index 26657d758eb..dbf6080f458 100644 --- a/ocaml/xapi/dbsync_master.ml +++ b/ocaml/xapi/dbsync_master.ml @@ -25,8 +25,7 @@ open Recommendations (* create pool record (if master and not one already there) *) let create_pool_record ~__context = - let pools = Db.Pool.get_all ~__context in - if pools = [] then + if Db.Pool.get_all ~__context = [] then Db.Pool.create ~__context ~ref:(Ref.make ()) ~uuid:(Uuidx.to_string (Uuidx.make ())) ~name_label:"" ~name_description:"" diff --git a/ocaml/xapi/helpers.ml b/ocaml/xapi/helpers.ml index 492b054cd28..32fb3c97d89 100644 --- a/ocaml/xapi/helpers.ml +++ b/ocaml/xapi/helpers.ml @@ -142,7 +142,12 @@ let checknull f = try f () with _ -> "" let ignore_invalid_ref f (x : 'a Ref.t) = try Ref.to_option (f x) with Db_exn.DBCache_NotFound _ -> None -let get_pool ~__context = List.hd (Db.Pool.get_all ~__context) +let get_pool ~__context = + match Db.Pool.get_all ~__context with + | [] -> + raise (Failure "Helpers.get_pool: No pool available") + | pool :: _ -> + pool let get_master ~__context = Db.Pool.get_master ~__context ~self:(get_pool ~__context) diff --git a/ocaml/xapi/message_forwarding.ml b/ocaml/xapi/message_forwarding.ml index af2b1aa1458..060195e120a 100644 --- a/ocaml/xapi/message_forwarding.ml +++ b/ocaml/xapi/message_forwarding.ml @@ -363,8 +363,15 @@ functor with _ -> "invalid" let current_pool_uuid ~__context = + let get_pool_record () = + match Db.Pool.get_all_records ~__context with + | [] -> + raise (Failure "current_pool_uuid: no pool available") + | (_, pool) :: _ -> + pool + in if Pool_role.is_master () then - let _, pool = List.hd (Db.Pool.get_all_records ~__context) in + let pool = get_pool_record () in Printf.sprintf "%s%s" pool.API.pool_uuid (add_brackets pool.API.pool_name_label) else diff --git a/ocaml/xapi/xapi_pool_patch.ml b/ocaml/xapi/xapi_pool_patch.ml index 4c30792b7f0..a1d006e688a 100644 --- a/ocaml/xapi/xapi_pool_patch.ml +++ b/ocaml/xapi/xapi_pool_patch.ml @@ -61,7 +61,7 @@ let pool_patch_upload_handler (req : Http.Request.t) s _ = | Some _ -> query (* There was already an SR specified *) | None -> - let pool = Db.Pool.get_all ~__context |> List.hd in + let pool = Helpers.get_pool ~__context in let default_SR = Db.Pool.get_default_SR ~__context ~self:pool in ("sr_id", Ref.string_of default_SR) :: query in diff --git a/quality-gate.sh b/quality-gate.sh index 018e498c85b..c7965c34f0e 100755 --- a/quality-gate.sh +++ b/quality-gate.sh @@ -3,7 +3,7 @@ set -e list-hd () { - N=266 + N=253 LIST_HD=$(git grep -r --count 'List.hd' -- **/*.ml | cut -d ':' -f 2 | paste -sd+ - | bc) if [ "$LIST_HD" -eq "$N" ]; then echo "OK counted $LIST_HD List.hd usages"