CA-212079: Allow XenMotion and AD during RPU from pre-Dundee

ocaml/test/OMakefile

@@ -64,6 +64,7 @@ OCAML_OBJS = \
 	test_dbsync_master \
 	test_xapi_xenops \
 	test_no_migrate \
+	test_features \
 
 OCamlProgram(suite, suite $(OCAML_OBJS) )
 

ocaml/test/suite.ml

@@ -34,6 +34,7 @@ let base_suite =
 			Test_map_check.test;
 			Test_pool_apply_edition.test;
 			Test_pool_license.test;
+			Test_features.test;
 			Test_pool_restore_database.test;
 			Test_platformdata.test;
 			Test_sm_features.test;

ocaml/test/test_features.ml

@@ -0,0 +1,67 @@
+(*
+ * Copyright (C) Citrix Systems Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU Lesser General Public License as published
+ * by the Free Software Foundation; version 2.1 only. with the special
+ * exception on linking described in file LICENSE.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ * GNU Lesser General Public License for more details.
+ *)
+
+open OUnit
+open Test_highlevel
+open Features
+
+module OfAssocList = Generic.Make(struct
+	module Io = struct
+		type input_t = (string * string) list
+		type output_t = Features.feature list
+
+		let string_of_input_t = Test_printers.(assoc_list string string)
+		let string_of_output_t =
+			Test_printers.(fun features -> String.concat "," (List.map name_of_feature features))
+	end
+
+	let transform = of_assoc_list
+
+	(* Xen_motion and AD are enabled unless explicitly disabled. All other features
+	   are disabled unless explitly enabled. *)
+	let tests = [
+		[],
+		[Xen_motion; AD];
+
+		["restrict_xen_motion", "true";
+		 "restrict_ad", "true"],
+		[];
+
+		["restrict_xen_motion", "true"],
+		[AD];
+
+		["restrict_xen_motion", "false"],
+		[Xen_motion; AD];
+
+		["restrict_xen_motion", "false";
+		 "restrict_dmc", "false"],
+		[DMC; Xen_motion; AD];
+
+		["restrict_xen_motion", "false";
+		 "restrict_ad", "true";
+		 "restrict_dmc", "false"],
+		[DMC; Xen_motion];
+
+		["enable_xha", "true";
+		 "restrict_xen_motion", "true"],
+		[HA; AD];
+	]
+end)
+
+
+let test =
+	"pool_license" >:::
+		[
+			"test_of_assoc_list" >::: OfAssocList.tests;
+		]

ocaml/xapi/features.ml

@@ -95,6 +95,12 @@ let keys_of_features =
 		Live_patching, ("restrict_live_patching", Negative, "Live_patching");
 	]
 
+(* A list of features that must be considered "enabled" by `of_assoc_list`
+   if the feature string is missing from the list. These are existing features
+   that have been recently restricted, and which we want to remain enabled during
+   a rolling pool upgrade. *)
+let enabled_when_unknown = [Xen_motion; AD]
+
 let name_of_feature f =
 	rpc_of_feature f |> Rpc.string_of_rpc
 
@@ -134,15 +140,13 @@ let to_assoc_list (s: feature list) =
 	List.map get_map all_features
 
 let of_assoc_list l =
-	let get_feature (k, v) =
+	let get_feature f =
 		try
-			let v = bool_of_string v in
-			let f, o = feature_of_string k in
+			let str, o = string_of_feature f in
+			let v = bool_of_string (List.assoc str l) in
 			let v = if o = Positive then v else not v in
 			if v then Some f else None
 		with _ ->
-			None
+			if List.mem f enabled_when_unknown then Some f else None
 	in
-	let features = List.map get_feature l in
-	List.fold_left (function ac -> function Some f -> f :: ac | None -> ac) [] features
-
+	Stdext.Listext.List.filter_map get_feature all_features

ocaml/xapi/pool_features.ml

@@ -15,17 +15,17 @@ open Features
 module D = Debug.Make(struct let name="pool_features" end)
 open D
 
-let all_flags = List.map (fun (k, v) -> k) (to_assoc_list all_features)
-
-let new_restrictions params =
-	let kvs = List.filter (fun (k, v) ->
-			try String.sub k 0 9 = "restrict_" && not (List.mem k all_flags)
-			with Invalid_argument _ -> false
-		) params in
-	List.map (fun (k, v) -> k) kvs
+(*
+	Terminology:
+	- (Feature) flags: The keys in pool.restriction and host.license_params. Strings like "restrict_dmc".
+	- Params: An instance of host.license_params.
+	- Restrictions: A (string * string) list of feature flag to a Boolean string value ("true" or "false").
+	- Features: Values of type Features.feature.
+	- Core: Relating to features known by xapi, as define in features.ml.
+	- Additional: Relating to features provided by v6d beyond the core ones.
+*)
 
