Merge pull request xapi-project#3144 from jonludlam/CA-260352

CA-260352: Fix upgrade from 1.14-ppx to 1.30

Author: lindig

ocaml/client_records/records.ml

@@ -1032,7 +1032,7 @@ let pool_update_record rpc session_id update =
         make_field ~name:"installation-size"   ~get:(fun () -> Int64.to_string (x ()).API.pool_update_installation_size) ();
         make_field ~name:"hosts"               ~get:(fun () -> String.concat ", " (get_hosts ())) ~get_set:get_hosts ();
         make_field ~name:"after-apply-guidance" ~get:(fun () -> String.concat ", " (after_apply_guidance ())) ~get_set:after_apply_guidance ();
-        make_field ~name:"enforce-homogeneity" ~get:(fun () -> string_of_bool (x ()).API.pool_update_enforce_homogeneity) ();
+        make_field ~name:"enforce-homogeneity" ~get:(fun () -> string_of_bool (Client.Pool_update.get_enforce_homogeneity rpc session_id !_ref)) ();
       ]}
 
 let host_cpu_record rpc session_id host_cpu =

ocaml/idl/datamodel.ml

@@ -4098,6 +4098,17 @@ let pool_update_resync_host = call
     ~allowed_roles:_R_POOL_OP
     ()
 
+let pool_update_get_enforce_homogeneity = call
+    ~name:"get_enforce_homogeneity"
+    ~hide_from_docs:true
+    ~doc:"Get the value of the field 'enforce_homogeneity'"
+    ~in_oss_since:None
+    ~in_product_since:rel_honolulu
+    ~params:[ Ref _pool_update, "self", "The update to be queried"]
+    ~allowed_roles:_R_POOL_OP
+    ~result:(Bool, "The value of the field")
+    ()
+
 let pool_update =
   create_obj ~in_db:true
     ~in_product_since:rel_ely
@@ -4122,6 +4133,7 @@ let pool_update =
       pool_update_attach;
       pool_update_detach;
       pool_update_resync_host;
+      pool_update_get_enforce_homogeneity;
     ]
     ~contents:
       [ uid       ~in_oss_since:None _pool_update;
@@ -4132,13 +4144,6 @@ let pool_update =
         field     ~in_product_since:rel_ely ~default_value:(Some (VSet [])) ~in_oss_since:None ~qualifier:StaticRO ~ty:(Set pool_update_after_apply_guidance) "after_apply_guidance" "What the client should do after this update has been applied.";
         field     ~in_oss_since:None ~qualifier:StaticRO ~ty:(Ref _vdi) "vdi" "VDI the update was uploaded to";
         field     ~in_product_since:rel_ely ~in_oss_since:None ~qualifier:DynamicRO ~ty:(Set (Ref _host)) "hosts" "The hosts that have applied this update.";
-        field     ~in_product_since:rel_honolulu
-                  ~default_value:(Some (VBool false))
-                  ~in_oss_since:None
-                  ~qualifier:StaticRO
-                  ~ty:Bool
-                  "enforce_homogeneity"
-                  "Flag - if true, all hosts in a pool must apply this update";
       ]
     ()
 

ocaml/xapi/message_forwarding.ml

@@ -3949,6 +3949,7 @@ module Forward = functor(Local: Custom_actions.CUSTOM_ACTIONS) -> struct
       do_op_on ~local_fn ~__context ~host
         (fun session_id rpc -> Client.Pool_update.resync_host rpc session_id host)
 
+    let get_enforce_homogeneity = Local.Pool_update.get_enforce_homogeneity
   end
   module VGPU_type = struct end
   module LVHD = struct end

ocaml/xapi/xapi_pool.ml

@@ -144,14 +144,30 @@ let pre_join_checks ~__context ~rpc ~session_id ~force =
   in
 
   let assert_homogeneous_updates () =
