Sync master into feature/host-network-device-order (#6674)

Author: changlei-li

doc/content/xapi/guides/howtos/add-function.md

@@ -172,8 +172,8 @@ the Host module:
     let price_of ~__context ~host ~item =
         info "Host.price_of for item %s" item;
         let local_fn = Local.Host.price_of ~host ~item in
-        do_op_on ~local_fn ~__context ~host
-          (fun session_id rpc -> Client.Host.price_of ~rpc ~session_id ~host ~item)
+        let remote_fn = Client.Host.price_of ~host ~item in
+        do_op_on ~local_fn ~__context ~host ~remote_fn
 
 After the ~__context parameter, the parameters of this new function should
 match the parameters we specified for the message. In this case, that is the

ocaml/database/db_cache_impl.ml

@@ -67,9 +67,7 @@ let read_field t tblname fldname objref =
     occurs. *)
 let ensure_utf8_xml string =
   let length = String.length string in
-  let prefix =
-    Xapi_stdext_encodings.Encodings.UTF8_XML.longest_valid_prefix string
-  in
+  let prefix = Xapi_stdext_encodings.Utf8.XML.longest_valid_prefix string in
   if length > String.length prefix then
     warn "string truncated to: '%s'." prefix ;
   prefix
@@ -86,20 +84,32 @@ let write_field_locked t tblname objref fldname newval =
       (get_database t)
   )
 
+(** Ensure a value is conforming to UTF-8 with XML restrictions *)
+let is_valid v =
+  let valid = Xapi_stdext_encodings.Utf8.XML.is_valid in
+  let valid_pair (x, y) = valid x && valid y in
+  match v with
+  | Schema.Value.String s ->
+      valid s
+  | Schema.Value.Set ss ->
+      List.for_all valid ss
+  | Schema.Value.Pairs pairs ->
+      List.for_all valid_pair pairs
+
+let share_string = function
+  | Schema.Value.String s ->
+      Schema.Value.String (Share.merge s)
+  | v ->
+      (* we assume strings in the tree have been shared already *)
+      v
+
 let write_field t tblname objref fldname newval =
-  let newval =
-    match newval with
-    | Schema.Value.String s ->
-        (* the other caller of write_field_locked only uses sets and maps,
-           so we only need to check for String here
-        *)
-        if not (Xapi_stdext_encodings.Encodings.UTF8_XML.is_valid s) then
-          raise Invalid_value ;
-        Schema.Value.String (Share.merge s)
-    | _ ->
-        newval
-  in
-  with_lock (fun () -> write_field_locked t tblname objref fldname newval)
+  if not @@ is_valid newval then
+    raise Invalid_value
+  else
+    with_lock (fun () ->
+        write_field_locked t tblname objref fldname (share_string newval)
+    )
 
 let touch_row t tblname objref =
   update_database t (touch tblname objref) ;

ocaml/database/string_marshall_helper.ml

@@ -22,9 +22,7 @@ module D = Debug.Make (struct let name = __MODULE__ end)
 
 let ensure_utf8_xml string =
   let length = String.length string in
-  let prefix =
-    Xapi_stdext_encodings.Encodings.UTF8_XML.longest_valid_prefix string
-  in
+  let prefix = Xapi_stdext_encodings.Utf8.XML.longest_valid_prefix string in
   if length > String.length prefix then
     D.warn "Whilst doing 'set' of structured field, string truncated to: '%s'."
       prefix ;

ocaml/idl/datamodel_common.ml

@@ -10,7 +10,7 @@ open Datamodel_roles
               to leave a gap for potential hotfixes needing to increment the schema version.*)
 let schema_major_vsn = 5
 
-let schema_minor_vsn = 789
+let schema_minor_vsn = 790
 
 (* Historical schema versions just in case this is useful later *)
 let rio_schema_major_vsn = 5

ocaml/idl/datamodel_errors.ml

@@ -648,6 +648,11 @@ let _ =
       "The specified server is disabled and cannot be re-enabled until after \
        it has rebooted."
     () ;
