CA-403867: Block pool join if IP not configured on joining cluster network (#6290)

Author: gangj

ocaml/idl/datamodel_errors.ml

@@ -897,6 +897,14 @@ let _ =
        the pool coordinator. Make sure the sm are of the same versions and try \
        again."
     () ;
+  error Api_errors.pool_joining_pool_cannot_enable_clustering_on_vlan_network
+    ["vlan"] ~doc:"The remote pool cannot enable clustering on vlan network" () ;
+  error Api_errors.pool_joining_host_must_have_only_one_IP_on_clustering_network
+    []
+    ~doc:
+      "The host joining the pool must have one and only one IP on the \
+       clustering network"
+    () ;
 
   (* External directory service *)
   error Api_errors.subject_cannot_be_resolved []

ocaml/tests/test_clustering.ml

@@ -165,15 +165,15 @@ let test_find_cluster_host_finds_multiple_cluster_hosts () =
   let host = Db.Host.get_all ~__context |> List.hd in
   let _ = T.make_cluster_host ~__context ~host () in
   let _ = T.make_cluster_host ~__context ~host () in
+  let err =
+    Printf.sprintf "Multiple cluster_hosts found for host %s %s"
+      (Db.Host.get_uuid ~__context ~self:host)
+      (Ref.string_of host)
+  in
   Alcotest.check_raises
     "test_find_cluster_host_finds_multiple_cluster_hosts should throw an \
      internal error"
-    Api_errors.(
-      Server_error
-        ( internal_error
-        , ["Multiple cluster_hosts found for host"; Ref.string_of host]
-        )
-    )
+    Api_errors.(Server_error (internal_error, [err]))
     (fun () -> ignore (Xapi_clustering.find_cluster_host ~__context ~host))
 
 let test_find_cluster_host =

ocaml/xapi-consts/api_errors.ml

@@ -757,6 +757,12 @@ let pool_joining_host_ca_certificates_conflict =
 let pool_joining_sm_features_incompatible =
   add_error "POOL_JOINING_SM_FEATURES_INCOMPATIBLE"
 
+let pool_joining_pool_cannot_enable_clustering_on_vlan_network =
+  add_error "POOL_JOINING_POOL_CANNOT_ENABLE_CLUSTERING_ON_VLAN_NETWORK"
+
+let pool_joining_host_must_have_only_one_IP_on_clustering_network =
+  add_error "POOL_JOINING_HOST_MUST_HAVE_ONLY_ONE_IP_ON_CLUSTERING_NETWORK"
+
 (*workload balancing*)
 let wlb_not_initialized = add_error "WLB_NOT_INITIALIZED"
 

ocaml/xapi/cert_distrib.ml

@@ -101,7 +101,7 @@ let raise_internal ?e ?(details = "") msg : 'a =
       e
   in
   [msg; details; e] |> String.concat ". " |> D.error "%s" ;
-  raise Api_errors.(Server_error (internal_error, [msg]))
+  Helpers.internal_error "%s" msg
 
 module type CertificateProvider = sig
   val store_path : string
@@ -404,13 +404,8 @@ let exchange_certificates_in_pool ~__context =
           let throw_op =
             ( "FIST"
             , fun () ->
-                raise
-                  Api_errors.(
-                    Server_error
-                      ( internal_error
-                      , ["/tmp/fist_exchange_certificates_in_pool FIST!"]
-                      )
-                  )
+                Helpers.internal_error
+                  "/tmp/fist_exchange_certificates_in_pool FIST!"
             )
           in
           let ops' = insert_at rand_i throw_op ops in

ocaml/xapi/certificates_sync.ml

@@ -119,19 +119,13 @@ let update ~__context =
   let* () = sync ~__context ~type':`host_internal in
   Ok ()
 
-let internal_error fmt =
-  fmt
-  |> Printf.ksprintf @@ fun msg ->
-     error "%s" msg ;
-     raise Api_errors.(Server_error (internal_error, [msg]))
-
 let remove_from_db ~__context cert =
   try
     Db.Certificate.destroy ~__context ~self:cert ;
     info "removed host certificate %s from db" (Ref.string_of cert)
   with e ->
-    internal_error "failed to remove cert %s: %s" (Ref.string_of cert)
-      (Printexc.to_string e)
+    Helpers.internal_error ~log_err:true "failed to remove cert %s: %s"
+      (Ref.string_of cert) (Printexc.to_string e)
 
 let path host_uuid =
   let prefix = !Xapi_globs.trusted_pool_certs_dir in
@@ -161,5 +155,5 @@ let eject_certs_from_fs_for ~__context host =
     | false ->
         info "host %s has no certificate %s to remove" host_uuid file
   with e ->
-    internal_error "failed to remove cert %s on pool eject: %s" file
-      (Printexc.to_string e)
+    Helpers.internal_error ~log_err:true
+      "failed to remove cert %s on pool eject: %s" file (Printexc.to_string e)

ocaml/xapi/dbsync_slave.ml

@@ -136,12 +136,9 @@ let refresh_localhost_info ~__context info =
     let network_state = Scanf.sscanf script_output "Port 80 open: %B" Fun.id in
     Db.Host.set_https_only ~__context ~self:host ~value:network_state
   with _ ->
-    let message =
-      Printf.sprintf
-        "unexpected output from /etc/xapi.d/plugins/firewall-port: %s"
-        script_output
-    in
-    raise Api_errors.(Server_error (internal_error, [message]))
+    Helpers.internal_error
+      "unexpected output from /etc/xapi.d/plugins/firewall-port: %s"
+      script_output
 (*************** update database tools ******************)
 
 (** Record host memory properties in database *)

ocaml/xapi/helpers.ml

@@ -34,6 +34,15 @@ module StringSet = Set.Make (String)
 
 let ( let* ) = Result.bind
 
+let internal_error ?(log_err = false) ?(err_fun = error) fmt =
+  Printf.ksprintf
+    (fun str ->
+      if log_err then
+        err_fun "%s" str ;
+      raise Api_errors.(Server_error (internal_error, [str]))
+    )
+    fmt
+
 let log_exn_continue msg f x =
   try f x
   with e ->
@@ -719,8 +728,7 @@ let check_domain_type : API.domain_type -> [`hvm | `pv_in_pvh | `pv | `pvh] =
   | `pvh ->
       `pvh
   | `unspecified ->
-      raise
-        Api_errors.(Server_error (internal_error, ["unspecified domain type"]))
+      internal_error "unspecified domain type"
 
 let domain_type ~__context ~self : [`hvm | `pv_in_pvh | `pv | `pvh] =
   let vm = Db.VM.get_record ~__context ~self in
@@ -1498,11 +1506,8 @@ let resolve_uri_path ~root ~uri_path =
   | true, true ->
       x
   | _ ->
-      let msg =
-        Printf.sprintf "Failed to resolve uri path '%s' under '%s': %s" uri_path
-          root x
-      in
-      raise Api_errors.(Server_error (internal_error, [msg]))
+      internal_error "Failed to resolve uri path '%s' under '%s': %s" uri_path
+        root x
 
 let run_in_parallel ~funs ~capacity =
   let rec run_in_parallel' acc funs capacity =
@@ -1727,42 +1732,21 @@ let rec retry_until_timeout ?(interval = 0.1) ?(timeout = 5.) doc f =
       let next_interval = interval *. 1.5 in
       let next_timeout = timeout -. interval in
       if next_timeout < 0. then
-        raise
-          Api_errors.(
-            Server_error (internal_error, [Printf.sprintf "retry %s failed" doc])
-          ) ;
+        internal_error "retry %s failed" doc ;
       Thread.delay interval ;
       retry_until_timeout ~interval:next_interval ~timeout:next_timeout doc f
 
 let get_first_pusb ~__context usb_group =
   try List.hd (Db.USB_group.get_PUSBs ~__context ~self:usb_group)
   with _ ->
-    raise
-      Api_errors.(
-        Server_error
-          ( internal_error
-          , [
-              Printf.sprintf
-                "there is no PUSB associated with the USB_group: %s"
-                (Ref.string_of usb_group)
-            ]
-          )
-      )
+    internal_error "there is no PUSB associated with the USB_group: %s"
+      (Ref.string_of usb_group)
 
 let get_first_vusb ~__context usb_group =
   try List.hd (Db.USB_group.get_VUSBs ~__context ~self:usb_group)
   with _ ->
-    raise
-      Api_errors.(
-        Server_error
-          ( internal_error
-          , [
-              Printf.sprintf
-                "there is no VUSB associated with the USB_group: %s"
-                (Ref.string_of usb_group)
-            ]
-          )
-      )
+    internal_error "there is no VUSB associated with the USB_group: %s"
+      (Ref.string_of usb_group)
 
 let host_supports_hvm ~__context host =
   (* We say that a host supports HVM if any of
@@ -1873,13 +1857,7 @@ end = struct
   let to_result ~__context ~of_rpc ~t =
     Context.with_tracing ~__context __FUNCTION__ @@ fun __context ->
     wait_for_mirror ~__context ~propagate_cancel:true ~t ;
-    let fail msg =
-      raise
-        Api_errors.(
-          Server_error
-            (internal_error, [Printf.sprintf "%s, %s" (Ref.string_of t) msg])
-        )
-    in
+    let fail msg = internal_error "%s, %s" (Ref.string_of t) msg in
     let res =
       match Db.Task.get_status ~__context ~self:t with
       | `pending ->
@@ -1965,15 +1943,8 @@ end = struct
     in
     let sufficiently_secret = String.length x > 36 in
     if has_valid_chars && sufficiently_secret |> not then
-      raise
-        Api_errors.(
-          Server_error
-            ( internal_error
-            , [
-                {|expected pool secret to match the following regex '^[0-9a-f\/\-]{37,}$'|}
-              ]
-            )
-        ) ;
+      internal_error
+        {|expected pool secret to match the following regex '^[0-9a-f\/\-]{37,}$'|} ;
     SecretString.of_string x
 
   let _make () =

ocaml/xapi/livepatch.ml

@@ -68,7 +68,7 @@ let of_json js =
       (ExnHelper.string_of_exn e)
       msg
       (Yojson.Basic.pretty_to_string js) ;
-    raise Api_errors.(Server_error (internal_error, [msg]))
+    Helpers.internal_error "%s" msg
 
 let get_latest_livepatch lps =
   List.map (fun (_, _, t_v, t_r) -> (t_v, t_r)) lps
@@ -344,14 +344,11 @@ let apply ~component ~livepatch_file ~base_build_id ~base_version ~base_release
     | expected_id, Some real_id when expected_id = real_id ->
         ()
     | _ ->
-        let msg =
-          Printf.sprintf
-            "The livepatch is against build ID %s, but the build ID of the \
-             running %s is %s"
-            expected component_str
-            (Option.value real ~default:"None")
-        in
-        raise Api_errors.(Server_error (internal_error, [msg]))
+        Helpers.internal_error
+          "The livepatch is against build ID %s, but the build ID of the \
+           running %s is %s"
+          expected component_str
+          (Option.value real ~default:"None")
   in
   match component with
   | Xen ->

ocaml/xapi/message_forwarding.ml

@@ -3858,15 +3858,8 @@ functor
           in
           ()
         with Forkhelpers.Spawn_internal_error (_, _, _) ->
-          raise
-            (Api_errors.Server_error
-               ( Api_errors.internal_error
-               , [
-                   "Generation of alerts for server certificate expiration \
-                    failed."
-                 ]
-               )
-            )
+          Helpers.internal_error
+            "Generation of alerts for server certificate expiration failed."
 
       let reset_server_certificate ~__context ~host =
         info "Host.reset_server_certificate: host = '%s'"

ocaml/xapi/nm.ml

@@ -441,11 +441,7 @@ let rec create_bridges ~__context pif_rc net_rc =
         ]
       )
   | Network_sriov_logical _ ->
