XSI-1987 & CA-416462: Fix RPU host evacuation version check

ocaml/tests/test_helpers.ml

@@ -466,6 +466,138 @@ module RunInParallel = Generic.MakeStateless (struct
       ]
 end)
 
+module Version = struct
+  let test_compare_int_list () =
+    let test_cases =
+      [
+        ("Equal Lists", [1; 2; 3], [1; 2; 3], 0)
+      ; ("Empty Lists", [], [], 0)
+      ; ("'a' is smaller (first element)", [1; 10; 100], [2; 0; 0], -1)
+      ; ("'a' is smaller (later element)", [1; 2; 3], [1; 2; 4], -1)
+      ; ("'a' is greater (first element)", [5; 1; 1], [2; 10; 10], 1)
+      ; ("'a' is greater (later element)", [1; 3; 3], [1; 2; 4], 1)
+      ; ("Lists with negative numbers", [0; -5; 10], [0; -2; -10], -1)
+      ; ("Single element lists (equal)", [42], [42], 0)
+      ; ("Single element lists (unequal)", [42], [43], -1)
+      ; ("Different number of element in lists", [25; 27], [25; 27; 1], -1)
+      ]
+    in
+    let test_compare (description, list1, list2, expected) =
+      let actual = Helpers.compare_int_lists list1 list2 in
+      let description = Printf.sprintf "compate_int_lists: %s" description in
+      Alcotest.(check int) description expected actual
+    in
+    List.iter test_compare test_cases
+
+  let test_version_numbers_of_string () =
+    let test_cases =
+      [
+        ( "Standard major.minor.patch version, e.g. xapi build version stored \
+           in the database"
+        , "25.30.0"
+        , [25; 30; 0]
+        )
+      ; ( "Dev build version, e.g. xapi build version stored in the database"
+        , "25.30.0.6.gb239bd75a"
+        , [25; 30; 0; 6]
+        )
+      ; ( "Version with a patch identifier e.g. xen versions stored in the \
+           database"
+        , "25.15.0-13"
+        , [25; 15; 0; 13]
+        )
+      ; ("Default version", "0.0.0", [0; 0; 0])
+      ]
+    in
+    let test_version_numbers (description, version_string, expected) =
+      let actual = Helpers.version_numbers_of_string version_string in
+      let description =
+        Printf.sprintf "version_numbers_of_string: %s" description
+      in
+      Alcotest.(check @@ list int) description expected actual
+    in
+    List.iter test_version_numbers test_cases
+
+  let test_compare_versions () =
+    let sw_vers_a =
+      Xapi_globs.[(_platform_version, "2.4.0"); (_xen_version, "4.14.0-13")]
+    in
+    let sw_vers_b = Xapi_globs.[(_xen_version, "4.13.0-13")] in
+    let test_cases =
+      Xapi_globs.
+        [
+          ( "Software versions 'b' are missing platform version"
+          , _platform_version
+          , sw_vers_a
+          , sw_vers_b
+          , 1
+          )
+        ; ( "Software versions 'a' are missing platform version"
+          , _platform_version
+          , sw_vers_b
+          , sw_vers_a
+          , -1
+          )
+        ; ( "xen version exists in both (`a` is greater)"
+          , _xen_version
+          , sw_vers_a
+          , sw_vers_b
+          , 1
+          )
+        ; ( "xapi build version is missing from both (equal)"
+          , _xapi_build_version
+          , sw_vers_a
+          , sw_vers_b
+          , 0
+          )
+        ]
+    in
+    let test_compare (description, key, value_a, value_b, expected) =
+      let actual = Helpers.compare_versions ~version_key:key value_a value_b in
+      let description = Printf.sprintf "compare_versions: %s" description in
+      Alcotest.(check int) description expected actual
+    in
+    List.iter test_compare test_cases
+
+  let test_compare_all_versions () =
+    let current =
+      Xapi_globs.[(_platform_version, "8.1.0"); (_xen_version, "4.13.0-15")]
+    in
+    let newer =
+      Xapi_globs.[(_platform_version, "8.2.0"); (_xen_version, "4.13.0-15")]
+    in
+    let mixed =
+      Xapi_globs.[(_platform_version, "8.2.0"); (_xen_version, "4.12.0-15")]
+    in
+    let test_cases =
+      [
+        ("Newer is greater or equal than Current", newer, current, true)
+      ; ("Current is greater or equal than Current", current, current, true)
+      ; ("Current is not greater or equal than Newer", current, newer, false)
+      ; ("Mixed is not greater or equal then Current", mixed, current, false)
+      ; ("Current is not greater or equal than Mixed", current, mixed, false)
+      ]
+    in
+    let test_compare (description, vers_a, vers_b, expected) =
+      let actual =
+        Helpers.compare_all_versions ~is_greater_or_equal:vers_a ~than:vers_b
+      in
+      let description = Printf.sprintf "compare_all_versions: %s" description in
+      Alcotest.(check bool) description expected actual
+    in
+    List.iter test_compare test_cases
+
+  let test =
+    [
+      ("Compare int list", `Quick, test_compare_int_list)
+    ; ("Version numbers from string", `Quick, test_version_numbers_of_string)
+    ; ("Compare versions", `Quick, test_compare_versions)
+    ; ("Compare all versions", `Quick, test_compare_all_versions)
+    ]
+
+  let tests = [("Version compare tests", test)]
+end
+
 let tests =
   make_suite "helpers_"
     [
@@ -476,3 +608,4 @@ let tests =
     ; ("assert_is_valid_cidr", CIDRCheckers.tests)
     ; ("run_in_parallel", RunInParallel.tests)
     ]