+  error Api_errors.host_disabled_indefinitely ["host"]
+    ~doc:
+      "The specified server is disabled and can only be re-enabled manually \
+       with Host.enable."
+    () ;
   error Api_errors.no_hosts_available []
     ~doc:"There were no servers available to complete the specified operation."
     () ;

ocaml/idl/datamodel_host.ml

@@ -625,12 +625,37 @@ let disable =
         , "Puts the host into a state in which no new VMs can be started. \
            Currently active VMs on the host continue to execute."
         )
+      ; ( Changed
+        , "25.31.0"
+        , "Added auto_enable option to allow persisting the state across \
+           toolstack restarts and host reboots."
+        )
       ]
     ~name:"disable"
     ~doc:
       "Puts the host into a state in which no new VMs can be started. \
        Currently active VMs on the host continue to execute."
-    ~params:[(Ref _host, "host", "The Host to disable")]
+    ~versioned_params:
+      [
+        {
+          param_type= Ref _host
+        ; param_name= "host"
+        ; param_doc= "The Host to disable"
+        ; param_release= rio_release
+        ; param_default= None
+        }
+      ; {
+          param_type= Bool
+        ; param_name= "auto_enable"
+        ; param_doc=
+            "If true (default), the host will be re-enabled after a toolstack \
+             restart automatically. If false, the host will be disabled \
+             indefinitely, across toolstack restarts and host reboots, until \
+             re-enabled explicitly with Host.enable."
+        ; param_release= numbered_release "25.31.0"
+        ; param_default= Some (VBool true)
+        }
+      ]
     ~allowed_roles:(_R_POOL_OP ++ _R_CLIENT_CERT)
     ()
 

ocaml/idl/ocaml_backend/gen_server.ml

