xapi: remove some usages of common, exception-raising functions

The Not_found and hd exceptions keep popping up, and it's difficult to
find them when there are no backtraces logged.
Remove usages if them, even if they are not problematic so the actual
problematic ones can be flushed out over time.

Signed-off-by: Pau Ruiz Safont <pau.safont@vates.tech>

Author: psafont

ocaml/xapi/create_storage.ml

@@ -81,14 +81,16 @@ let maybe_create_pbd rpc session_id sr device_config me =
   in
   (* Check not more than 1 pbd in the database *)
   let pbds =
-    if List.length pbds > 1 then (
-      (* shouldn't happen... delete all but first pbd to make db consistent again *)
-      List.iter
-        (fun pbd -> Client.PBD.destroy ~rpc ~session_id ~self:pbd)
-        (List.tl pbds) ;
-      [List.hd pbds]
-    ) else
-      pbds
+    match pbds with
+    | [] | [_] ->
+        pbds
+    | pbd :: pbds ->
+        (* shouldn't happen... delete all but first pbd to make db consistent
+           again *)
+        List.iter
+          (fun pbd -> Client.PBD.destroy ~rpc ~session_id ~self:pbd)
+          pbds ;
+        [pbd]
   in
   if pbds = [] (* If there's no PBD, create it *) then
     Client.PBD.create ~rpc ~session_id ~host:me ~sR:sr ~device_config
@@ -153,17 +155,16 @@ let initialise_storage (me : API.ref_host) rpc session_id __context : unit =
       List.filter (fun (_, pbd_rec) -> pbd_rec.API.pBD_host = master) pbds
     in
     let maybe_create_pbd_for_shared_sr s =
-      let _, mpbd_rec =
-        List.find (fun (_, pbdr) -> pbdr.API.pBD_SR = s) master_pbds
-      in
-      let master_devconf = mpbd_rec.API.pBD_device_config in
-      let my_devconf = List.remove_assoc "SRmaster" master_devconf in
-      (* this should never be used *)
-      maybe_create_pbd rpc session_id s my_devconf me
+      List.find_opt (fun (_, pbdr) -> pbdr.API.pBD_SR = s) master_pbds
+      |> Option.iter @@ fun (_, mpbd_rec) ->
+         let master_devconf = mpbd_rec.API.pBD_device_config in
+         let my_devconf = List.remove_assoc "SRmaster" master_devconf in
+         try
+           (maybe_create_pbd rpc session_id s my_devconf me : [`PBD] Ref.t)
+           |> ignore
+         with _ -> ()
     in
-    List.iter
-      (fun s -> try ignore (maybe_create_pbd_for_shared_sr s) with _ -> ())
-      shared_sr_refs
+    List.iter maybe_create_pbd_for_shared_sr shared_sr_refs
   in
   let other_config =
     try
@@ -173,9 +174,8 @@ let initialise_storage (me : API.ref_host) rpc session_id __context : unit =
   in
   if
     not
-      (List.mem_assoc Xapi_globs.sync_create_pbds other_config
-      && List.assoc Xapi_globs.sync_create_pbds other_config
-         = Xapi_globs.sync_switch_off
+      (List.assoc_opt Xapi_globs.sync_create_pbds other_config
+      = Some Xapi_globs.sync_switch_off
       )
   then (
     debug "Creating PBDs for shared SRs" ;

ocaml/xapi/system_domains.ml

@@ -148,36 +148,6 @@ let is_in_use ~__context ~self =
   else
     false
 
-(* [wait_for ?timeout f] returns true if [f()] (called at 1Hz) returns true within
-   the [timeout] period and false otherwise *)
-let wait_for ?(timeout = 120.) f =
-  let start = Unix.gettimeofday () in
-  let finished = ref false in
-  let success = ref false in
-  while not !finished do
-    let remaining = timeout -. (Unix.gettimeofday () -. start) in
-    if remaining < 0. then
-      finished := true
-    else
-      try
-        if f () then (
-          success := true ;
-          finished := true
-        ) else
-          Thread.delay 1.
-      with _ -> Thread.delay 1.
-  done ;
-  !success
-
-let pingable ip () =
-  try
-    let (_ : string * string) =
-      Forkhelpers.execute_command_get_output "/bin/ping"
-        ["-c"; "1"; "-w"; "1"; ip]
-    in
-    true
-  with _ -> false
-
 let queryable ~__context transport () =
   let open Xmlrpc_client in
   let tracing = Context.set_client_span __context in
@@ -197,47 +167,6 @@ let queryable ~__context transport () =
       (Printexc.to_string e) ;
     false
 
-let ip_of ~__context driver =
-  (* Find the VIF on the Host internal management network *)
-  let vifs = Db.VM.get_VIFs ~__context ~self:driver in
-  let hin = Helpers.get_host_internal_management_network ~__context in
-  let ip =
-    let vif =
-      try
-        List.find
-          (fun vif -> Db.VIF.get_network ~__context ~self:vif = hin)
-          vifs
-      with Not_found ->
-        failwith
-          (Printf.sprintf
-             "driver domain %s has no VIF on host internal management network"
-             (Ref.string_of driver)
-          )
-    in
-    match Xapi_udhcpd.get_ip ~__context vif with
-    | Some (a, b, c, d) ->
-        Printf.sprintf "%d.%d.%d.%d" a b c d
-    | None ->
-        failwith
-          (Printf.sprintf
-             "driver domain %s has no IP on the host internal management \
-              network"
-             (Ref.string_of driver)
-          )
-  in
-  info "driver domain uuid:%s ip:%s" (Db.VM.get_uuid ~__context ~self:driver) ip ;
-  if not (wait_for (pingable ip)) then
-    failwith
-      (Printf.sprintf "driver domain %s is not responding to IP ping"
-         (Ref.string_of driver)
-      ) ;
-  if not (wait_for (queryable ~__context (Xmlrpc_client.TCP (ip, 80)))) then
-    failwith
-      (Printf.sprintf "driver domain %s is not responding to XMLRPC query"
-         (Ref.string_of driver)
-      ) ;
-  ip
-
 type service = {uuid: string; ty: string; instance: string; url: string}
 [@@deriving rpc]
 

ocaml/xapi/system_domains.mli

@@ -51,9 +51,6 @@ val is_in_use : __context:Context.t -> self:API.ref_VM -> bool
 val queryable : __context:Context.t -> Xmlrpc_client.transport -> unit -> bool
 (** [queryable ip port ()] returns true if [ip]:[port] responsds to an XMLRPC query *)
 
-val ip_of : __context:Context.t -> API.ref_VM -> string
-(** [ip_of __context vm] returns the IP of the given VM on the internal management network *)
-
 (** One of many service running in a driver domain *)
 type service = {uuid: string; ty: string; instance: string; url: string}
 

ocaml/xapi/xapi_ha.ml

@@ -1869,10 +1869,7 @@ let enable __context heartbeat_srs configuration =
         with _ -> false
       in
       if not alive then
-        raise
-          (Api_errors.Server_error
-             (Api_errors.host_offline, [Ref.string_of host])
-          )
+        raise Api_errors.(Server_error (host_offline, [Ref.string_of host]))
     )
     (Db.Host.get_all ~__context) ;
   let pool = Helpers.get_pool ~__context in
@@ -1897,20 +1894,23 @@ let enable __context heartbeat_srs configuration =
       else
         heartbeat_srs
     in
-    if possible_srs = [] then
-      raise (Api_errors.Server_error (Api_errors.cannot_create_state_file, [])) ;
-    (* For the moment we'll create a state file in one compatible SR since the xHA component only handles one *)
-    let srs = [List.hd possible_srs] in
+    (* For the moment we'll create a state file in one compatible SR since the
+       xHA component only handles one *)
+    let sr =
+      match possible_srs with
+      | [] ->
+          raise Api_errors.(Server_error (cannot_create_state_file, []))
+      | sr :: _ ->
+          sr
+    in
     List.iter
       (fun sr ->
         let vdi = Xha_statefile.find_or_create ~__context ~sr ~cluster_stack in
         statefile_vdis := vdi :: !statefile_vdis
       )
-      srs ;
+      [sr] ;
     (* For storing the database, assume there is only one SR *)
-    let database_vdi =
-      Xha_metadata_vdi.find_or_create ~__context ~sr:(List.hd srs)
-    in
+    let database_vdi = Xha_metadata_vdi.find_or_create ~__context ~sr in
     database_vdis := database_vdi :: !database_vdis ;
     (* Record the statefile UUIDs in the Pool.ha_statefile set *)
     Db.Pool.set_ha_statefiles ~__context ~self:pool
@@ -1991,14 +1991,16 @@ let enable __context heartbeat_srs configuration =
               (ExnHelper.string_of_exn e)
           )
           errors ;
-        if errors <> [] then (
-          (* Perform a disable since the pool HA state isn't consistent *)
-          error "Attempting to disable HA pool-wide" ;
-          Helpers.log_exn_continue
-            "Disabling HA after a failure joining all hosts to the liveset"
-            disable_internal __context ;
-          raise (snd (List.hd errors))
-        ) ;
+        List.iter
+          (fun (_, exn) ->
+            (* Perform a disable since the pool HA state isn't consistent *)
+            error "Attempting to disable HA pool-wide" ;
+            Helpers.log_exn_continue
+              "Disabling HA after a failure joining all hosts to the liveset"
+              disable_internal __context ;
+            raise exn
+          )
+          errors ;
         (* We have to set the HA enabled flag before forcing a database resynchronisation *)
         Db.Pool.set_ha_enabled ~__context ~self:pool ~value:true ;
         debug "HA enabled" ;
@@ -2036,13 +2038,16 @@ let enable __context heartbeat_srs configuration =
               (ExnHelper.string_of_exn e)
           )
           errors ;
-        if errors <> [] then (
-          (* Perform a disable since the pool HA state isn't consistent *)
-          error "Attempting to disable HA pool-wide" ;
-          Helpers.log_exn_continue "Disabling HA after a failure during enable"
-            disable_internal __context ;
-          raise (snd (List.hd errors))
-        ) ;
+        List.iter
+          (fun (_, exn) ->
+            (* Perform a disable since the pool HA state isn't consistent *)
+            error "Attempting to disable HA pool-wide" ;
+            Helpers.log_exn_continue
+              "Disabling HA after a failure during enable" disable_internal
+              __context ;
+            raise exn
+          )
+          errors ;
         (* Update the allowed_operations on the HA volumes to prevent people thinking they can mess with them *)
         List.iter
           (fun vdi -> Xapi_vdi.update_allowed_operations ~__context ~self:vdi)

ocaml/xapi/xha_interface.ml

@@ -32,8 +32,7 @@ let xml_element_has_name name element =
 (** Returns the first element with the specified name from
     the given element list. *)
 let first_xml_element_with_name elements name =
-  try Some (List.find (xml_element_has_name name) elements)
-  with Not_found -> None
+  List.find_opt (xml_element_has_name name) elements
 
 (** Parses an XML element of the form "<name>value</value>".
     Returns a (name, value) string pair, where the arguments

quality-gate.sh

@@ -3,7 +3,7 @@
 set -e
 
 list-hd () {
-  N=274
+  N=269
   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"