+  @ Version.tests

ocaml/xapi/db_gc.ml

@@ -165,16 +165,18 @@ let detect_rolling_upgrade ~__context =
         in
         (* Resynchronise *)
         if actually_in_progress <> pool_says_in_progress then (
-          let platform_versions =
+          let host_versions =
             List.map
               (fun host ->
-                Helpers.version_string_of ~__context (Helpers.LocalObject host)
+                Helpers.get_software_versions ~__context
+                  (Helpers.LocalObject host)
+                |> Helpers.versions_string_of
               )
               (Db.Host.get_all ~__context)
           in
           debug "xapi platform version = %s; host platform versions = [ %s ]"
             (Xapi_version.platform_version ())
-            (String.concat "; " platform_versions) ;
+            (String.concat "; " host_versions) ;
           warn
             "Pool thinks rolling upgrade%s in progress but Host version \
              numbers indicate otherwise; correcting"

ocaml/xapi/helpers.ml

@@ -867,12 +867,18 @@ let assert_we_are_master ~__context =
       )
 
 (* Host version compare helpers *)
-let compare_int_lists : int list -> int list -> int =
+let rec compare_int_lists : int list -> int list -> int =
  fun a b ->
-  let first_non_zero is =
-    List.fold_left (fun a b -> if a <> 0 then a else b) 0 is
-  in
-  first_non_zero (List.map2 compare a b)
+  match (a, b) with
+  | [], [] ->
+      0
+  | [], _ ->
+      -1
+  | _, [] ->
+      1
+  | x :: xs, y :: ys ->
+      let r = compare x y in
+      if r <> 0 then r else compare_int_lists xs ys
 
 let group_by f list =
   let evaluated_list = List.map (fun x -> (x, f x)) list in
@@ -913,72 +919,109 @@ let sort_by_schwarzian ?(descending = false) f list =
   |> List.sort (fun (_, x') (_, y') -> comp x' y')
   |> List.map (fun (x, _) -> x)
 
-let platform_version_inverness = [2; 4; 0]
+let version_keys_list =
+  Xapi_globs.[_platform_version; _xapi_build_version; _xen_version]
 
