Sync master to feature branch (#6948)

Author: liulinC

ocaml/forkexecd/lib/fe_stubs.c

@@ -20,6 +20,8 @@
 #include <limits.h>
 #include <sys/wait.h>
 
+#include <caml/mlvalues.h>
+#include <caml/threads.h>
 #include <caml/fail.h>
 #include <caml/memory.h>
 #include <caml/unixsupport.h>
@@ -213,15 +215,15 @@ caml_safe_exec_with_helper(value args, value environment)
     }
 
     // potentially slow section, release Ocaml engine
-    caml_enter_blocking_section();
+    caml_release_runtime_system();
 
     safe_exec_result res;
     int err = safe_exec_with_helper(&res, c_args, c_envs);
 
     free(c_envs);
     free(c_args);
 
-    caml_leave_blocking_section();
+    caml_acquire_runtime_system();
 
     // error, notify with an exception
     if (err != 0)
@@ -395,7 +397,7 @@ caml_pidwaiter_waitpid(value timeout_value, value pid_value)
     double timeout = timeout_value == Val_none ? 0 : Double_val(Some_val(timeout_value));
     pid_t pid = Int_val(pid_value);
 
-    caml_enter_blocking_section();
+    caml_release_runtime_system();
 
     bool timed_out = false;
     int err = 0;
@@ -407,7 +409,7 @@ caml_pidwaiter_waitpid(value timeout_value, value pid_value)
             timed_out = true;
     }
 
-    caml_leave_blocking_section();
+    caml_acquire_runtime_system();
 
     if (err)
         unix_error(err, "waitpid", Nothing);

ocaml/idl/datamodel_lifecycle.ml

@@ -234,7 +234,7 @@ let prototyped_of_message = function
   | "PCI", "disable_dom0_access" ->
       Some "24.14.0"
   | "message", "destroy_all" ->
-      Some "26.5.0-next"
+      Some "26.6.0"
   | "message", "destroy_many" ->
       Some "22.19.0"
   | "VTPM", "set_contents" ->

ocaml/idl/ocaml_backend/dune

@@ -4,6 +4,8 @@
   (libraries
     astring
     cmdliner
+    fmt
+    ptime.clock
     uuidm
     xapi-consts
     xapi-datamodel

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

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)) ;

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. *)
 

ocaml/libs/log/dune

@@ -9,6 +9,8 @@
    fmt
    mtime
    logs
+   ptime
+   ptime.clock
    threads.posix
    xapi-backtrace
    unix

ocaml/libs/vhd/vhd_format_lwt/odirect_stubs.c

@@ -36,7 +36,7 @@ CAMLprim value stub_openfile_direct(value filename, value rw, value perm){
 
   const char *filename_c = strdup(String_val(filename));
 
-  caml_release_runtime_system();
+  int perm_c = Int_val(perm);
   int flags = 0;
 #if defined(O_DIRECT)
   flags |= O_DIRECT;
@@ -46,7 +46,8 @@ CAMLprim value stub_openfile_direct(value filename, value rw, value perm){
   } else {
     flags |= O_RDONLY;
   }
-  fd = open(filename_c, flags, Int_val(perm));
+  caml_release_runtime_system();
+  fd = open(filename_c, flags, perm_c);
   caml_acquire_runtime_system();
 
   free((void*)filename_c);

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 ->

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}[ (]