CA-282006: Prevent IP reconfiguration on a live cluster network

ocaml/idl/datamodel.ml

@@ -963,6 +963,7 @@ module PIF = struct
     ~params: [ Ref _pif, "self", "Reference to the object"
              ; Bool, "value", "New value to set" ]
     ~allowed_roles:_R_POOL_OP
+    ~errs:[Api_errors.clustering_enabled_on_network]
     ()
 
   let ip_configuration_mode = Enum ("ip_configuration_mode",
@@ -982,6 +983,7 @@ module PIF = struct
               ]
       ~in_product_since:rel_miami
       ~allowed_roles:_R_POOL_OP
+      ~errs:[Api_errors.clustering_enabled_on_network]
       ()
 
   let ipv6_configuration_mode = Enum ("ipv6_configuration_mode",
@@ -1001,6 +1003,7 @@ module PIF = struct
               ]
       ~lifecycle:[Prototyped, rel_tampa, ""]
       ~allowed_roles:_R_POOL_OP
+      ~errs:[Api_errors.clustering_enabled_on_network]
       ()
 
   let primary_address_type = Enum ("primary_address_type",
@@ -1048,7 +1051,8 @@ module PIF = struct
       ~params:[Ref _pif, "self", "The PIF object to destroy"]
       ~in_product_since:rel_miami
       ~allowed_roles:_R_POOL_OP
-      ~errs:[Api_errors.pif_tunnel_still_exists]
+      ~errs:[ Api_errors.pif_tunnel_still_exists
+            ; Api_errors.clustering_enabled_on_network]
       ()
 
   let pool_introduce_params first_rel =

ocaml/quicktest/quicktest.ml

@@ -847,6 +847,7 @@ let _ =
     "cbt";
     "import_raw_vdi";
     "pbd-bvt";
+    "reconfigure-ip-cluster";
   ] in
   let default_tests = List.filter (fun x -> not(List.mem x [ "lifecycle"; "vhd" ])) all_tests in
 
@@ -883,6 +884,7 @@ let _ =
           maybe_run_test "pbd-bvt" (fun () -> Quicktest_bvt.start s !rpc);
           maybe_run_test "cbt" (fun () -> Quicktest_cbt.test s);
           maybe_run_test "vm-placement" Quicktest_vm_placement.run_from_within_quicktest;
+          maybe_run_test "reconfigure-ip-cluster" (fun () -> Quicktest_cluster.test s);
           maybe_run_test "storage" (fun () -> Quicktest_storage.go s);
           if not !using_unix_domain_socket then maybe_run_test "http" Quicktest_http.run_from_within_quicktest;
           maybe_run_test "event" event_next_unblocking_test;

ocaml/quicktest/quicktest_cluster.ml

