ocaml: reduce number of problematic List.hd

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 _ -> ()

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

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

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 ;

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

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"

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 \

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

ocaml/xapi/helpers.ml

@@ -142,7 +142,12 @@ let checknull f = try f () with _ -> "<not in database>"
 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)

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

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