ocaml: remove List.hd usages

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)

ocaml/database/db_cache_impl.mli

@@ -4,8 +4,8 @@ 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] *)
+(** [flush_and_exit db code] flushes the specific backend [db] and exits xapi
+    with [code] *)
 
 val sync : Parse_db_conf.db_connection list -> Db_cache_types.Database.t -> unit
 (** [sync db] forcibly flushes the database to disk *)

ocaml/database/db_connections.ml

@@ -54,7 +54,12 @@ 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 () =
+  match Db_conn_store.read_db_connections () with
+  | [] ->
+      raise Db_exn.Db_not_initialized
+  | x :: _ ->
+      x
 
 (* !!! FIX ME *)
 
@@ -75,14 +80,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

ocaml/database/db_connections.mli

@@ -18,6 +18,9 @@ val choose :
   Parse_db_conf.db_connection list -> Parse_db_conf.db_connection option
 
 val preferred_write_db : unit -> Parse_db_conf.db_connection
+(** [preferred_write_db ()] returns the database connection currently
+    available for writing. Raises [Db_not_initialized] if there's none available
+  *)
 
 val exit_on_next_flush : bool ref
 

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

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

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

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

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

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 =

ocaml/libs/pciutil/dune

@@ -4,6 +4,7 @@
   (libraries
     threads
     unix
+    xapi-stdext-std
     xapi-stdext-unix
   )
 )

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]
+  |> Xapi_stdext_std.Listext.List.head
+  |> Option.map (fun path -> parse_from path vendor device)
+  |> function
+  | Some vd ->
+      vd
+  | None ->
+      (unknown_vendor vendor, unknown_device device)

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 ;

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 ->
@@ -75,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

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

@@ -33,9 +33,16 @@ 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 [l] or [None] if [l] is empty *)
+
+  val last : 'a list -> 'a option
+  (** [last l] returns the last element of [l] or None if [l] 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. Returns the
+      first [Error] result encountered or, if no errors were produced, returns
+      all 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}[ (]

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,8 +31,10 @@ 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
+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 =
@@ -114,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
@@ -124,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 =
@@ -160,6 +152,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 +230,7 @@ let () =
     ; test_drop
     ; test_last
     ; test_split_at
+    ; test_try_map
     ; test_find_minimum_int
     ; test_find_minimum_tuple
     ]

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

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 =

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 ->

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 *)

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