+    (* If we can't find the 'enforce_homogeneity' key, we'll default to it being true. However,
+       let's make an override in case something has gone seriously wrong *)
+    let default_update_enforcement =
+      let pool = List.hd (Client.Pool.get_all rpc session_id) in
+      let remote_pool_other_config = Client.Pool.get_other_config rpc session_id pool in
+      try bool_of_string (List.assoc "default_update_enforcement" remote_pool_other_config) with _ -> true
+    in
+    let safe_get_enforce_homogeneity rpc session_id self =
+      try
+        Client.Pool_update.get_enforce_homogeneity rpc session_id self
+      with e ->
+        error "error locating an update's enforce_homogeneity flag. Update ref: '%s' Exception: '%s'"
+          (Ref.string_of self)
+          (Printexc.to_string e);
+        default_update_enforcement
+    in
     let module S      = Helpers.StringSet in
     let local_host    = Helpers.get_localhost ~__context in
     let local_uuid    = Db.Host.get_uuid ~__context ~self:local_host in
     let updates_on ~rpc ~session_id host =
       Client.Host.get_updates ~rpc ~session_id ~self:host
-      |> List.map (fun self -> Client.Pool_update.get_record ~rpc ~session_id ~self)
-      |> List.filter (fun upd -> upd.API.pool_update_enforce_homogeneity = true)
-      |> List.map (fun upd -> upd.API.pool_update_uuid)
+      |> List.map (fun self -> (self,Client.Pool_update.get_record ~rpc ~session_id ~self))
+      |> List.filter (fun (self,upd) -> safe_get_enforce_homogeneity rpc session_id self = true)
+      |> List.map (fun (_,upd) -> upd.API.pool_update_uuid)
       |> S.of_list in
     let local_updates =
       Helpers.call_api_functions ~__context (fun rpc session_id ->

ocaml/xapi/xapi_pool_update.ml

@@ -348,6 +348,52 @@ let patch_uuid_of_update_uuid uuid =
   modify 4; modify 5; modify 6; modify 7;
   Uuid.uuid_of_int_array arr |> Uuid.string_of_uuid
 
+
+module EnforceHomogeneityWorkaround = struct
+  (* Enforce homogeneity horrendous hack *)
+
+  (* We're doing this because we can't put new keys in the database and then upgrade to the
+     released version of 7.2 that doesn't understand the database keys. So we stash them in
+     other_config. Unforunately pool_update doesn't contain other_config, but pool patch
+     does. So we'll stick it in there. Eughrghghg. *)
+  let __enforce_homogeneity_key = "enforce_homogeneity"
+
+  (* Retreive the pool_patch object associated with a pool_update. This is very
+     similar to the function 'pool_patch_of_update' in xapi_pool_patch.ml, but
+     because we might be talking about a different pool we need to only use the
+     public API, not the internal Db calls that that function uses. Also, because
+     the pool_update field of the pool_patch record is not exposed in the API, we
+     have to use the above patch_uuid_of_update_uuid function... *)
+  let pool_patch_of_update rpc session_id ref =
+    let update_uuid = Client.Pool_update.get_uuid rpc session_id ref in
+    let patch_uuid = patch_uuid_of_update_uuid update_uuid in
+    try
+      Client.Pool_patch.get_by_uuid rpc session_id patch_uuid
+    with e ->
+      error "Invalid state: Expected invariant - 1 pool_patch per pool_update. Got %s"
+        (Printexc.to_string e);
+      raise Api_errors.(Server_error (internal_error, ["Invalid state"]))
+
+  (* Note that this function will purposefully raise exceptions if there's any
+     problem figuring out the value of 'enforce_homogeneity'. It's up to the
+     caller to decide what to do in this case *)
+  let get_enforce_homogeneity rpc session_id ~self =
+    let pool_patch_ref = pool_patch_of_update rpc session_id self in
+    Client.Pool_patch.get_other_config rpc session_id pool_patch_ref
+    |> List.assoc __enforce_homogeneity_key
+    |> bool_of_string
+
+  let set_enforce_homogeneity rpc session_id ~self ~value =
+    let pool_patch_ref = pool_patch_of_update rpc session_id self in
+    Client.Pool_patch.remove_from_other_config rpc session_id pool_patch_ref __enforce_homogeneity_key;
+    Client.Pool_patch.add_to_other_config rpc session_id pool_patch_ref __enforce_homogeneity_key (string_of_bool value)
+
+end
+
+let get_enforce_homogeneity ~__context ~self =
+  Helpers.call_api_functions ~__context (fun rpc session_id ->
+    EnforceHomogeneityWorkaround.get_enforce_homogeneity rpc session_id self)
+
 let create_update_record ~__context ~update ~update_info ~vdi =
   let patch_ref = Ref.make () in
   ignore(Db.Pool_patch.create ~__context
@@ -360,7 +406,7 @@ let create_update_record ~__context ~update ~update_info ~vdi =
            ~pool_applied:false
            ~after_apply_guidance:update_info.after_apply_guidance
            ~pool_update:update
-           ~other_config:[]);
+           ~other_config:[EnforceHomogeneityWorkaround.__enforce_homogeneity_key,string_of_bool update_info.enforce_homogeneity]);
   Db.Pool_update.create ~__context
     ~ref:update
     ~uuid:update_info.uuid
@@ -371,7 +417,6 @@ let create_update_record ~__context ~update ~update_info ~vdi =
     ~key:update_info.key
     ~after_apply_guidance:update_info.after_apply_guidance
     ~vdi:vdi
-    ~enforce_homogeneity:update_info.enforce_homogeneity
 
 let introduce ~__context ~vdi =
   ignore(Unixext.mkdir_safe Xapi_globs.host_update_dir 0o755);
@@ -462,8 +507,12 @@ let resync_host ~__context ~host =
           | Some self ->
             (* re-interpret the enforce_homogeneity flag CP-258536 *)
             debug "pool_update.resync_host: update %s exists - updating it" update_uuid;
-            Db.Pool_update.set_enforce_homogeneity ~__context ~self
-              ~value:update_info.enforce_homogeneity
+            begin try
+              Helpers.call_api_functions ~__context (fun rpc session_id -> 
+                EnforceHomogeneityWorkaround.set_enforce_homogeneity rpc session_id self update_info.enforce_homogeneity)
+            with e ->
+              error "Failed to set enforce_homogeneity: %s" (Printexc.to_string e)
+            end
           | None ->
             let update = Ref.make () in
             debug "pool_update.resync_host: update %s not in database - creating it" update_uuid;