-      raise
-        Api_errors.(
-          Server_error
-            (internal_error, ["Should not create bridge for SRIOV logical PIF"])
-        )
+      Helpers.internal_error "Should not create bridge for SRIOV logical PIF"
 
 let rec destroy_bridges ~__context ~force pif_rc bridge =
   let open Xapi_pif_helpers in
@@ -468,11 +464,7 @@ let rec destroy_bridges ~__context ~force pif_rc bridge =
   | Physical _ ->
       [(bridge, false)]
   | Network_sriov_logical _ ->
-      raise
-        Api_errors.(
-          Server_error
-            (internal_error, ["Should not destroy bridge for SRIOV logical PIF"])
-        )
+      Helpers.internal_error "Should not destroy bridge for SRIOV logical PIF"
 
 let determine_static_routes net_rc =
   if List.mem_assoc "static-routes" net_rc.API.network_other_config then

ocaml/xapi/repository.ml

@@ -372,7 +372,7 @@ let parse_updateinfo ~__context ~self ~check =
             hash md.RepoMetaData.checksum
         in
         error "%s: %s" repo_name msg ;
-        raise Api_errors.(Server_error (internal_error, [msg]))
+        Helpers.internal_error "%s" msg
       )
   ) ;
   let updateinfo_xml_gz_path =
@@ -691,9 +691,8 @@ let apply_livepatch ~__context ~host:_ ~component ~base_build_id ~base_version
   let component' =
     try component_of_string component
     with _ ->
-      let msg = Printf.sprintf "Invalid component name '%s'" component in
-      error "%s" msg ;
-      raise Api_errors.(Server_error (internal_error, [msg]))
+      Helpers.internal_error ~log_err:true "Invalid component name '%s'"
+        component
   in
   match
     Livepatch.get_livepatch_file_path ~component:component' ~base_build_id
@@ -703,9 +702,8 @@ let apply_livepatch ~__context ~host:_ ~component ~base_build_id ~base_version
       Livepatch.apply ~component:component' ~livepatch_file ~base_build_id
         ~base_version ~base_release ~to_version ~to_release
   | None ->
-      let msg = Printf.sprintf "No expected livepatch file for %s" component in
-      error "%s" msg ;
-      raise Api_errors.(Server_error (internal_error, [msg]))
+      Helpers.internal_error ~log_err:true "No expected livepatch file for %s"
+        component
 
 let apply_livepatches' ~__context ~host ~livepatches =
   List.partition_map