@@ -0,0 +1,92 @@
+
+open Quicktest_common
+(* provide test record type and make_test, start,
+ * debug, success, and failed test functions *)
+
+open Client
+(* provide rpc ref *)
+
+module C = Client
+
+let is_empty = function | [] -> true | _ -> false
+
+(* [failed test.name string_of_failure] removes [test] from a test Hashtbl
+ * and is therefore only called once, in the try-with statement.
+ * This exception is raised within the try-with body to trigger
+ * [failed test string_of_failure] *)
+exception Abort_test of string
+
+(** --- Helpers for reconfiguration --- *)
+
+let reconfigure_ipv4 ~session_id ~self ~dNS =
+  let netmask = C.PIF.get_netmask ~session_id ~rpc:!rpc ~self in
+  let iP = C.PIF.get_IP ~session_id ~rpc:!rpc ~self in
+  let gateway = C.PIF.get_gateway ~session_id ~rpc:!rpc ~self in
+  let mode = C.PIF.get_ip_configuration_mode ~session_id ~rpc:!rpc ~self in
+  C.PIF.reconfigure_ip ~session_id ~rpc:!rpc ~self ~iP ~dNS ~gateway ~netmask ~mode
+
+let reconfigure_ipv6 ~session_id ~self ~dNS =
+
+  (* confirm valid IPv6 strings exist *)
+  let iPv6_lst = (C.PIF.get_IPv6 ~session_id ~rpc:!rpc ~self) |> List.filter ((<>) "") in
+  if is_empty iPv6_lst
+  then raise (Abort_test "No valid IPv6 strings exist.");
+
+  let gateway = C.PIF.get_ipv6_gateway ~session_id ~rpc:!rpc ~self in
+  let mode = C.PIF.get_ipv6_configuration_mode ~session_id ~rpc:!rpc ~self in
+  let iPv6 = List.hd iPv6_lst in
+  C.PIF.reconfigure_ipv6 ~session_id ~rpc:!rpc ~self ~iPv6 ~dNS ~gateway ~mode
+
+(** --- Test skeleton, receives environment params before running  --- *)
+let test_reconfigure_ip ~ipv6 ~session_id ~(self : API.ref_PIF) =
+  let ip_string = if ipv6 then "IPv6" else "IPv4" in
+  let test =
+    make_test (Printf.sprintf "Testing reconfiguring %s with clustering." ip_string) 4
+  in
+  try
+    start test;
+
+    let dNS = C.PIF.get_DNS ~session_id ~rpc:!rpc ~self in
+    if ipv6
+    then reconfigure_ipv6 ~session_id ~self ~dNS
+    else reconfigure_ipv4 ~session_id ~self ~dNS;
+
+    failed test "PIF.reconfigure_ip should raise clustering_enabled_on_network."
+  with
+  | Api_errors.(Server_error(code,_)) when code=Api_errors.clustering_enabled_on_network
+      -> debug test (Printf.sprintf "%s raised as expected." Api_errors.clustering_enabled_on_network);
+         success test
+  | Api_errors.(Server_error(_,_)) -> () (* Don't fail on other API errors, only test clustering *)
+  | Abort_test s -> failed test s
+  | e -> failed test (ExnHelper.string_of_exn e)
+
+(** --- Check environment before calling test --- *)
+let test session_id =
+  let test_all_pifs = make_test "Testing IP reconfiguration with and without clustering." 2 in
+  try
+    print_newline ();
+    start test_all_pifs;
+    print_newline ();
+    let pifs = Client.PIF.get_all ~session_id ~rpc:!rpc in
+
+    List.iter
+      (fun self ->
+        let clustering =
+          let network = C.PIF.get_network ~session_id ~rpc:!rpc ~self in
+          C.Cluster.get_all ~session_id ~rpc:!rpc
+          |> List.filter
+            (fun cluster -> (C.Cluster.get_network ~session_id ~rpc:!rpc ~self:cluster) = network)
+          |> (fun lst -> not (is_empty lst))
+        in
+        if clustering
+        then begin
+          test_reconfigure_ip ~ipv6:false ~session_id ~self
+          (* IPv6 clusters not yet supported, can run this test once that changes *)
+          (* test_reconfigure_ip ~ipv6:true ~session_id ~self *)
+        end
+        else
+          debug test_all_pifs "No cluster objects on this PIF, skipping tests."
+      ) pifs;
+
+      success test_all_pifs
+  with e -> failed test_all_pifs (ExnHelper.string_of_exn e)

ocaml/xapi/xapi_pif.ml

@@ -443,8 +443,21 @@ let introduce_internal
   (* return ref of newly created pif record *)
   pif
 
+(* Assertion passes if network has clusters attached but host has disabled clustering *)
+let assert_no_clustering_enabled ~__context ~network ~host =
+  if not (Xapi_clustering.is_clustering_disabled_on_host ~__context host)
+  then
+    (Db.Cluster.get_refs_where ~__context
+      ~expr:Db_filter_types.(Eq(Field "network", Literal (Ref.string_of network))))
+    |> function
+    | []   -> ()
+    | _::_ -> raise Api_errors.(Server_error (clustering_enabled_on_network, [Ref.string_of network]))
+
 (* Internal [forget] is passed a pre-built table [t] *)
 let forget_internal ~t ~__context ~self =
+  let network = Db.PIF.get_network ~__context ~self in
+  let host = Db.PIF.get_host ~__context ~self in
+  assert_no_clustering_enabled ~__context ~network ~host;
   if Db.PIF.get_managed ~__context ~self = true then
     Nm.bring_pif_down ~__context self;
   (* NB we are allowed to forget an interface which still exists *)
@@ -623,6 +636,9 @@ let destroy ~__context ~self =
 let reconfigure_ipv6 ~__context ~self ~mode ~iPv6 ~gateway ~dNS =
   assert_pif_is_managed ~__context ~self;
   assert_no_protection_enabled ~__context ~self;
+  let network = Db.PIF.get_network ~__context ~self in
+  let host = Db.PIF.get_host ~__context ~self in
+  assert_no_clustering_enabled ~__context ~network ~host;
 
   if gateway <> "" then
     Helpers.assert_is_valid_ip `ipv6 "gateway" gateway;
@@ -672,6 +688,9 @@ let reconfigure_ipv6 ~__context ~self ~mode ~iPv6 ~gateway ~dNS =
 let reconfigure_ip ~__context ~self ~mode ~iP ~netmask ~gateway ~dNS =
   assert_pif_is_managed ~__context ~self;
   assert_no_protection_enabled ~__context ~self;
+  let network = Db.PIF.get_network ~__context ~self in
+  let host = Db.PIF.get_host ~__context ~self in
+  assert_no_clustering_enabled ~__context ~network ~host;
 
   if mode = `Static then begin
     (* require these parameters if mode is static *)
@@ -680,7 +699,7 @@ let reconfigure_ip ~__context ~self ~mode ~iP ~netmask ~gateway ~dNS =
   end;
 
   (* for all IP parameters, if they're not empty
-     	 * then check they contain valid IP address *)
+        * then check they contain valid IP address *)
   List.iter
     (fun (param, value) -> if value <> "" then Helpers.assert_is_valid_ip `ipv4 param value)
     ["IP",iP; "netmask",netmask; "gateway",gateway];
@@ -767,20 +786,13 @@ let set_property ~__context ~self ~name ~value =
         Nm.bring_pif_up ~__context pif
     ) (self :: vlan_pifs)
 
-let pif_has_clustering_enabled ~__context (self : API.ref_PIF) network =
-  (Db.Cluster.get_refs_where ~__context
-    ~expr:Db_filter_types.(Eq(Field "network", Literal (Ref.string_of network))))
-    |> function
-    | []   -> false
-    | a::_ -> true
-
 let set_disallow_unplug ~__context ~self ~value =
   if (Db.PIF.get_disallow_unplug ~__context ~self) <> value
   then begin
     let network = Db.PIF.get_network ~__context ~self in
-    if pif_has_clustering_enabled ~__context self network
-    then raise Api_errors.(Server_error(clustering_enabled_on_network, [Ref.string_of network]))
-    else Db.PIF.set_disallow_unplug ~__context ~self ~value
+    let host = Db.PIF.get_host ~__context ~self in
+    assert_no_clustering_enabled ~__context ~network ~host;
+    Db.PIF.set_disallow_unplug ~__context ~self ~value
   end
 
 let rec unplug ~__context ~self =