From 77af921e494152e7b901c274df7015dd8121d693 Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Tue, 16 Dec 2025 14:55:52 +0000 Subject: [PATCH 1/6] libs: add try_map to listext This function is useful to apply a function to a list that may fail, it returns the first error, or all the successful results. Signed-off-by: Pau Ruiz Safont --- .../lib/xapi-stdext-std/listext.ml | 10 +++++++ .../lib/xapi-stdext-std/listext.mli | 4 +++ .../lib/xapi-stdext-std/listext_test.ml | 30 +++++++++++++++++++ 3 files changed, 44 insertions(+) diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/listext.ml b/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/listext.ml index 9336429ee3b..8d1b24edf0c 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/listext.ml +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/listext.ml @@ -57,6 +57,16 @@ module List = struct let mapi_tr f l = rev (rev_mapi f l) + let try_map f l = + let rec loop acc = function + | [] -> + Ok (List.rev acc) + | x :: xs -> ( + match f x with Ok x -> loop (x :: acc) xs | Error _ as e -> e + ) + in + loop [] l + let take n list = let rec loop i acc = function | x :: xs when i < n -> diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/listext.mli b/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/listext.mli index 3de05254e70..53d6873bc64 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/listext.mli +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/listext.mli @@ -37,6 +37,10 @@ module List : sig (** [last l] returns the last element of a list or raise Invalid_argument if the list is empty *) + val try_map : ('a -> ('b, 'c) result) -> 'a list -> ('b list, 'c) result + (** [try_map f l] applies f to all elements of l, in turn and returns the + first [error]. If none were return, returns the [Ok results] *) + val rev_mapi : (int -> 'a -> 'b) -> 'a list -> 'b list (** [rev_map f l] gives the same result as {!Stdlib.List.rev}[ (] {!Stdlib.List.mapi}[ f l)], but is tail-recursive and more efficient. *) diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/listext_test.ml b/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/listext_test.ml index 39224f40be6..7b5139ad3a6 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/listext_test.ml +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/listext_test.ml @@ -35,6 +35,12 @@ let test_error tested_f (name, case, expected) = let check () = Alcotest.check_raises name expected (tested_f case) in (name, `Quick, check) +let test_try_map tested_f (name, case, expected) = + let check () = + Alcotest.(check @@ result (list int) int) name expected (tested_f case) + in + (name, `Quick, check) + let test_iteri_right = let specs = [ @@ -160,6 +166,29 @@ let test_split_at = let tests = List.map test specs in ("split_at", tests) +let test_try_map = + let only_positive = function i when i >= 0 -> Ok i | i -> Error i in + let specs = + [ + ([], Ok []) + ; ([0; 1], Ok [0; 1]) + ; ([-1], Error (-1)) + ; ([-2; 0], Error (-2)) + ; ([0; -3], Error (-3)) + ; ([-4; -3], Error (-4)) + ] + in + let test (lst, expected) = + let name = + Printf.sprintf "try_map only_positive [%s]" + (String.concat "; " (List.map string_of_int lst)) + in + test_try_map (Listext.try_map only_positive) (name, lst, expected) + in + + let tests = List.map test specs in + ("try_map", tests) + let test_find_minimum (name, pp, typ, specs) = let test ((cmp, cmp_name), input, expected) = let name = Printf.sprintf "%s of [%s]" cmp_name (pp input) in @@ -215,6 +244,7 @@ let () = ; test_drop ; test_last ; test_split_at + ; test_try_map ; test_find_minimum_int ; test_find_minimum_tuple ] From 1ab798a4cb792d27bfb9f659419648a1c6904644 Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Fri, 28 Nov 2025 14:07:16 +0000 Subject: [PATCH 2/6] database: replace List.hd with Db_not_initialized on flush This makes the exception much more recognizable and easier to locate. Signed-off-by: Pau Ruiz Safont --- ocaml/database/db_cache_impl.ml | 6 +++++- ocaml/database/db_cache_impl.mli | 6 +++--- ocaml/database/db_connections.ml | 16 ++++++++++------ ocaml/database/db_connections.mli | 2 +- ocaml/database/db_exn.ml | 2 ++ ocaml/database/db_exn.mli | 2 ++ 6 files changed, 23 insertions(+), 11 deletions(-) diff --git a/ocaml/database/db_cache_impl.ml b/ocaml/database/db_cache_impl.ml index 56ab07cab46..98c0fde7098 100644 --- a/ocaml/database/db_cache_impl.ml +++ b/ocaml/database/db_cache_impl.ml @@ -432,7 +432,11 @@ let sync conns db = let flush_dirty dbconn = Db_connections.flush_dirty_and_maybe_exit dbconn None let flush_and_exit dbconn ret_code = - ignore (Db_connections.flush_dirty_and_maybe_exit dbconn (Some ret_code)) + match dbconn with + | Some dbconn -> + ignore (Db_connections.flush_dirty_and_maybe_exit dbconn (Some ret_code)) + | None -> + raise Db_not_initialized let spawn_db_flush_threads () = (* Spawn threads that flush cache to db connections at regular intervals *) diff --git a/ocaml/database/db_cache_impl.mli b/ocaml/database/db_cache_impl.mli index 8dd161b0f8e..77f94ea4dfc 100644 --- a/ocaml/database/db_cache_impl.mli +++ b/ocaml/database/db_cache_impl.mli @@ -3,9 +3,9 @@ include Db_interface.DB_ACCESS2 val make : Db_ref.t -> Parse_db_conf.db_connection list -> Schema.t -> unit (** [make t connections default_schema] initialises the in-memory cache *) -val flush_and_exit : Parse_db_conf.db_connection -> int -> unit -(** [flush_and_exit db code] flushes the specific backend [db] and exits - xapi with [code] *) +val flush_and_exit : Parse_db_conf.db_connection option -> int -> unit +(** [flush_and_exit db code] flushes the specific backend [db] and exits xapi + with [code]. Raises Db_not_initialized if db is None *) val sync : Parse_db_conf.db_connection list -> Db_cache_types.Database.t -> unit (** [sync db] forcibly flushes the database to disk *) diff --git a/ocaml/database/db_connections.ml b/ocaml/database/db_connections.ml index 18152a18c4e..2afb207596f 100644 --- a/ocaml/database/db_connections.ml +++ b/ocaml/database/db_connections.ml @@ -54,7 +54,8 @@ let choose connections = most_recent.Parse_db_conf.path gen ; Some most_recent -let preferred_write_db () = List.hd (Db_conn_store.read_db_connections ()) +let preferred_write_db () = + List.nth_opt (Db_conn_store.read_db_connections ()) 0 (* !!! FIX ME *) @@ -75,14 +76,17 @@ let pre_exit_hook () = R.debug "Closed all active redo logs." (* The connection flushing calls each lock the connection they're flushing to. - The backend flush calls have to do enough locking (i.e. with the db_lock) to ensure that they - flush a consistent snapshot. Backends must also ensure that they do not hold the global db_lock - whilst they are writing to non-local storage. + The backend flush calls have to do enough locking (i.e. with the db_lock) to + ensure that they flush a consistent snapshot. Backends must also ensure that + they do not hold the global db_lock whilst they are writing to non-local + storage. *) let flush_dirty_and_maybe_exit dbconn exit_spec = Db_conn_store.with_db_conn_lock dbconn (fun () -> - (* if we're being told to shutdown by signal handler then flush every connection - - the rationale is that we're not sure which db connections will be available on next restart *) + (* if we're being told to shutdown by signal handler then flush every + connection + - the rationale is that we're not sure which db connections will be + available on next restart *) ( if !exit_on_next_flush then let (_ : bool) = Backend_xml.flush_dirty dbconn in let refcount = dec_and_read_db_flush_thread_refcount () in diff --git a/ocaml/database/db_connections.mli b/ocaml/database/db_connections.mli index 81ec405a581..6bb7392bad3 100644 --- a/ocaml/database/db_connections.mli +++ b/ocaml/database/db_connections.mli @@ -17,7 +17,7 @@ val get_dbs_and_gen_counts : unit -> (int64 * Parse_db_conf.db_connection) list val choose : Parse_db_conf.db_connection list -> Parse_db_conf.db_connection option -val preferred_write_db : unit -> Parse_db_conf.db_connection +val preferred_write_db : unit -> Parse_db_conf.db_connection option val exit_on_next_flush : bool ref diff --git a/ocaml/database/db_exn.ml b/ocaml/database/db_exn.ml index b7a69f07a9b..a3c1c42d521 100644 --- a/ocaml/database/db_exn.ml +++ b/ocaml/database/db_exn.ml @@ -37,3 +37,5 @@ exception Remote_db_server_returned_bad_message exception Empty_key_in_map exception Invalid_value + +exception Db_not_initialized diff --git a/ocaml/database/db_exn.mli b/ocaml/database/db_exn.mli index 53b686e1f4c..d78d9f62edc 100644 --- a/ocaml/database/db_exn.mli +++ b/ocaml/database/db_exn.mli @@ -37,3 +37,5 @@ exception Remote_db_server_returned_bad_message exception Empty_key_in_map exception Invalid_value + +exception Db_not_initialized From a0610fbcb44e60be38c34cce05b06dd4bbf786f9 Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Fri, 28 Nov 2025 13:17:53 +0000 Subject: [PATCH 3/6] ocaml: remove usages of List.hd These can be easily replaced with a match against the list, or changing parameters to separate the head from the rest of the list Signed-off-by: Pau Ruiz Safont --- ocaml/libs/http-lib/http_client.ml | 4 +--- ocaml/libs/pciutil/pciutil.ml | 19 ++++++++++--------- ocaml/libs/stunnel/stunnel.ml | 7 +++---- ocaml/xapi/map_check.ml | 5 +---- ocaml/xapi/monitor_dbcalls.ml | 11 ++++++----- ocaml/xapi/xapi_role.ml | 12 ++++++------ quality-gate.sh | 2 +- 7 files changed, 28 insertions(+), 32 deletions(-) diff --git a/ocaml/libs/http-lib/http_client.ml b/ocaml/libs/http-lib/http_client.ml index 7d9cabfb741..8a744375f3d 100644 --- a/ocaml/libs/http-lib/http_client.ml +++ b/ocaml/libs/http-lib/http_client.ml @@ -69,9 +69,7 @@ let response_of_fd_exn_slow fd = let line = input_line_fd fd in let bits = Astring.String.fields ~empty:false line in (* We just ignore the initial "FRAME xxxxx" *) - let bits = - if bits <> [] && List.hd bits = "FRAME" then List.tl bits else bits - in + let bits = match bits with "FRAME" :: bits -> bits | _ -> bits in match bits with | http_version :: code :: rest -> let version = diff --git a/ocaml/libs/pciutil/pciutil.ml b/ocaml/libs/pciutil/pciutil.ml index 757ea0ce0e4..43b1297ac1d 100644 --- a/ocaml/libs/pciutil/pciutil.ml +++ b/ocaml/libs/pciutil/pciutil.ml @@ -62,12 +62,13 @@ let parse vendor device = (fun path -> try Unix.access path perms ; true with _ -> false) l in - try - (* is that the correct path ? *) - let l = - access_list - ["/usr/share/hwdata/pci.ids"; "/usr/share/misc/pci.ids"] - [Unix.R_OK] - in - parse_from (List.hd l) vendor device - with _ -> (unknown_vendor vendor, unknown_device device) + access_list + ["/usr/share/hwdata/pci.ids"; "/usr/share/misc/pci.ids"] + [Unix.R_OK] + |> Fun.flip List.nth_opt 0 + |> Option.map (fun path -> parse_from path vendor device) + |> function + | Some vd -> + vd + | None -> + (unknown_vendor vendor, unknown_device device) diff --git a/ocaml/libs/stunnel/stunnel.ml b/ocaml/libs/stunnel/stunnel.ml index 0445b4bee4c..295d5d59661 100644 --- a/ocaml/libs/stunnel/stunnel.ml +++ b/ocaml/libs/stunnel/stunnel.ml @@ -78,9 +78,8 @@ module Unsafe = struct (* Low-level (unsafe) function which forks, runs a 'pre_exec' function and then executes some other binary. It makes sure to catch any exception thrown by exec* so that we don't end up with two ocaml processes. *) - let fork_and_exec ?(pre_exec = fun () -> ()) ?env (cmdline : string list) = - let args = Array.of_list cmdline in - let argv0 = List.hd cmdline in + let fork_and_exec ?(pre_exec = fun () -> ()) ?env argv0 (args : string list) = + let args = Array.of_list (argv0 :: args) in let pid = Unix.fork () in if pid = 0 then try @@ -342,7 +341,7 @@ let attempt_one_connect ?(use_fork_exec_helper = true) List.iter Unsafe.do_fd_operation fdops ; Unixext.close_all_fds_except fds_needed ) - (path :: args) + path args ) in Unixfd.safe_close config_out ; diff --git a/ocaml/xapi/map_check.ml b/ocaml/xapi/map_check.ml index 0cb2d97e37f..8e96ff1a59a 100644 --- a/ocaml/xapi/map_check.ml +++ b/ocaml/xapi/map_check.ml @@ -132,10 +132,7 @@ let with_ks ~kss ~fn = let corrected_values = List.filter (fun cv -> cv <> None) (List.map (fun ks -> fn field ks) kss) in - if corrected_values = [] then - [] - else - match List.hd corrected_values with None -> [] | Some cv -> cv + match corrected_values with [] | None :: _ -> [] | Some cv :: _ -> cv let assert_req_values ~field ~ks ~vs = (* each required values in this ks must match the one in the vs map this key/value belongs to *) diff --git a/ocaml/xapi/monitor_dbcalls.ml b/ocaml/xapi/monitor_dbcalls.ml index 48b96bbd92a..9561135fbc4 100644 --- a/ocaml/xapi/monitor_dbcalls.ml +++ b/ocaml/xapi/monitor_dbcalls.ml @@ -95,11 +95,12 @@ let pifs_update_fn () = (fun (_, pif) -> List.hd pif.API.pIF_bond_master_of) my_bond_pifs in - if List.length my_bonds <> 1 then - debug "Error: bond %s cannot be found" bond - else - Db.Bond.set_links_up ~__context ~self:(List.hd my_bonds) - ~value:(Int64.of_int links_up) + match my_bonds with + | [self] -> + Db.Bond.set_links_up ~__context ~self + ~value:(Int64.of_int links_up) + | _ -> + debug "Error: bond %s cannot be found" bond with e -> issues := e :: !issues ; keeps := bond :: !keeps diff --git a/ocaml/xapi/xapi_role.ml b/ocaml/xapi/xapi_role.ml index fa7124d96f9..b3f84ac7dcb 100644 --- a/ocaml/xapi/xapi_role.ml +++ b/ocaml/xapi/xapi_role.ml @@ -233,12 +233,12 @@ let get_by_permission ~__context ~permission = let get_by_permission_name_label ~__context ~label = let permission = - let ps = get_by_name_label ~__context ~label in - if ps <> [] then - List.hd ps (* names are unique, there's either 0 or 1*) - else - Ref.null - (* name not found *) + match get_by_name_label ~__context ~label with + | role :: _ -> + (* names are unique, there's either 0 or 1 *) + role + | [] -> + Ref.null in get_by_permission_common ~__context ~permission ~cmp_fn:(fun perm -> label = get_name_label ~__context ~self:perm diff --git a/quality-gate.sh b/quality-gate.sh index c7965c34f0e..d214ba1a52a 100755 --- a/quality-gate.sh +++ b/quality-gate.sh @@ -3,7 +3,7 @@ set -e list-hd () { - N=253 + N=246 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 3b1c40a97885637d980fb63e59cf39e80538a0ff Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Fri, 28 Nov 2025 14:42:41 +0000 Subject: [PATCH 4/6] ocaml/libs: List.last and List.head now return options Previously an exception was raised for last, head is a new function. Also adds a latest_release to datamodel_types that can't fail after the module has been loaded. (the list is populated so it won't fail when the module is loaded either) Signed-off-by: Pau Ruiz Safont --- ocaml/idl/datamodel_types.ml | 3 +++ ocaml/idl/datamodel_types.mli | 2 ++ ocaml/idl/dm_api.ml | 4 ++-- .../lib/xapi-stdext-std/listext.ml | 10 +++------- .../lib/xapi-stdext-std/listext.mli | 8 +++++--- .../lib/xapi-stdext-std/listext_test.ml | 20 +++---------------- 6 files changed, 18 insertions(+), 29 deletions(-) diff --git a/ocaml/idl/datamodel_types.ml b/ocaml/idl/datamodel_types.ml index ea1ffd17afe..1be90528856 100644 --- a/ocaml/idl/datamodel_types.ml +++ b/ocaml/idl/datamodel_types.ml @@ -359,6 +359,9 @@ let release_order_full = let release_order = List.filter (fun x -> x.code_name <> None) release_order_full +let latest_release = + Xapi_stdext_std.Listext.List.last release_order |> Option.get + exception Unknown_release of string exception UnspecifiedRelease diff --git a/ocaml/idl/datamodel_types.mli b/ocaml/idl/datamodel_types.mli index 09a43615b70..cda1ef806ca 100644 --- a/ocaml/idl/datamodel_types.mli +++ b/ocaml/idl/datamodel_types.mli @@ -80,6 +80,8 @@ val release_order_full : api_release list val release_order : api_release list +val latest_release : api_release + exception Unknown_release of string exception UnspecifiedRelease diff --git a/ocaml/idl/dm_api.ml b/ocaml/idl/dm_api.ml index 83b3ac6b37e..9629b2c0052 100644 --- a/ocaml/idl/dm_api.ml +++ b/ocaml/idl/dm_api.ml @@ -369,6 +369,7 @@ let check api emergency_calls = let are_in_vsn_order ps = let release_lt x y = release_leq x y && x <> y in let in_since releases = + let last = code_name_of_release latest_release in (* been in since the lowest of releases *) List.fold_left (fun sofar r -> @@ -378,8 +379,7 @@ let check api emergency_calls = | r -> if release_lt r sofar then r else sofar ) - (Xapi_stdext_std.Listext.List.last release_order |> code_name_of_release) - releases + last releases in let rec check_vsns max_release_sofar ps = match ps with diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/listext.ml b/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/listext.ml index 8d1b24edf0c..411d6ab214a 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/listext.ml +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/listext.ml @@ -85,13 +85,9 @@ module List = struct in loop 0 list - let rec last = function - | [] -> - invalid_arg "last: empty list" - | [x] -> - x - | _ :: xs -> - last xs + let head = function [] -> None | x :: _ -> Some x + + let rec last = function [] -> None | [x] -> Some x | _ :: xs -> last xs let split_at n list = let rec loop i acc = function diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/listext.mli b/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/listext.mli index 53d6873bc64..dd69a9e9422 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/listext.mli +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/listext.mli @@ -33,9 +33,11 @@ module List : sig element being the rest of elements of the list (or [] if the list is shorter). The results with negative values of [n] are the same as using 0. *) - val last : 'a list -> 'a - (** [last l] returns the last element of a list or raise Invalid_argument if - the list is empty *) + val head : 'a list -> 'a option + (** [head l] returns the first element of [lst] or None if [lst] is empty *) + + val last : 'a list -> 'a option + (** [last lst] returns the last element of [lst] or None if [lst] is empty *) val try_map : ('a -> ('b, 'c) result) -> 'a list -> ('b list, 'c) result (** [try_map f l] applies f to all elements of l, in turn and returns the diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/listext_test.ml b/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/listext_test.ml index 7b5139ad3a6..89acc03a043 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/listext_test.ml +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/listext_test.ml @@ -14,7 +14,7 @@ module Listext = Xapi_stdext_std.Listext.List let test_last_list tested_f (name, case, expected) = - let check () = Alcotest.(check @@ int) name expected (tested_f case) in + let check () = Alcotest.(check @@ option int) name expected (tested_f case) in (name, `Quick, check) let test_list tested_f (name, case, expected) = @@ -31,10 +31,6 @@ let test_split_at_list tested_f (name, case, expected) = in (name, `Quick, check) -let test_error tested_f (name, case, expected) = - let check () = Alcotest.check_raises name expected (tested_f case) in - (name, `Quick, check) - let test_try_map tested_f (name, case, expected) = let check () = Alcotest.(check @@ result (list int) int) name expected (tested_f case) @@ -120,8 +116,7 @@ let test_drop = ("drop", tests) let test_last = - let specs = [([1], 0, 1); ([1; 2; 3], 1, 3)] in - let error_specs = [([], -1, Invalid_argument "last: empty list")] in + let specs = [([1], 0, Some 1); ([1; 2; 3], 1, Some 3); ([], -1, None)] in let test_good (whole, number, expected) = let name = Printf.sprintf "get last %i from [%s]" number @@ -130,16 +125,7 @@ let test_last = test_last_list Listext.last (name, whole, expected) in let tests = List.map test_good specs in - let error_test (whole, number, error) = - let name = - Printf.sprintf "last [%s] with %i fails" - (String.concat "; " (List.map string_of_int whole)) - number - in - test_error (fun ls () -> ignore (Listext.last ls)) (name, whole, error) - in - let error_tests = List.map error_test error_specs in - ("last", tests @ error_tests) + ("last", tests) let test_split_at = let specs = From 3ceaad60ddf7e51b310c9e59ce898b79c3b5a53d Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Fri, 28 Nov 2025 15:05:31 +0000 Subject: [PATCH 5/6] ocaml: replace List.(hd (rev list)) with List.last This forces users to deal with None in the new code. One of them is replace with the new function List.try_map that returns the first error. While split_on_char never returns an empty list, it's a good test for using try_map Signed-off-by: Pau Ruiz Safont --- ocaml/xapi/rbac_audit.ml | 42 +++++++++++++++++++----------------- ocaml/xapi/storage_access.ml | 16 ++++++++++---- quality-gate.sh | 2 +- 3 files changed, 35 insertions(+), 25 deletions(-) diff --git a/ocaml/xapi/rbac_audit.ml b/ocaml/xapi/rbac_audit.ml index bbc5a7a6fc9..d78dc5b6df7 100644 --- a/ocaml/xapi/rbac_audit.ml +++ b/ocaml/xapi/rbac_audit.ml @@ -133,26 +133,28 @@ let populate_audit_record_with_obj_names_of_refs line = let sexpr_idx = String.index line ']' + 1 in let before_sexpr_str = String.sub line 0 sexpr_idx in (* remove the [...] prefix *) - let sexpr_str = - Xapi_stdext_std.Xstringext.String.sub_to_end line sexpr_idx - in - let sexpr = SExpr_TS.of_string sexpr_str in - match sexpr with - | SExpr.Node [] -> - line - | SExpr.Node els -> ( - let (args : SExpr.t) = List.hd (List.rev els) in - match List.partition (fun (e : SExpr.t) -> e <> args) els with - | prefix, [SExpr.Node arg_list] -> - (* paste together the prefix of original audit record *) - let the_sexpr = - SExpr.Node (prefix @ [SExpr.Node (get_obj_names_of_refs arg_list)]) - in - String.concat " " [before_sexpr_str; SExpr.string_of the_sexpr] - | _ -> - line - ) - | _ -> + (Xapi_stdext_std.Xstringext.String.sub_to_end line sexpr_idx + |> SExpr_TS.of_string + |> function + | SExpr.Node list -> + Xapi_stdext_std.Listext.List.last list + |> Option.map (fun last -> (list, last)) + | _ -> + None + ) + |> function + | Some (els, args) -> ( + match List.partition (fun (e : SExpr.t) -> e <> args) els with + | prefix, [SExpr.Node arg_list] -> + (* paste together the prefix of original audit record *) + let the_sexpr = + SExpr.Node (prefix @ [SExpr.Node (get_obj_names_of_refs arg_list)]) + in + String.concat " " [before_sexpr_str; SExpr.string_of the_sexpr] + | _ -> + line + ) + | None -> line with e -> D.debug "error populating audit record arg names: %s" diff --git a/ocaml/xapi/storage_access.ml b/ocaml/xapi/storage_access.ml index cda399e9d60..319fbccd786 100644 --- a/ocaml/xapi/storage_access.ml +++ b/ocaml/xapi/storage_access.ml @@ -152,11 +152,19 @@ let on_xapi_start ~__context = (* The results include the prefix itself, but that is the main storage queue, we don't need it *) |> List.filter (( <> ) !Storage_interface.queue_name) - |> List.map (fun driver -> - (* Get the last component of the queue name: org.xen.xapi.storage.sr_type -> sr_type *) - (* split_on_char returns a non-empty list *) - String.split_on_char '.' driver |> List.rev |> List.hd + |> Listext.List.try_map (fun driver -> + (* Get the last component of the queue name: + org.xen.xapi.storage.sr_type -> sr_type *) + driver + |> String.split_on_char '.' + |> Listext.List.last + |> Option.to_result ~none:(Invalid_argument driver) ) + |> function + | Ok drivers -> + drivers + | Error exn -> + raise exn with | Message_switch_failure -> [] (* no more logging *) diff --git a/quality-gate.sh b/quality-gate.sh index d214ba1a52a..8af2794bf45 100755 --- a/quality-gate.sh +++ b/quality-gate.sh @@ -3,7 +3,7 @@ set -e list-hd () { - N=246 + N=244 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 dec6b8f6e2274b1184ed8dd317d8ca889368e3f8 Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Tue, 9 Dec 2025 14:02:52 +0000 Subject: [PATCH 6/6] ocaml: use new List.head instead of List.nth_opt The return type is the same, but it's more obvious to see what it does Signed-off-by: Pau Ruiz Safont --- dune-project | 1 + ocaml/database/db_connections.ml | 2 +- ocaml/libs/pciutil/dune | 1 + ocaml/libs/pciutil/pciutil.ml | 2 +- ocaml/xapi-aux/dune | 1 + ocaml/xapi-aux/networking_info.ml | 6 ++-- ocaml/xapi/import.ml | 3 +- ocaml/xapi/xapi_pif_helpers.ml | 2 +- ocaml/xapi/xapi_sm.ml | 23 ++++++++------- ocaml/xapi/xapi_vdi.ml | 30 ++++++-------------- ocaml/xcp-rrdd/bin/rrdd/dune | 1 + ocaml/xcp-rrdd/bin/rrdd/rrdd_http_handler.ml | 2 +- ocaml/xcp-rrdd/bin/rrdp-dcmi/dune | 1 + opam/xapi-tools.opam | 1 + 14 files changed, 35 insertions(+), 41 deletions(-) diff --git a/dune-project b/dune-project index c5889ff42ac..8f5190c95d0 100644 --- a/dune-project +++ b/dune-project @@ -361,6 +361,7 @@ ; because it is not in xs-opam yet rrd-transport rrdd-plugin + xapi-stdext-std xapi-tracing-export xen-api-client (alcotest :with-test) diff --git a/ocaml/database/db_connections.ml b/ocaml/database/db_connections.ml index 2afb207596f..87083fdab7e 100644 --- a/ocaml/database/db_connections.ml +++ b/ocaml/database/db_connections.ml @@ -55,7 +55,7 @@ let choose connections = Some most_recent let preferred_write_db () = - List.nth_opt (Db_conn_store.read_db_connections ()) 0 + Xapi_stdext_std.Listext.List.head (Db_conn_store.read_db_connections ()) (* !!! FIX ME *) diff --git a/ocaml/libs/pciutil/dune b/ocaml/libs/pciutil/dune index 44240eff3d8..08d1b1751ba 100644 --- a/ocaml/libs/pciutil/dune +++ b/ocaml/libs/pciutil/dune @@ -4,6 +4,7 @@ (libraries threads unix + xapi-stdext-std xapi-stdext-unix ) ) diff --git a/ocaml/libs/pciutil/pciutil.ml b/ocaml/libs/pciutil/pciutil.ml index 43b1297ac1d..cabcc1865d8 100644 --- a/ocaml/libs/pciutil/pciutil.ml +++ b/ocaml/libs/pciutil/pciutil.ml @@ -65,7 +65,7 @@ let parse vendor device = access_list ["/usr/share/hwdata/pci.ids"; "/usr/share/misc/pci.ids"] [Unix.R_OK] - |> Fun.flip List.nth_opt 0 + |> Xapi_stdext_std.Listext.List.head |> Option.map (fun path -> parse_from path vendor device) |> function | Some vd -> diff --git a/ocaml/xapi-aux/dune b/ocaml/xapi-aux/dune index 8eebb6edc41..85d86248022 100644 --- a/ocaml/xapi-aux/dune +++ b/ocaml/xapi-aux/dune @@ -16,6 +16,7 @@ xapi-idl.network xapi-inventory xapi-log + xapi-stdext-std xapi-stdext-threads xapi-stdext-unix xml-light2 diff --git a/ocaml/xapi-aux/networking_info.ml b/ocaml/xapi-aux/networking_info.ml index 928ad45322b..388ad251815 100644 --- a/ocaml/xapi-aux/networking_info.ml +++ b/ocaml/xapi-aux/networking_info.ml @@ -15,6 +15,8 @@ module Net = Network_client.Client module L = Debug.Make (struct let name = __MODULE__ end) +module Listext = Xapi_stdext_std.Listext.List + let get_hostname () = try Unix.gethostname () with _ -> "" type management_ip_error = @@ -99,7 +101,7 @@ let get_management_ip_addrs ~dbg = let get_management_ip_addr ~dbg = match get_management_ip_addrs ~dbg with | Ok (preferred, _) -> - List.nth_opt preferred 0 |> Option.map Ipaddr.to_string + Listext.head preferred |> Option.map Ipaddr.to_string | Error _ -> None @@ -113,7 +115,7 @@ let get_host_certificate_subjects ~dbg = let ips = List.(rev_append (rev preferred) others) in Option.fold ~none:(Error IP_missing) ~some:(fun ip -> Ok (List.map ipaddr_to_octets ips, ip)) - (List.nth_opt ips 0) + (Listext.head ips) in let dns_names = dns_names () in let name = diff --git a/ocaml/xapi/import.ml b/ocaml/xapi/import.ml index 04306cff5f6..335ea5fe513 100644 --- a/ocaml/xapi/import.ml +++ b/ocaml/xapi/import.ml @@ -439,9 +439,8 @@ module VM : HandlerTools = struct in let maybe_template = - List.nth_opt + Listext.List.head (Db.VM.get_by_name_label ~__context ~label:vm_record.API.vM_name_label) - 0 in match (is_default_template, maybe_template) with | true, Some template -> diff --git a/ocaml/xapi/xapi_pif_helpers.ml b/ocaml/xapi/xapi_pif_helpers.ml index b43891b935a..3a833e40570 100644 --- a/ocaml/xapi/xapi_pif_helpers.ml +++ b/ocaml/xapi/xapi_pif_helpers.ml @@ -273,7 +273,7 @@ let get_primary_address ~__context ~pif = match Db.PIF.get_IP ~__context ~self:pif with "" -> None | ip -> Some ip ) | `IPv6 -> - List.nth_opt (get_non_link_ipv6 ~__context ~pif) 0 + Xapi_stdext_std.Listext.List.head (get_non_link_ipv6 ~__context ~pif) let get_pif_position ~__context ~pif_rec = let n_of_xenbrn_opt bridge = diff --git a/ocaml/xapi/xapi_sm.ml b/ocaml/xapi/xapi_sm.ml index 769484ddd7f..ec44b20a03a 100644 --- a/ocaml/xapi/xapi_sm.ml +++ b/ocaml/xapi/xapi_sm.ml @@ -78,17 +78,18 @@ let addto_pending_hosts_features ~__context self new_features = curr_pending_features let valid_hosts_pending_features ~__context pending_features = - if List.length pending_features <> List.length (Db.Host.get_all ~__context) - then ( - debug "%s: Not enough hosts have registered their sm features" __FUNCTION__ ; - [] - ) else - List.map snd pending_features |> fun l -> - List.fold_left Smint.Feature.compat_features - (* The list in theory cannot be empty due to the if condition check, but do - this just in case *) - (List.nth_opt l 0 |> Option.fold ~none:[] ~some:Fun.id) - (List.tl l) + let __FUN = __FUNCTION__ in + let not_enough_msg () = + debug "%s: Not enough hosts have registered their sm features" __FUN + in + match pending_features with + | [] -> + not_enough_msg () ; [] + | features + when List.compare_lengths features (Db.Host.get_all ~__context) <> 0 -> + not_enough_msg () ; [] + | (_, x) :: xs -> + List.fold_left Smint.Feature.compat_features x (List.map snd xs) let remove_valid_features_from_pending ~__context ~self valid_features = let valid_features = List.map Smint.Feature.unparse valid_features in diff --git a/ocaml/xapi/xapi_vdi.ml b/ocaml/xapi/xapi_vdi.ml index 1148efe09c5..dbee27e763d 100644 --- a/ocaml/xapi/xapi_vdi.ml +++ b/ocaml/xapi/xapi_vdi.ml @@ -886,28 +886,14 @@ let wait_for_vbds_to_be_unplugged_and_destroyed ~__context ~self ~timeout = let classes = [Printf.sprintf "VDI/%s" (Ref.string_of self)] in let next_token_and_vbds ~token ~timeout = let most_recent_vbds_field events = - (* We do not assume anything here about the order of the list of events we get. *) - let most_recent_snapshot = - let events_from_newest_to_oldest = - (* We need to sort the timestamp strings in decreasing order *) - List.sort - (fun e1 e2 -> Event_types.(-String.compare e1.ts e2.ts)) - events - in - let snapshots_from_newest_to_oldest = - (* filter_map preserves the order of elements *) - List.filter_map - (fun event -> event.Event_types.snapshot) - events_from_newest_to_oldest - in - List.nth_opt snapshots_from_newest_to_oldest 0 - in - Option.map - (fun snapshot -> - let vdi = API.vDI_t_of_rpc snapshot in - vdi.API.vDI_VBDs - ) - most_recent_snapshot + (* We need to sort the timestamp strings in decreasing order *) + List.sort (fun e1 e2 -> Event_types.(-String.compare e1.ts e2.ts)) events + |> List.filter_map (fun event -> event.Event_types.snapshot) + |> Xapi_stdext_std.Listext.List.head + |> Option.map (fun snapshot -> + let vdi = API.vDI_t_of_rpc snapshot in + vdi.API.vDI_VBDs + ) in let from = let timeout = Scheduler.span_to_s timeout in diff --git a/ocaml/xcp-rrdd/bin/rrdd/dune b/ocaml/xcp-rrdd/bin/rrdd/dune index 5b8936e4f8b..5dc5bcd1b3b 100644 --- a/ocaml/xcp-rrdd/bin/rrdd/dune +++ b/ocaml/xcp-rrdd/bin/rrdd/dune @@ -28,6 +28,7 @@ xapi-rrd xapi-rrd.unix rrdd_libs + xapi-stdext-std xapi-stdext-threads xapi-stdext-unix xmlm diff --git a/ocaml/xcp-rrdd/bin/rrdd/rrdd_http_handler.ml b/ocaml/xcp-rrdd/bin/rrdd/rrdd_http_handler.ml index 0f0c3e5ffbc..24fa2ba715a 100644 --- a/ocaml/xcp-rrdd/bin/rrdd/rrdd_http_handler.ml +++ b/ocaml/xcp-rrdd/bin/rrdd/rrdd_http_handler.ml @@ -19,7 +19,7 @@ let content_xml = content_hdr_of_mime mime_xml let client_prefers_json req = let module Accept = Http.Accept in let ( let* ) = Option.bind in - let map_head f lst = List.nth_opt lst 0 |> Option.map f in + let map_head f lst = Xapi_stdext_std.Listext.List.head lst |> Option.map f in let prefers_json = let* accept = req.Http.Request.accept in let* accepted = diff --git a/ocaml/xcp-rrdd/bin/rrdp-dcmi/dune b/ocaml/xcp-rrdd/bin/rrdp-dcmi/dune index 80103ece943..d948c822411 100644 --- a/ocaml/xcp-rrdd/bin/rrdp-dcmi/dune +++ b/ocaml/xcp-rrdd/bin/rrdp-dcmi/dune @@ -8,6 +8,7 @@ xapi-idl.rrd xapi-log xapi-rrd + xapi-stdext-std astring ) ) diff --git a/opam/xapi-tools.opam b/opam/xapi-tools.opam index 1cf69ff6a7f..4eb45997bff 100644 --- a/opam/xapi-tools.opam +++ b/opam/xapi-tools.opam @@ -30,6 +30,7 @@ depends: [ "yojson" "rrd-transport" "rrdd-plugin" + "xapi-stdext-std" "xapi-tracing-export" "xen-api-client" "alcotest" {with-test}