diff --git a/ocaml/test/OMakefile b/ocaml/test/OMakefile index 777c996755..a7572a1c5d 100644 --- a/ocaml/test/OMakefile +++ b/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) ) diff --git a/ocaml/test/suite.ml b/ocaml/test/suite.ml index 8b1fcb6aa1..4cd66b0108 100644 --- a/ocaml/test/suite.ml +++ b/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; diff --git a/ocaml/test/test_features.ml b/ocaml/test/test_features.ml new file mode 100644 index 0000000000..f2719773c2 --- /dev/null +++ b/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; + ] diff --git a/ocaml/xapi/features.ml b/ocaml/xapi/features.ml index 44092d9aa9..441df767e0 100644 --- a/ocaml/xapi/features.ml +++ b/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 diff --git a/ocaml/xapi/pool_features.ml b/ocaml/xapi/pool_features.ml index badab68a2d..db0722dfd7 100644 --- a/ocaml/xapi/pool_features.ml +++ b/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