xapi_ha: avoid raising Not_found when joining a liveset (#6734)

An xcp-ng user reported a failure when enabling HA, with the only error
being a Not_found, with this change we now know that it's because the IP
of the coordinator is not present in the local database's `ha_peers`
value.

While doing this:
- I also removed several finds and hd to reduce these kind of exceptions
and make the problematic uses easier to find in the future
- The localdb interface was rebustified by using options
- the cluster_stack values were reified and consolidated into constants,
they are problematic because they are strings instead of an enum, but we
can tame them a bit

Author: psafont

ocaml/sdk-gen/c/gen_c_binding.ml

@@ -346,7 +346,7 @@ and gen_impl cls =
       ; ("async_params", `A (List.map paramJson (asyncParams msg)))
       ; ("msg_params", `A (List.map paramJson msg.msg_params))
       ; ("abstract_result_type", `String (result_type msg))
-      ; ("has_params", `Bool (List.length msg.msg_params <> 0))
+      ; ("has_params", `Bool (msg.msg_params <> []))
       ; ("param_count", `String (string_of_int (List.length msg.msg_params)))
       ; ("has_result", `Bool (String.compare (result_type msg) "" <> 0))
       ; ("init_result", `Bool (init_result msg))

ocaml/xapi-consts/constants.ml

@@ -212,12 +212,29 @@ let ballooning_enabled = "ballooning.enabled"
 let redo_log_enabled = "redo_log.enabled"
 
 (* Valid cluster stack values *)
-let ha_cluster_stack = "ha_cluster_stack"
+module Ha_cluster_stack = struct
+  type t = Xhad | Corosync
 
-let default_smapiv3_cluster_stack = "corosync"
+  let key = "ha_cluster_stack"
 
-(* Note: default without clustering is in !Xapi_globs.default_cluster_stack *)
-let supported_smapiv3_cluster_stacks = ["corosync"]
+  let to_string = function Xhad -> "xhad" | Corosync -> "corosync"
+
+  let of_string = function
+    | "xhad" ->
+        Some Xhad
+    | "corosync" ->
+        Some Corosync
+    | _ ->
+        None
+end
+
+let ha_cluster_stack = Ha_cluster_stack.key
+
+let default_cluster_stack = Ha_cluster_stack.(to_string Xhad)
+
+let default_smapiv3_cluster_stack = Ha_cluster_stack.(to_string Corosync)
+
+let supported_smapiv3_cluster_stacks = [default_smapiv3_cluster_stack]
 
 (* Set in the local db to cause us to emit an alert when we come up as a master after
    a transition or HA failover *)

ocaml/xapi/create_storage.ml

@@ -79,24 +79,20 @@ let maybe_create_pbd rpc session_id sr device_config me =
       (fun self -> Client.PBD.get_host ~rpc ~session_id ~self = me)
       pbds
   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
-  in
-  if pbds = [] (* If there's no PBD, create it *) then
+  let create () : [`PBD] Ref.t =
     Client.PBD.create ~rpc ~session_id ~host:me ~sR:sr ~device_config
       ~other_config:[]
-  else
-    List.hd pbds
-
-(* Otherwise, return the current one *)
+  in
+  (* Ensure there's a single PBD *)
+  match pbds with
+  | [] ->
+      ignore (create ())
+  | [_] ->
+      ()
+  | _ :: 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
 
 let maybe_remove_tools_sr rpc session_id __context =
   let srs = Db.SR.get_all ~__context in
@@ -153,17 +149,13 @@ 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 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 +165,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/localdb.ml

@@ -64,17 +64,27 @@ exception Missing_key of string
 let m = Mutex.create ()
 
 let get (key : string) =
+  let __FUN = __FUNCTION__ in
+  let ( let* ) = Option.bind in
   with_lock m (fun () ->
-      assert_loaded () ;
-      match Hashtbl.find_opt db key with
-      | Some x ->
-          x
-      | None ->
-          raise (Missing_key key)
+      let* () =
+        try assert_loaded () ; Some ()
+        with e ->
+          warn "%s: unexpected error, ignoring it: %s" __FUN
+            (Printexc.to_string e) ;
+          None
+      in
+      Hashtbl.find_opt db key
   )
 
-let get_with_default (key : string) (default : string) =
-  try get key with Missing_key _ -> default
+let get_exn key =
+  match get key with Some x -> x | None -> raise (Missing_key key)
+
+let get_of_string of_string key = Option.bind (get key) of_string
+
+let get_bool key = get_of_string bool_of_string_opt key
+
+let get_int key = get_of_string int_of_string_opt key
 
 (* Returns true if a change was made and should be flushed *)
 let put_one (key : string) (v : string) =

ocaml/xapi/localdb.mli

@@ -18,12 +18,24 @@
 (** Thrown when a particular named key could not be found. *)
 exception Missing_key of string
 
-val get : string -> string
+val get : string -> string option
 (** Retrieves a value *)
 
-val get_with_default : string -> string -> string
-(** [get_with_default key default] returns the value associated with [key],
-    	or [default] if the key is missing. *)
+val get_exn : string -> string
+(** Retrieves the value for the key, raises Missing_key when the key is not
+    present *)
+
+val get_bool : string -> bool option
+(** Retrieves the value for the key, returns a value when it's found and is a
+    valid boolean, otherwise is [None] *)
+
+val get_int : string -> int option
+(** Retrieves the value for the key, returns a value when it's found and is a
+    valid int, otherwise is [None] *)
+
+val get_of_string : (string -> 'a option) -> string -> 'a option
+(** [get_of_string of_string key] retrieves the value for [key], and if it
+    exists, processes it with [of_string], otherwise it's [None] *)
 
 val put : string -> string -> unit
 (** Inserts a value into the database, only returns when the insertion has

ocaml/xapi/repository.ml

@@ -232,7 +232,7 @@ let sync ~__context ~self ~token ~token_id ~username ~password =
     Xapi_stdext_pervasives.Pervasiveext.finally
       (fun () ->
         let config_repo config =
-          if List.length config <> 0 then (* Set params to yum/dnf *)
+          if config <> [] then (* Set params to yum/dnf *)
             let Pkg_mgr.{cmd; params} = Pkgs.config_repo ~repo_name ~config in
             ignore
               (Helpers.call_script ~log_output:Helpers.On_failure cmd params)

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

@@ -288,12 +288,9 @@ let synchronize_certificates_with_coordinator ~__context =
 
 (* Make sure the local database can be read *)
 let init_local_database () =
-  ( try
-      let (_ : string) = Localdb.get Constants.ha_armed in
-      ()
-    with Localdb.Missing_key _ ->
-      Localdb.put Constants.ha_armed "false" ;
-      debug "%s = 'false' (by default)" Constants.ha_armed
+  if Option.is_none (Localdb.get_bool Constants.ha_armed) then (
+    Localdb.put Constants.ha_armed "false" ;
+    debug "%s = 'false' (by default)" Constants.ha_armed
   ) ;
   (* Add the local session check hook *)
   Session_check.check_local_session_hook :=
@@ -519,13 +516,14 @@ let start_ha () =
 (** Enable and load the redo log if we are the master, the local-DB flag is set
  * and HA is disabled *)
 let start_redo_log () =
+  let redo_log_enabled () =
+    Localdb.get_bool Constants.redo_log_enabled |> Option.value ~default:false
+  in
+  let ha_armed () =
+    Localdb.get_bool Constants.ha_armed |> Option.value ~default:false
+  in
   try
-    if
-      Pool_role.is_master ()
-      && bool_of_string
-           (Localdb.get_with_default Constants.redo_log_enabled "false")
-      && not (bool_of_string (Localdb.get Constants.ha_armed))
-    then (
+    if Pool_role.is_master () && redo_log_enabled () && not (ha_armed ()) then (
       debug "Redo log was enabled when shutting down, so restarting it" ;
       Static_vdis.reattempt_on_boot_attach () ;
       (* enable the use of the redo log *)
@@ -610,7 +608,7 @@ let resynchronise_ha_state () =
         let pool = Helpers.get_pool ~__context in
         let pool_ha_enabled = Db.Pool.get_ha_enabled ~__context ~self:pool in
         let local_ha_enabled =
-          bool_of_string (Localdb.get Constants.ha_armed)
+          Localdb.get_bool Constants.ha_armed |> Option.value ~default:false
         in
         match (local_ha_enabled, pool_ha_enabled) with
         | true, true ->

ocaml/xapi/xapi_globs.ml

@@ -858,7 +858,7 @@ let migration_https_only = ref true
 
 let cluster_stack_root = ref "/usr/libexec/xapi/cluster-stack"
 
-let cluster_stack_default = ref "xhad"
+let cluster_stack_default = ref Constants.default_cluster_stack
 
 let xen_cmdline_path = ref "/opt/xensource/libexec/xen-cmdline"