[LCM to feature] Merge LCM to feature branch (#6962)

minglumlu · web-flow · commit 8789d0cef53d · 2026-03-20T14:58:30.000+08:00
diff --git a/ocaml/idl/ocaml_backend/dune b/ocaml/idl/ocaml_backend/dune
@@ -4,6 +4,8 @@
   (libraries
     astring
     cmdliner
+    fmt
+    ptime.clock
     uuidm
     xapi-consts
     xapi-datamodel
diff --git a/ocaml/idl/ocaml_backend/gen_rbac.ml b/ocaml/idl/ocaml_backend/gen_rbac.ml
@@ -34,10 +34,13 @@ let internal_role_local_root = "_local_root_"
 
 (* the output of this function is used as input by the automatic tests *)
 let writer_csv static_permissions_roles =
-  Printf.sprintf "%s,PERMISSION/ROLE,%s\n"
-    (let t = Debug.gettimestring () in
-     String.sub t 0 (String.length t - 1)
-    )
+  let now =
+    let now = Ptime_clock.now () in
+    let str = Fmt.str "%a" Ptime.(pp_rfc3339 ~frac_s:3 ~tz_offset_s:0 ()) now in
+    (* remove separators between Year, Month, and Day; to keep old logging format *)
+    Astring.String.filter (function '-' -> false | _ -> true) str
+  in
+  Printf.sprintf "%s,PERMISSION/ROLE,%s\n" now
     (* role titles are ordered by roles in roles_all *)
     (List.fold_left (fun rr r -> rr ^ r ^ ",") "" Datamodel_roles.roles_all)
   ^ List.fold_left
diff --git a/ocaml/libs/log/debug.ml b/ocaml/libs/log/debug.ml
@@ -74,13 +74,8 @@ let tasks : task ThreadLocalTable.t = ThreadLocalTable.make ()
 let names : string ThreadLocalTable.t = ThreadLocalTable.make ()
 
 let gettimestring () =
-  let time = Unix.gettimeofday () in
-  let tm = Unix.gmtime time in
-  let msec = time -. floor time in
-  Printf.sprintf "%d%.2d%.2dT%.2d:%.2d:%.2d.%.3dZ|" (1900 + tm.Unix.tm_year)
-    (tm.Unix.tm_mon + 1) tm.Unix.tm_mday tm.Unix.tm_hour tm.Unix.tm_min
-    tm.Unix.tm_sec
-    (int_of_float (1000.0 *. msec))
+  let now = Ptime_clock.now () in
+  Fmt.str "%a|" Ptime.(pp_rfc3339 ~frac_s:3 ~tz_offset_s:0 ()) now
 
 (** [escape str] efficiently escapes non-printable characters and in addition
     the backslash character. The function is efficient in the sense that it will
@@ -216,20 +211,14 @@ let init_logs () =
      calling [output_log] too often. *)
   Logs.set_level (Some Logs.Warning)
 
-let rec split_c c str =
-  try
-    let i = String.index str c in
-    String.sub str 0 i
-    :: split_c c (String.sub str (i + 1) (String.length str - i - 1))
-  with Not_found -> [str]
-
 let log_backtrace_exn ?(level = Syslog.Err) ?(msg = "error") exn bt =
-  (* We already got the backtrace in the `bt` argument when called from with_thread_associated.
-     Log that, and remove `exn` from the backtraces table.
-     If with_backtraces was not nested then looking at `bt` is the only way to get
-     a proper backtrace, otherwise exiting from `with_backtraces` would've removed the backtrace
-     from the thread-local backtraces table, and we'd always just log a message complaining about
-     with_backtraces not being called, which is not true because it was.
+  (* We already got the backtrace in the `bt` argument when called from
+     with_thread_associated. Log that, and remove `exn` from the backtraces
+     table. If with_backtraces was not nested then looking at `bt` is the only
+     way to get a proper backtrace, otherwise exiting from `with_backtraces`
+     would've removed the backtrace from the thread-local backtraces table, and
+     we'd always just log a message complaining about with_backtraces not being
+     called, which is not true because it was.
   *)
   let bt' = Backtrace.remove exn in
   (* bt could be empty, but bt' would contain a non-empty warning, so compare 'bt' here *)
@@ -239,7 +228,7 @@ let log_backtrace_exn ?(level = Syslog.Err) ?(msg = "error") exn bt =
     else
       bt
   in
-  let all = split_c '\n' Backtrace.(to_string_hum bt) in
+  let all = String.split_on_char '\n' Backtrace.(to_string_hum bt) in
   (* Write to the log line at a time *)
   output_log "backtrace" level msg
     (Printf.sprintf "Raised %s" (Printexc.to_string exn)) ;
diff --git a/ocaml/libs/log/debug.mli b/ocaml/libs/log/debug.mli
@@ -31,9 +31,6 @@ val with_thread_named : string -> ('a -> 'b) -> 'a -> 'b
 
 module type BRAND = sig val name : string end
 
-val gettimestring : unit -> string
-(** The current time of day in a format suitable for logging *)
-
 val set_facility : Syslog.facility -> unit
 (** Set the syslog facility that will be used by this program. *)
 
diff --git a/ocaml/libs/log/dune b/ocaml/libs/log/dune
@@ -9,6 +9,8 @@
    fmt
    mtime
    logs
+   ptime
+   ptime.clock
    threads.posix
    xapi-backtrace
    unix
diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/listext.ml b/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/listext.ml
@@ -86,6 +86,20 @@ module List = struct
     in
     loop [] l
 
+  let try_map_collect f l =
+    let rec loop acc = function
+      | [] ->
+          Ok (List.rev acc)
+      | x :: xs -> (
+        match f x with
+        | Ok r ->
+            loop (r :: acc) xs
+        | Error e ->
+            Error (List.rev acc, e)
+      )
+    in
+    loop [] l
+
   let take n list =
     let rec loop i acc = function
       | x :: xs when i < n ->
diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/listext.mli b/ocaml/libs/xapi-stdext/lib/xapi-stdext-std/listext.mli
@@ -40,9 +40,15 @@ module List : sig
   (** [last l] returns the last element of [l] or None if [l] is empty *)
 
   val try_map : ('a -> ('b, 'c) result) -> 'a list -> ('b list, 'c) result
-  (** [try_map f l] applies [f] to all elements of [l] in turn. Returns the
-      first [Error] result encountered or, if no errors were produced, returns
-      all the [Ok] results. *)
+  (** [try_map f l] applies [f] to elements of [l] in turn. Returns the first
+      [Error] result encountered or, if no errors were produced, returns all
+      the [Ok] results. *)
+
+  val try_map_collect :
+    ('a -> ('b, 'c) result) -> 'a list -> ('b list, 'b list * 'c) result
+  (** [try_map_collect f l] applies [f] to elements of [l] in turn. Returns all
+      the [Ok] results, and the first [Error] result encountered, if it is
+      encountered. *)
 
   val rev_mapi : (int -> 'a -> 'b) -> 'a list -> 'b list
   (** [rev_map f l] gives the same result as {!Stdlib.List.rev}[ (]
diff --git a/ocaml/xapi-cli-server/cli_operations.ml b/ocaml/xapi-cli-server/cli_operations.ml
@@ -4839,56 +4839,73 @@ let vm_migrate printer rpc session_id params =
             (read_map_params "vgpu" params)
         in
         let preferred_sr =
-          (* The preferred SR is determined to be as the SR that the destine host has a PDB attached to it,
-             and among the choices of that the shared is preferred first(as it is recommended to have shared storage
-             in pool to host VMs), and then the one with the maximum available space *)
+          (* The preferred SR is determined to be as the SR that the
+             destination host has a PDB attached to it, and among the choices
+             of that the shared is preferred first (as it is recommended to
+             have shared storage in pool to host VMs), and then the one with
+             the maximum available space *)
           try
-            let expr =
-              Printf.sprintf
-                {|(field "host"="%s") and (field "currently_attached"="true")|}
-                (Ref.string_of host)
+            let host_attached_pbds =
+              let expr =
+                Printf.sprintf
+                  {|(field "host"="%s") and (field "currently_attached"="true")|}
+                  (Ref.string_of host)
+              in
+              remote Client.PBD.get_all_records_where ~expr
             in
-            let srs =
-              remote Client.PBD.get_all_where ~expr
-              |> List.map (fun pbd ->
-                  let sr = remote Client.PBD.get_SR ~self:pbd in
-                  (sr, remote Client.SR.get_record ~self:sr)
-              )
+            let shared_non_iso_srs () =
+              let expr =
+                {|(not (field "content_type"="iso")) and (field "shared"="true")|}
+              in
+              remote Client.SR.get_all_where ~expr
             in
-            (* In the following loop, the current SR:sr' will be compared with previous checked ones,
-               first if it is an ISO type, then pass this one for selection, then the only shared one from this and
-               previous one will be valued, and if not that case (both shared or none shared), choose the one with
-               more space available *)
-            let sr, _ =
-              List.fold_left
-                (fun (sr, free_space) ((_, sr_rec') as sr') ->
-                  if sr_rec'.API.sR_content_type = "iso" then
-                    (sr, free_space)
-                  else
-                    let free_space' =
-                      Int64.sub sr_rec'.API.sR_physical_size
-                        sr_rec'.API.sR_physical_utilisation
+            let local_non_iso_srs () =
+              let expr =
+                {|(not (field "content_type"="iso")) and (field "shared"="false")|}
+              in
+              remote Client.SR.get_all_where ~expr
+            in
+            let get_free_space_of non_iso_srs =
+              host_attached_pbds
+              |> List.filter_map (fun (_, pbd_rec) ->
+                  let sr = pbd_rec.API.pBD_SR in
+                  if List.mem sr non_iso_srs then
+                    let size = remote Client.SR.get_physical_size ~self:sr in
+                    let used =
+                      remote Client.SR.get_physical_utilisation ~self:sr
                     in
-                    match sr with
-                    | None ->
-                        (Some sr', free_space')
-                    | Some ((_, sr_rec) as sr) -> (
-                      match (sr_rec.API.sR_shared, sr_rec'.API.sR_shared) with
-                      | true, false ->
-                          (Some sr, free_space)
-                      | false, true ->
-                          (Some sr', free_space')
-                      | _ ->
-                          if free_space' > free_space then
-                            (Some sr', free_space')
-                          else
-                            (Some sr, free_space)
-                    )
-                )
-                (None, Int64.zero) srs
+                    Some (sr, Int64.sub size used)
+                  else
+                    None
+              )
             in
-            match sr with Some (sr_ref, _) -> Some sr_ref | _ -> None
-          with _ -> None
+            let find_most_free_space srs =
+              match
+                List.fast_sort
+                  (fun (_, a) (_, b) -> Int64.compare b a)
+                  (get_free_space_of srs)
+              with
+              | (sr, _) :: _ ->
+                  Some sr
+              | [] ->
+                  None
+            in
+            match find_most_free_space (shared_non_iso_srs ()) with
+            | Some sr ->
+                Some sr
+            | None ->
+                find_most_free_space (local_non_iso_srs ())
+          with exn ->
+            printer
+              (Cli_printer.PMsg
+                 (Printf.sprintf
+                    "Couldn't compute preferred SR, continuing with the \
+                     user-provided VDI mapping. The reason is: %s"
+                    (Printexc.to_string exn)
+                 )
+              ) ;
+
+            None
         in
         let vdi_map =
           match preferred_sr with
diff --git a/ocaml/xapi/dbsync_slave.ml b/ocaml/xapi/dbsync_slave.ml
@@ -52,14 +52,21 @@ let create_localhost ~__context info =
   in
   (* me = None on firstboot only *)
   if me = None then
+    (* Restore the host.last_update_hash when this is an ejected host. *)
+    let last_update_hash =
+      let k = "last_update_hash" in
+      let x = Localdb.get k |> Option.value ~default:"" in
+      (try Localdb.del k with _ -> ()) ;
+      x
+    in
     let (_ : API.ref_host) =
       Xapi_host.create ~__context ~uuid:info.uuid ~name_label:info.hostname
         ~name_description:"" ~hostname:info.hostname ~address:ip
         ~external_auth_type:"" ~external_auth_service_name:""
         ~external_auth_configuration:[] ~license_params:[] ~edition:""
         ~license_server:[("address", "localhost"); ("port", "27000")]
         ~local_cache_sr:Ref.null ~chipset_info:[] ~ssl_legacy:false
-        ~last_software_update:Date.epoch ~last_update_hash:""
+        ~last_software_update:Date.epoch ~last_update_hash
         ~ssh_enabled:Constants.default_ssh_enabled
         ~ssh_enabled_timeout:Constants.default_ssh_enabled_timeout
         ~ssh_expiry:Date.epoch
diff --git a/ocaml/xapi/helpers.ml b/ocaml/xapi/helpers.ml
@@ -126,6 +126,10 @@ let call_script ?(log_output = Always) ?env ?stdin ?timeout script args =
           (String.concat " " (filter_args args))
           message stdout stderr ;
       raise e
+  | e ->
+      debug "%s: unexpected exception raised: %s" __FUNCTION__
+        (ExnHelper.string_of_exn e) ;
+      raise e
 
 (** Construct a descriptive network name (used as name_label) for a give network interface. *)
 let choose_network_name_for_pif device = function
diff --git a/ocaml/xapi/import.ml b/ocaml/xapi/import.ml
@@ -2073,57 +2073,37 @@ let handlers =
   ; (Datamodel_common._vtpm, VTPMHandler.handle)
   ]
 
-(* If snapshot_of(x) = y, and both x and y are freshly imported VDIs,
-   the field must be rewritten to a real database reference. The same
-   relationship formed by parental links must be preserved as well.
-
-   We can't do this on-the-fly during an import because we can't
-   guarantee that the VDIs will be imported in reverse topological
-   order of the relation induced by snapshot_of. *)
-let update_vdi_links ~__context state =
-  (* Map an exported reference to a (freshly) imported reference, or
-     null if it's not present in the import. *)
-  let resolve_import =
-    let tbl = Hashtbl.create 16 in
-    let go (_, a, b) = Hashtbl.replace tbl a (Ref.of_string b) in
-    List.iter go state.table ;
-    fun r ->
-      Hashtbl.find_opt tbl (Ref.string_of r) |> Option.value ~default:Ref.null
-  in
-  let update x =
-    let x_r = Db.VDI.get_record ~__context ~self:x in
-    let parent = resolve_import x_r.API.vDI_parent in
-    let snapshot_of = resolve_import x_r.API.vDI_snapshot_of in
-    Db.VDI.set_parent ~__context ~self:x ~value:parent ;
-    Db.VDI.set_snapshot_of ~__context ~self:x ~value:snapshot_of ;
-    Db.VDI.set_is_a_snapshot ~__context ~self:x ~value:(snapshot_of <> Ref.null)
-  in
-  let go (cls, _, r) =
-    if cls = Datamodel_common._vdi then update (Ref.of_string r)
-  in
-  List.iter go state.table
-
-(* Same as [update_vdi_links] but over VMs instead. *)
-let update_vm_links ~__context state =
-  let resolve_import =
-    let tbl = Hashtbl.create 16 in
-    let go (_, a, b) = Hashtbl.replace tbl a (Ref.of_string b) in
-    List.iter go state.table ;
-    fun r ->
-      Hashtbl.find_opt tbl (Ref.string_of r) |> Option.value ~default:Ref.null
-  in
-  let update x =
-    let x_r = Db.VM.get_record ~__context ~self:x in
-    let parent = resolve_import x_r.API.vM_parent in
-    let snapshot_of = resolve_import x_r.API.vM_snapshot_of in
-    Db.VM.set_parent ~__context ~self:x ~value:parent ;
-    Db.VM.set_snapshot_of ~__context ~self:x ~value:snapshot_of ;
-    Db.VM.set_is_a_snapshot ~__context ~self:x ~value:(snapshot_of <> Ref.null)
-  in
-  let go (cls, _, r) =
-    if cls = Datamodel_common._vm then update (Ref.of_string r)
+let update_snapshot_and_parent_links ~__context state =
+  let aux (cls, _, ref) =
+    let ref = Ref.of_string ref in
+    ( if
+        cls = Datamodel_common._vm
+        && Db.VM.get_is_a_snapshot ~__context ~self:ref
+      then
+        let snapshot_of = Db.VM.get_snapshot_of ~__context ~self:ref in
+        if snapshot_of <> Ref.null then (
+          debug "lookup for snapshot_of = '%s'" (Ref.string_of snapshot_of) ;
+          log_reraise
+            ("Failed to find the VM which is snapshot of "
+            ^ Db.VM.get_name_label ~__context ~self:ref
+            )
+            (fun table ->
+              let snapshot_of = (lookup snapshot_of) table in
+              Db.VM.set_snapshot_of ~__context ~self:ref ~value:snapshot_of
+            )
+            state.table
+        )
+    ) ;
+    if cls = Datamodel_common._vm then (
+      let parent = Db.VM.get_parent ~__context ~self:ref in
+      debug "lookup for parent = '%s'" (Ref.string_of parent) ;
+      try
+        let parent = lookup parent state.table in
+        Db.VM.set_parent ~__context ~self:ref ~value:parent
+      with _ -> debug "no parent found"
+    )
   in
-  List.iter go state.table
+  List.iter aux state.table
 
 let check_references ~__context (table : table) =
   let is_export_reference r =
@@ -2171,8 +2151,7 @@ let handle_all __context config rpc session_id (xs : obj list) =
           false
     in
     if not dry_run then (
-      update_vm_links ~__context state ;
-      update_vdi_links ~__context state ;
+      update_snapshot_and_parent_links ~__context state ;
       check_references ~__context state.table
     ) ;
     state
diff --git a/ocaml/xapi/static_vdis.ml b/ocaml/xapi/static_vdis.ml
diff --git a/ocaml/xapi/xapi_ha.ml b/ocaml/xapi/xapi_ha.ml
diff --git a/ocaml/xapi/xapi_pool.ml b/ocaml/xapi/xapi_pool.ml
diff --git a/ocaml/xapi/xapi_xenops.ml b/ocaml/xapi/xapi_xenops.ml