-let version_string_of : __context:Context.t -> [`host] api_object -> string =
- fun ~__context host ->
-  try
-    let software_version =
-      match host with
-      | LocalObject host_ref ->
-          Db.Host.get_software_version ~__context ~self:host_ref
-      | RemoteObject (rpc, session_id, host_ref) ->
-          Client.Client.Host.get_software_version ~rpc ~session_id
-            ~self:host_ref
-    in
-    List.assoc Xapi_globs._platform_version software_version
-  with Not_found -> Xapi_globs.default_platform_version
+let get_software_versions ~__context host =
+  ( match host with
+  | LocalObject self ->
+      Db.Host.get_software_version ~__context ~self
+  | RemoteObject (rpc, session_id, self) ->
+      Client.Client.Host.get_software_version ~rpc ~session_id ~self
+  )
+  |> List.filter (fun (k, _) -> List.mem k version_keys_list)
+
+let versions_string_of : (string * string) list -> string =
+ fun ver_list ->
+  ver_list
+  |> List.map (fun (k, v) -> Printf.sprintf "%s: %s" k v)
+  |> String.concat ","
+
+let version_numbers_of_string version_string =
+  ( match String.split_on_char '-' version_string with
+  | [standard_version; patch] ->
+      String.split_on_char '.' standard_version @ [patch]
+  | [standard_version] ->
+      String.split_on_char '.' standard_version
+  | _ ->
+      ["0"; "0"; "0"]
+  )
+  |> List.filter_map int_of_string_opt
 
-let version_of : __context:Context.t -> [`host] api_object -> int list =
- fun ~__context host ->
-  let vs = version_string_of ~__context host in
-  List.map int_of_string (String.split_on_char '.' vs)
+let version_of : version_key:string -> (string * string) list -> int list =
+ fun ~version_key versions_list ->
+  List.assoc_opt version_key versions_list
+  |> Option.value ~default:"0.0.0"
+  |> version_numbers_of_string
 
 (* Compares host versions, analogous to Stdlib.compare. *)
-let compare_host_platform_versions :
-    __context:Context.t -> [`host] api_object -> [`host] api_object -> int =
- fun ~__context host_a host_b ->
-  let version_of = version_of ~__context in
-  compare_int_lists (version_of host_a) (version_of host_b)
-
-let max_version_in_pool : __context:Context.t -> int list =
+let compare_versions :
+       version_key:string
+    -> (string * string) list
+    -> (string * string) list
+    -> int =
+ fun ~version_key sw_ver_a sw_ver_b ->
+  let version_a = version_of ~version_key sw_ver_a in
+  let version_b = version_of ~version_key sw_ver_b in
+  compare_int_lists version_a version_b
+
+let compare_all_versions ~is_greater_or_equal:a ~than:b =
+  List.for_all
+    (fun version_key -> compare_versions ~version_key a b >= 0)
+    version_keys_list
+
+let max_version_in_pool : __context:Context.t -> (string * string) list =
  fun ~__context ->
   let max_version a b =
-    if a = [] then b else if compare_int_lists a b > 0 then a else b
+    if a = [] then
+      b
+    else if compare_all_versions ~is_greater_or_equal:a ~than:b then
+      a
+    else
+      b
   and versions =
     List.map
