CP-24903: Network.pool_introduce: purposes param

Give the Network.pool_introduce function a purposes parameter to enable
network purpose preservation on pool-join.

Add logic on pool-join to check whether the network purposes are
compatible.

Signed-off-by: Thomas Sanders <[email protected]>

Author: thomassa

ocaml/idl/datamodel.ml

@@ -5192,6 +5192,13 @@ let network_attach = call
     ~allowed_roles:_R_POOL_OP
     ()
 
+let network_purpose = Enum ("network_purpose", [
+  "nbd", "Network Block Device service using TLS";
+  "insecure_nbd", "Network Block Device service without integrity or confidentiality: NOT RECOMMENDED";
+  (* We should (re-)add other purposes as and when we write code with behaviour that depends on them,
+   * e.g. management, storage, guest, himn... unmanaged? *)
+])
+
 let network_introduce_params first_rel =
   [
     {param_type=String; param_name="name_label"; param_doc=""; param_release=first_rel; param_default=None};
@@ -5200,6 +5207,7 @@ let network_introduce_params first_rel =
     {param_type=Map(String,String); param_name="other_config"; param_doc=""; param_release=first_rel; param_default=None};
     {param_type=String; param_name="bridge"; param_doc=""; param_release=first_rel; param_default=None};
     {param_type=Bool; param_name="managed"; param_doc=""; param_release=falcon_release; param_default=None};
+    {param_type=Set(network_purpose); param_name="purposes"; param_doc=""; param_release=inverness_release; param_default=None};
   ]
 
 (* network pool introduce is used to copy network records on pool join -- it's the network analogue of VDI/PIF.pool_introduce *)
@@ -5263,13 +5271,6 @@ let network_detach_for_vm = call
     ~allowed_roles:_R_VM_POWER_ADMIN
     ()
 
-let network_purpose = Enum ("network_purpose", [
-  "nbd", "Network Block Device service using TLS";
-  "insecure_nbd", "Network Block Device service without integrity or confidentiality: NOT RECOMMENDED";
-  (* We should (re-)add other purposes as and when we write code with behaviour that depends on them,
-   * e.g. management, storage, guest, himn... unmanaged? *)
-])
-
 let network_add_purpose = call
   ~name:"add_purpose"
   ~doc:"Give a network a new purpose (if not present already)"

ocaml/xapi/test_common.ml

@@ -162,8 +162,8 @@ let make_pif ~__context ~network ~host ?(device="eth0") ?(mAC="C0:FF:EE:C0:FF:EE
     ~ipv6_configuration_mode ~iPv6 ~ipv6_gateway ~primary_address_type ~managed ~properties
 
 let make_network ~__context ?(name_label="net") ?(name_description="description") ?(mTU=1500L)
-    ?(other_config=[]) ?(bridge="xenbr0") ?(managed=true) () =
-  Xapi_network.pool_introduce ~__context ~name_label ~name_description ~mTU ~other_config ~bridge ~managed
+    ?(other_config=[]) ?(bridge="xenbr0") ?(managed=true) ?(purposes=[]) () =
+  Xapi_network.pool_introduce ~__context ~name_label ~name_description ~mTU ~other_config ~bridge ~managed ~purposes
 
 let make_vif ~__context ?(ref=Ref.make ()) ?(uuid=make_uuid ())
     ?(current_operations=[]) ?(allowed_operations=[]) ?(reserved=false)

ocaml/xapi/xapi_network.ml

@@ -185,10 +185,10 @@ let counter = ref 0
 let mutex = Mutex.create ()
 let stem = "xapi"
 
-let pool_introduce ~__context ~name_label ~name_description ~mTU ~other_config ~bridge ~managed =
+let pool_introduce ~__context ~name_label ~name_description ~mTU ~other_config ~bridge ~managed ~purposes =
   let r = Ref.make() and uuid = Uuid.make_uuid() in
   Db.Network.create ~__context ~ref:r ~uuid:(Uuid.to_string uuid)
-    ~current_operations:[] ~allowed_operations:[] ~purposes:[]
+    ~current_operations:[] ~allowed_operations:[] ~purposes
     ~name_label ~name_description ~mTU ~bridge ~managed
     ~other_config ~blobs:[] ~tags:[] ~default_locking_mode:`unlocked ~assigned_ips:[];
   r

ocaml/xapi/xapi_network.mli

@@ -72,7 +72,9 @@ val pool_introduce :
   mTU:int64 ->
   other_config:(string * string) list ->
   bridge:string ->
-  managed:bool -> [ `network ] Ref.t
+  managed:bool ->
+  purposes:API.network_purpose list ->
+  [ `network ] Ref.t
 
 (** Attempt to create a bridge with a unique name *)
 val create :

ocaml/xapi/xapi_pool.ml

@@ -423,6 +423,22 @@ let pre_join_checks ~__context ~rpc ~session_id ~force =
       raise (Api_errors.Server_error(Api_errors.operation_not_allowed, ["Primary address type differs"]));
   in
 
+  let assert_compatible_network_purposes () = try (
+    let my_nbdish =
+      Db.Network.get_all ~__context |>
+      List.map (fun nwk -> Db.Network.get_purposes ~__context ~self:nwk) |>
+      List.flatten |>
+      List.find (function `nbd | `insecure_nbd -> true | _ -> false) in
+    let remote_nbdish =
+      Client.Network.get_all rpc session_id |>
+      List.map (fun nwk -> Client.Network.get_purposes ~rpc ~session_id ~self:nwk) |>
+      List.flatten |>
+      List.find (function `nbd | `insecure_nbd -> true | _ -> false) in
+    if remote_nbdish <> my_nbdish then
+      raise Api_errors.(Server_error(operation_not_allowed, ["Incompatible network purposes: nbd and insecure_nbd"]))
+  ) with Not_found -> () (* If either side has no network with nbd-related purpose, then no problem. *)
+  in
+
   (* call pre-join asserts *)
   assert_pool_size_unrestricted ();
   assert_management_interface_exists ();
@@ -446,7 +462,8 @@ let pre_join_checks ~__context ~rpc ~session_id ~force =
   assert_api_version_matches ();
   assert_db_schema_matches ();
   assert_homogeneous_updates ();
-  assert_homogeneous_primary_address_type ()
+  assert_homogeneous_primary_address_type ();
+  assert_compatible_network_purposes ()
 
 let rec create_or_get_host_on_master __context rpc session_id (host_ref, host) : API.ref_host =
   let my_uuid = host.API.host_uuid in
@@ -638,6 +655,7 @@ let create_or_get_network_on_master __context rpc session_id (network_ref, netwo
           ~other_config:network.API.network_other_config
           ~bridge:network.API.network_bridge
           ~managed:network.API.network_managed
+          ~purposes:network.API.network_purposes
     else begin
       debug "Recreating network '%s' as internal network." network.API.network_name_label;
       (* This call will generate a new 'xapi#' bridge name rather than keeping the