@@ -457,7 +457,7 @@ let gen_module api : O.Module.t =
                ([
                   "let __call, __params = call.Rpc.name, call.Rpc.params in"
                 ; "List.iter (fun p -> let s = Rpc.to_string p in if not \
-                   (Xapi_stdext_encodings.Encodings.UTF8_XML.is_valid s) then"
+                   (Xapi_stdext_encodings.Utf8.is_valid s) then"
                 ; "raise (Api_errors.Server_error(Api_errors.invalid_value, \
                    [\"Invalid UTF-8 string in parameter\"; s])))  __params;"
                 ; "let __label = __call in"

ocaml/libs/tracing/tracing.ml

@@ -222,6 +222,8 @@ module TraceContext = struct
 
   let empty = {traceparent= None; baggage= None}
 
+  let depth_key = "span.depth"
+
   let with_traceparent traceparent ctx = {ctx with traceparent}
 
   let with_baggage baggage ctx = {ctx with baggage}
@@ -230,6 +232,20 @@ module TraceContext = struct
 
   let baggage_of ctx = ctx.baggage
 
+  let baggage_depth_of ctx =
+    Option.bind (baggage_of ctx) (List.assoc_opt depth_key)
+    |> Option.value ~default:"1"
+    |> int_of_string
+
+  let update_with_baggage k v ctx =
+    let new_baggage =
+      baggage_of ctx
+      |> Option.value ~default:[]
+      |> List.remove_assoc k
+      |> List.cons (k, v)
+    in
+    with_baggage (Some new_baggage) ctx
+
   let parse input =
     let open Astring.String in
     let trim_pair (key, value) = (trim key, trim value) in
@@ -322,22 +338,36 @@ module Span = struct
 
   let start ?(attributes = Attributes.empty)
       ?(trace_context : TraceContext.t option) ~name ~parent ~span_kind () =
-    let trace_id, extra_context =
+    let trace_id, extra_context, depth =
       match parent with
       | None ->
-          (Trace_id.make (), TraceContext.empty)
+          (Trace_id.make (), TraceContext.empty, 1)
       | Some span_parent ->
-          (span_parent.context.trace_id, span_parent.context.trace_context)
+          ( span_parent.context.trace_id
+          , span_parent.context.trace_context
+          , TraceContext.baggage_depth_of span_parent.context.trace_context + 1
+          )
     in
     let span_id = Span_id.make () in
+    let extra_context_with_depth =
+      TraceContext.(
+        update_with_baggage depth_key (string_of_int depth) extra_context
+      )
+    in
     let context : SpanContext.t =
-      {trace_id; span_id; trace_context= extra_context}
+      {trace_id; span_id; trace_context= extra_context_with_depth}
     in
     let context =
-      (* If trace_context is provided to the call, override any inherited trace context. *)
-      trace_context
-      |> Option.fold ~none:context
-           ~some:(Fun.flip SpanContext.with_trace_context context)
+      (* If trace_context is provided to the call, override any inherited trace
+         context except span.depth which should still be maintained. *)
+      match trace_context with
+      | Some tc ->
+          let tc_with_depth =
+            TraceContext.(update_with_baggage depth_key (string_of_int depth) tc)
+          in
+          SpanContext.with_trace_context tc_with_depth context
+      | None ->
+          context
     in
     (* Using gettimeofday over Mtime as it is better for sharing timestamps between the systems *)
     let begin_time = Unix.gettimeofday () in
@@ -473,6 +503,11 @@ module Spans = struct
 
   let set_max_traces x = Atomic.set max_traces x
 
+  (* Default is much larger than the largest current traces, so effectively off *)
+  let max_depth = Atomic.make 100
+
+  let set_max_depth x = Atomic.set max_depth x
+
   let finished_spans = Atomic.make ([], 0)
 
   let span_hashtbl_is_empty () = TraceMap.is_empty (Atomic.get spans)
@@ -713,12 +748,18 @@ module Tracer = struct
   let get_tracer ~name:_ = TracerProvider.get_current ()
 
   let span_of_span_context context name : Span.t =
+    let tc = SpanContext.context_of_span_context context in
+    let new_depth = TraceContext.baggage_depth_of tc in
+    let new_tc =
+      TraceContext.(update_with_baggage depth_key (string_of_int new_depth) tc)
+    in
+    let context = SpanContext.with_trace_context new_tc context in
     {
       context
     ; status= {status_code= Status.Unset; _description= None}
     ; name
     ; parent= None
-    ; span_kind= SpanKind.Client (* This will be the span of the client call*)
+    ; span_kind= SpanKind.Client (* This will be the span of the client call *)
     ; begin_time= Unix.gettimeofday ()
     ; end_time= None
     ; links= []
@@ -730,10 +771,32 @@ module Tracer = struct
       ?(span_kind = SpanKind.Internal) ~name ~parent () :
       (Span.t option, exn) result =
     let open TracerProvider in
-    (* Do not start span if the TracerProvider is disabled*)
+    let parent_depth =
+      Option.fold ~none:1
+        ~some:(fun parent ->
+          parent.Span.context
+          |> SpanContext.context_of_span_context
+          |> TraceContext.baggage_depth_of
+        )
+        parent
+    in
+    (* Do not start span if the TracerProvider is disabled *)
     if not t.enabled then
+      ok_none (* Do not start span if the max depth has been reached *)
+    else if parent_depth >= Atomic.get Spans.max_depth then (
+      let parent_trace_id =
+        Option.fold ~none:"None"
+          ~some:(fun p ->
+            p.Span.context
+            |> SpanContext.span_id_of_span_context
+            |> Span_id.to_string
+          )
+          parent
+      in
+      debug "Max_span_depth limit reached, not creating span %s (parent %s)"
+        name parent_trace_id ;
       ok_none
-    else
+    ) else
       let attributes = Attributes.merge_into t.attributes attributes in
       let span =
         Span.start ~attributes ?trace_context ~name ~parent ~span_kind ()
@@ -750,16 +813,24 @@ module Tracer = struct
           |> Spans.remove_from_spans
           |> Option.map (fun existing_span ->
                  let old_context = Span.get_context existing_span in
+                 let parent_trace_context = Span.get_trace_context parent in
+                 let new_depth =
+                   TraceContext.baggage_depth_of parent_trace_context + 1
+                 in
                  let new_context : SpanContext.t =
-                   let trace_context = span.Span.context.trace_context in
+                   let trace_context =
+                     TraceContext.(
+                       update_with_baggage depth_key (string_of_int new_depth)
+                         span.Span.context.trace_context
+                     )
+                   in
                    SpanContext.context
                      (SpanContext.trace_id_of_span_context parent.context)
                      old_context.span_id
                    |> SpanContext.with_trace_context trace_context
                  in
                  let updated_span = {existing_span with parent= Some parent} in
                  let updated_span = {updated_span with context= new_context} in
-
                  let () = Spans.add_to_spans ~span:updated_span in
                  updated_span
              )
@@ -926,7 +997,15 @@ module Propagator = struct
             let trace_context' =
               TraceContext.with_traceparent (Some traceparent) trace_context
             in
-            let carrier' = P.inject_into trace_context' carrier in
+            let new_depth =
+              TraceContext.baggage_depth_of trace_context' + 1 |> string_of_int
+            in
+            let trace_context'' =
+              TraceContext.(
+                update_with_baggage depth_key new_depth trace_context'
+              )
+            in
+            let carrier' = P.inject_into trace_context'' carrier in
             f carrier'
         | _ ->
             f carrier

ocaml/libs/tracing/tracing.mli

@@ -165,6 +165,8 @@ module Spans : sig
 
   val set_max_traces : int -> unit
 
+  val set_max_depth : int -> unit
+
   val span_count : unit -> int
 
   val since : unit -> Span.t list * int

ocaml/libs/tracing/tracing_export.ml

@@ -24,6 +24,10 @@ let export_interval = ref 30.
 
 let set_export_interval t = export_interval := t
 
+let export_chunk_size = Atomic.make 10000
+
+let set_export_chunk_size x = Atomic.set export_chunk_size x
+
 let host_id = ref "localhost"
 
 let set_host_id id = host_id := id
@@ -289,17 +293,40 @@ module Destination = struct
     with exn ->
       debug "Tracing: unable to export span : %s" (Printexc.to_string exn)
 
+  let rec span_info_chunks span_info batch_size =
+    let rec list_to_chunks_inner l n curr chunks =
+      if n = 0 then
+        if l <> [] then
+          list_to_chunks_inner l batch_size [] ((curr, batch_size) :: chunks)
+        else
+          (curr, batch_size) :: chunks
+      else
+        match l with
+        | [] ->
+            (curr, List.length curr) :: chunks
+        | h :: t ->
+            list_to_chunks_inner t (n - 1) (h :: curr) chunks
+    in
+    list_to_chunks_inner (fst span_info) batch_size [] []
+
   let flush_spans () =
     let ((_span_list, span_count) as span_info) = Spans.since () in
     let attributes = [("export.traces.count", string_of_int span_count)] in
     let@ parent =
       with_tracing ~span_kind:Server ~trace_context:TraceContext.empty
         ~parent:None ~attributes ~name:"Tracing.flush_spans"
     in
-    TracerProvider.get_tracer_providers ()
-    |> List.filter TracerProvider.get_enabled
-    |> List.concat_map TracerProvider.get_endpoints
-    |> List.iter (export_to_endpoint parent span_info)
+    let endpoints =
+      TracerProvider.get_tracer_providers ()
+      |> List.filter TracerProvider.get_enabled
+      |> List.concat_map TracerProvider.get_endpoints
+    in
+    let span_info_chunks =
+      span_info_chunks span_info (Atomic.get export_chunk_size)
+    in
+    List.iter
+      (fun s_i -> List.iter (export_to_endpoint parent s_i) endpoints)
+      span_info_chunks
 
   let delay = Delay.make ()