-      (fun host_ref -> version_of ~__context (LocalObject host_ref))
+      (fun host_ref -> get_software_versions ~__context (LocalObject host_ref))
       (Db.Host.get_all ~__context)
   in
   List.fold_left max_version [] versions
 
 let host_has_highest_version_in_pool :
     __context:Context.t -> host:[`host] api_object -> bool =
  fun ~__context ~host ->
-  let host_version = version_of ~__context host
+  let host_versions = get_software_versions ~__context host
   and max_version = max_version_in_pool ~__context in
-  compare_int_lists host_version max_version >= 0
+  compare_all_versions ~is_greater_or_equal:host_versions ~than:max_version
 
 let host_versions_not_decreasing ~__context ~host_from ~host_to =
-  compare_host_platform_versions ~__context host_from host_to <= 0
+  let sw_vers_from = get_software_versions ~__context host_from in
+  let sw_vers_to = get_software_versions ~__context host_to in
+  compare_all_versions ~is_greater_or_equal:sw_vers_to ~than:sw_vers_from
 
-let is_platform_version_same_on_master ~__context ~host =
+let are_host_versions_same_on_master_inner ~__context ~host ~master =
   if is_pool_master ~__context ~host then
     true
   else
-    let master = get_master ~__context in
-    compare_host_platform_versions ~__context (LocalObject master)
-      (LocalObject host)
-    = 0
+    let sw_ver_master = get_software_versions ~__context (LocalObject master) in
+    let sw_ver_host = get_software_versions ~__context (LocalObject host) in
+    List.for_all
+      (fun version_key ->
+        compare_versions ~version_key sw_ver_master sw_ver_host = 0
+      )
+      version_keys_list
+
+let are_host_versions_same_on_master ~__context ~host =
+  let master = get_master ~__context in
+  are_host_versions_same_on_master_inner ~__context ~host ~master
 
 let maybe_raise_vtpm_unimplemented func message =
   if not !ignore_vtpm_unimplemented then (
     error {|%s: Functionality not implemented yet. "%s"|} func message ;
     raise Api_errors.(Server_error (not_implemented, [message]))
   )
 
-let assert_platform_version_is_same_on_master ~__context ~host ~self =
-  if not (is_platform_version_same_on_master ~__context ~host) then
+let assert_host_versions_are_same_on_master ~__context ~host ~self =
+  if not (are_host_versions_same_on_master ~__context ~host) then
     raise
       (Api_errors.Server_error
          ( Api_errors.vm_host_incompatible_version
@@ -1004,15 +1047,14 @@ let assert_host_has_highest_version_in_pool :
 
 let pool_has_different_host_platform_versions ~__context =
   let all_hosts = Db.Host.get_all ~__context in
-  let platform_versions =
-    List.map
-      (fun host -> version_string_of ~__context (LocalObject host))
-      all_hosts
-  in
-  let is_different_to_me platform_version =
-    platform_version <> Xapi_version.platform_version ()
-  in
-  List.exists is_different_to_me platform_versions
+  let master = get_master ~__context in
+  not
+    (List.for_all
+       (fun host ->
+         are_host_versions_same_on_master_inner ~__context ~host ~master
+       )
+       all_hosts
+    )
 
 (* Checks that a host has a PBD for a particular SR (meaning that the
    SR is visible to the host) *)

ocaml/xapi/xapi_globs.ml

@@ -151,6 +151,10 @@ let _dbv = "dbv"
 
 let _db_schema = "db_schema"
 
+let _xapi_build_version = "xapi_build"
+
+let _xen_version = "xen"
+
 (* When comparing two host versions, always treat a host that has platform_version defined as newer
  * than any host that does not have platform_version defined.
  * Substituting this default when a host does not have platform_version defined will be acceptable,

ocaml/xapi/xapi_host.ml

@@ -285,13 +285,18 @@ let compute_evacuation_plan_no_wlb ~__context ~host ?(ignore_ha = false) () =
      	   the source host. So as long as host versions aren't decreasing,
      	   we're allowed to migrate VMs between hosts. *)
   debug "evacuating host version: %s"
-    (Helpers.version_string_of ~__context (Helpers.LocalObject host)) ;
+    (Helpers.get_software_versions ~__context (Helpers.LocalObject host)
+    |> Helpers.versions_string_of
+    ) ;
   let target_hosts =
     List.filter
       (fun target ->
         debug "host %s version: %s"
           (Db.Host.get_hostname ~__context ~self:target)
-          (Helpers.version_string_of ~__context (Helpers.LocalObject target)) ;
+          Helpers.(
+            get_software_versions ~__context (LocalObject target)
+            |> versions_string_of
+          ) ;
         Helpers.host_versions_not_decreasing ~__context
           ~host_from:(Helpers.LocalObject host)
           ~host_to:(Helpers.LocalObject target)