-let pool_features_of_list hosts =
-	List.fold_left Stdext.Listext.List.intersect all_features hosts
+let all_flags = List.map (fun (k, v) -> k) (to_assoc_list all_features)
 
 let get_pool_features ~__context =
 	let pool = Helpers.get_pool ~__context in
@@ -37,39 +37,71 @@ let is_enabled ~__context f =
 
 let assert_enabled ~__context ~f =
 	if not (is_enabled ~__context f) then
-		raise (Api_errors.Server_error(Api_errors.license_restriction, [Features.name_of_feature f]))
+		raise (Api_errors.Server_error(Api_errors.license_restriction, [name_of_feature f]))
+
+(* The set of core restrictions of a pool is the intersection of the sets of features
+   of the individual hosts. *)
+let compute_core_features all_host_params =
+	List.map of_assoc_list all_host_params
+	|> List.fold_left Stdext.Listext.List.intersect all_features
 
+(* Find the feature flags in the given license params that are not represented
+   in the feature type. These are additional flags given to us by v6d.
+   Assume that their names always start with "restrict_". *)
+let find_additional_flags params =
+	let kvs = List.filter (fun (k, v) ->
+			try String.sub k 0 9 = "restrict_" && not (List.mem k all_flags)
+			with Invalid_argument _ -> false
+		) params in
+	List.map fst kvs
+
+(* Determine the set of additional features. For each restrict_ flag,
+   looks for matching flags on all hosts; if one of them is restricted ("true")
+   or absent, then the feature on the pool level is marked as restricted. *)
+let rec compute_additional_restrictions all_host_params = function
+	| [] -> []
+	| flag :: rest ->
+		let switches =
+			List.map
+				(function params ->
+					if List.mem_assoc flag params
+					then bool_of_string (List.assoc flag params)
+					else true)
+				all_host_params
+		in
+		(flag, string_of_bool (List.fold_left (||) false switches)) ::
+			compute_additional_restrictions all_host_params rest
+
+(* Combine the host-level feature restrictions into pool-level ones, and write
+   the result to the database. *)
 let update_pool_features ~__context =
+	(* Get information from the database *)
 	let pool = Helpers.get_pool ~__context in
-	let pool_restrictions = Db.Pool.get_restrictions ~__context ~self:pool in
-	let hosts = List.map
+	let old_restrictions = Db.Pool.get_restrictions ~__context ~self:pool in
+	let all_host_params = List.map
 		(fun (_, host_r) -> host_r.API.host_license_params)
 		(Db.Host.get_all_records ~__context) in
-	let master =
+	let master_params =
 		let master_ref = Db.Pool.get_master ~__context ~self:pool in
 		Db.Host.get_license_params ~__context ~self:master_ref
 	in
-	let new_features = pool_features_of_list (List.map of_assoc_list hosts) in
-	let additional_flags = new_restrictions master in
-	let rec find_additional = function
-		| [] -> []
-		| flag :: rest ->
-			let switches =
-				List.map
-					(function params ->
-						if List.mem_assoc flag params
-						then bool_of_string (List.assoc flag params)
-						else true)
-					hosts
-			in
-			(flag, string_of_bool (List.fold_left (||) false switches)) :: find_additional rest
-	in
-	let additional_restrictions = find_additional additional_flags in
-	let new_restrictions = additional_restrictions @ (to_assoc_list new_features) in
-	if new_restrictions <> pool_restrictions then begin
-		let pool_features = of_assoc_list pool_restrictions in
-		info "Old pool features enabled: %s" (to_compact_string pool_features);
-		info "New pool features enabled: %s" (to_compact_string new_features);
+
+	(* Determine the set of core restrictions *)
+	let new_core_features = compute_core_features all_host_params in
+	let new_core_restrictions = to_assoc_list new_core_features in
+
+	(* Determine the set of additional restrictions *)
+	let additional_flags = find_additional_flags master_params in
+	let new_additional_restrictions = compute_additional_restrictions all_host_params additional_flags in
+
+	(* The complete set of restrictions is formed by the core feature plus the additional features *)
+	let new_restrictions = new_additional_restrictions @ new_core_restrictions in
+
+	(* Update the DB if the restrictions have changed *)
+	if new_restrictions <> old_restrictions then begin
+		let old_core_features = of_assoc_list old_restrictions in
+		info "Old pool features enabled: %s" (to_compact_string old_core_features);
+		info "New pool features enabled: %s" (to_compact_string new_core_features);
 		Db.Pool.set_restrictions ~__context ~self:pool ~value:new_restrictions;
 		Xapi_pool_helpers.apply_guest_agent_config ~__context
 	end