CP-311148/CP-311150: add a quicktest for XAPI memory overhead calculations

ocaml/idl/ocaml_backend/gen_client.ml

@@ -319,6 +319,12 @@ let gen_module api : O.Module.t =
     ; "    | Rpc.Enum ((Rpc.String code) :: args) -> return (server_failure \
        code (List.map Rpc.string_of_rpc args))"
     ; "    | rpc -> failwith (\"Client.rpc: \" ^ Rpc.to_string rpc)"
+    ; "type client = {rpc: Rpc.call -> Rpc.response; session_id:  ref_session}"
+    ; "type 'a api = rpc:(Rpc.call -> Rpc.response) -> session_id:ref_session \
+       -> 'a"
+    ; ""
+    ; "let call {rpc; session_id} f = f ~rpc ~session_id"
+    ; ""
     ]
   in
   let postamble =

ocaml/libs/log/debug.ml

@@ -82,6 +82,14 @@ let gettimestring () =
     allocate a new string only when necessary *)
 let escape = Astring.String.Ascii.escape
 
+let remote_context = Ambient_context_thread_local.Thread_local.create ()
+
+let set_remote_context = function
+  | None ->
+      Ambient_context_thread_local.Thread_local.remove remote_context
+  | Some context ->
+      Ambient_context_thread_local.Thread_local.set remote_context context
+
 let format include_time brand priority message =
   let id = get_thread_id () in
   let task, name =
@@ -97,13 +105,17 @@ let format include_time brand priority message =
     | Some {desc; client= Some client} ->
         (desc, Printf.sprintf "%s->%s" client name)
   in
-  Printf.sprintf "[%s%5s||%d %s|%s|%s] %s"
+  let remote_context =
+    Ambient_context_thread_local.Thread_local.get remote_context
+    |> Option.value ~default:""
+  in
+  Printf.sprintf "[%s%5s|%s|%d %s|%s|%s] %s"
     ( if include_time then
         gettimestring ()
       else
         ""
     )
-    priority id name task brand message
+    priority remote_context id name task brand message
 
 let print_debug = ref false
 

ocaml/libs/log/debug.mli

@@ -29,6 +29,9 @@ val with_thread_associated :
 val with_thread_named : string -> ('a -> 'b) -> 'a -> 'b
 (** Do an action with a name associated with the current thread *)
 
+val set_remote_context : string option -> unit
+(** [set_remote_context context] sets the remote context, will be logged as the 2nd field *)
+
 module type BRAND = sig val name : string end
 
 val set_facility : Syslog.facility -> unit

ocaml/libs/log/dune

@@ -5,6 +5,7 @@
    (language c)
    (names syslog_stubs))
  (libraries
+   ambient-context.thread_local
    astring
    fmt
    mtime

ocaml/libs/tracing/tracing.ml

@@ -336,6 +336,9 @@ module Span = struct
 
   let get_trace_context t = t.context |> SpanContext.context_of_span_context
 
+  let[@inline always] set_trace_context trace_context =
+    trace_context |> TraceContext.traceparent_of |> Debug.set_remote_context
+
   let start ?(attributes = Attributes.empty)
       ?(trace_context : TraceContext.t option) ~name ~parent ~span_kind () =
     let trace_id, extra_context, depth =
@@ -348,6 +351,7 @@ module Span = struct
           , TraceContext.baggage_depth_of span_parent.context.trace_context + 1
           )
     in
+    set_trace_context extra_context ;
     let span_id = Span_id.make () in
     let extra_context_with_depth =
       TraceContext.(
@@ -405,7 +409,15 @@ module Span = struct
   let get_attributes span =
     Attributes.fold (fun k v tags -> (k, v) :: tags) span.attributes []
 
+  let[@inline always] traceparent_of_parent parent =
+    parent |> get_context |> SpanContext.to_traceparent
+
   let finish ?(attributes = Attributes.empty) ~span () =
+    (* Unfold the stack: set parent's traceparent if any.
+       If at top level then remove the trace context.
+       This ensures we don't have a stale trace context set.
+     *)
+    span.parent |> Option.map traceparent_of_parent |> Debug.set_remote_context ;
     let attributes =
       Attributes.union (fun _k a _b -> Some a) attributes span.attributes
     in

ocaml/quicktest/dune

@@ -9,10 +9,15 @@
     ezxenstore
     ezxenstore.watch
     fmt
+    fmt.tty
     forkexec
     http_lib
     mtime
     mtime.clock.os
+    cli_progress_bar
+    quicktest_trace
+    quicktest_trace_api
+    quicktest_trace_rpc
     pam
     qcheck-alcotest
     result
@@ -25,6 +30,7 @@
     threads.posix
     unix
     uuid
+    backtrace
     xapi-client
     xapi-consts
     xapi-datamodel

ocaml/quicktest/qt.ml

@@ -5,6 +5,7 @@ type sr_info = {
   ; allowed_operations: API.storage_operations_set
   ; capabilities: string list
   ; required_sm_api_version: string
+  ; is_iso: bool
 }
 
 let init_session rpc username password =
@@ -152,16 +153,29 @@ module VM = struct
       cmd @ Option.fold ~none:[] ~some:(fun x -> ["sr-uuid=" ^ x]) sr_uuid
     in
     let newvm_uuid = cli_cmd cmd in
-    Client.Client.VM.get_by_uuid ~rpc ~session_id ~uuid:newvm_uuid
+    (newvm_uuid, Client.Client.VM.get_by_uuid ~rpc ~session_id ~uuid:newvm_uuid)
 
   let uninstall rpc session_id vm =
     let uuid = Client.Client.VM.get_uuid ~rpc ~session_id ~self:vm in
     cli_cmd ["vm-uninstall"; "uuid=" ^ uuid; "--force"] |> ignore
 
-  let with_new rpc session_id ~template ?sr f =
-    let vm =
+  let with_new rpc session_id ~template ?iso ?sr f =
+    let uuid, vm =
       install rpc session_id ~template ~name:"temp_quicktest_vm" ?sr ()
     in
+    iso
+    |> Option.iter (fun iso ->
+        let (_ : string) =
+          cli_cmd
+            [
+              "vm-cd-add"
+            ; "uuid=" ^ uuid
+            ; "cd-name=" ^ iso.API.vDI_name_label
+            ; "device=0"
+            ]
+        in
+        ()
+    ) ;
     Xapi_stdext_pervasives.Pervasiveext.finally
       (fun () -> f vm)
       (fun () -> uninstall rpc session_id vm)

ocaml/quicktest/qt.mli

@@ -9,6 +9,7 @@ type sr_info = {
   ; allowed_operations: API.storage_operations_set
   ; capabilities: string list
   ; required_sm_api_version: string
+  ; is_iso: bool
 }
 
 val init_session : rpc -> string -> string -> API.ref_session
@@ -53,6 +54,7 @@ module VM : sig
        rpc
     -> API.ref_session
     -> template:API.ref_VM
+    -> ?iso:API.vDI_t
     -> ?sr:API.ref_SR
     -> (API.ref_VM -> 'a)
     -> 'a

ocaml/quicktest/qt_filter.ml

@@ -104,16 +104,16 @@ module SR = struct
       (* Even though the SM backend may expose a VDI_CREATE capability attempts
          to actually create a VDI will fail in (eg) the tools SR and any that
          happen to be R/O NFS exports *)
+      let is_iso_sr =
+        Client.Client.SR.get_content_type ~rpc ~session_id ~self:sr = "iso"
+      in
       let avoid_vdi_create session_id sr =
         let other_config =
           Client.Client.SR.get_other_config ~rpc ~session_id ~self:sr
         in
         let is_tools_sr =
           Client.Client.SR.get_is_tools_sr ~rpc ~session_id ~self:sr
         in
-        let is_iso_sr =
-          Client.Client.SR.get_content_type ~rpc ~session_id ~self:sr = "iso"
-        in
         let special_key = "quicktest-no-VDI_CREATE" in
         let is_marked =
           List.mem_assoc special_key other_config
@@ -155,13 +155,13 @@ module SR = struct
         else
           ops
       in
-      (ops, caps, sm.API.sM_required_api_version)
+      (ops, caps, sm.API.sM_required_api_version, is_iso_sr)
     in
-    let allowed_operations, capabilities, required_sm_api_version =
+    let allowed_operations, capabilities, required_sm_api_version, is_iso =
       get_sr_features session_id sr
     in
     let open Qt in
-    {sr; allowed_operations; capabilities; required_sm_api_version}
+    {sr; allowed_operations; capabilities; required_sm_api_version; is_iso}
 
   let list_srs_connected_to_localhost rpc session_id =
     let is_attached =
@@ -234,13 +234,29 @@ module SR = struct
 
   let sr_filter f srs () = List.filter f (srs ())
 
+  let iso_srs () =
+    with_xapi_query @@ fun () ->
+    Lazy.force all_srs
+    |> List.filter (fun sr_info ->
+        Client.Client.SR.get_content_type ~rpc:!A.rpc ~session_id:!session_id
+          ~self:sr_info.Qt.sr
+        = "iso"
+    )
+
   let not_iso =
     sr_filter (fun sr_info ->
         Client.Client.SR.get_content_type ~rpc:!A.rpc ~session_id:!session_id
           ~self:sr_info.Qt.sr
         <> "iso"
     )
 
+  let is_iso =
+    sr_filter (fun sr_info ->
+        Client.Client.SR.get_content_type ~rpc:!A.rpc ~session_id:!session_id
+          ~self:sr_info.Qt.sr
+        = "iso"
+    )
+
   let is_empty = function [] -> true | _ :: _ -> false
 
   let with_any_vdi =
@@ -346,3 +362,33 @@ let vm_template template_name =
       | Some vm_template ->
           [(name, speed, test vm_template)]
   )
+
+let find_memtest_iso ~prefix srs =
+  with_xapi_query @@ fun () ->
+  let isos =
+    srs
+    |> List.concat_map @@ fun iso_info ->
+       let expr =
+         Printf.sprintf {|field "SR" = "%s"|} (Ref.string_of iso_info.Qt.sr)
+       in
+       Client.Client.VDI.get_all_records_where ~rpc:!A.rpc
+         ~session_id:!session_id ~expr
+       |> List.filter (fun (_, iso) ->
+           String.starts_with ~prefix iso.API.vDI_name_label
+       )
+  in
+  isos
+  |> List.sort (fun (_, a) (_, b) ->
+      -String.compare a.API.vDI_name_label b.API.vDI_name_label
+  )
+
+let memtest_iso ?(prefix = "memtest") tcs =
+  let isos = find_memtest_iso ~prefix (SR.iso_srs ()) in
+  tcs
+  |> for_each @@ fun (name, speed, test) ->
+     match isos with
+     | [] ->
+         []
+     | (_, iso) :: _ ->
+         Printf.eprintf "Choosing ISO %S\n%!" iso.API.vDI_name_label ;
+         [(name, speed, test iso)]

ocaml/quicktest/qt_filter.mli

@@ -49,8 +49,12 @@ module SR : sig
 
   val random : srs -> srs
 
+  val iso_srs : srs
+
   val not_iso : srs -> srs
 
+  val is_iso : srs -> srs
+
   val with_any_vdi : srs -> srs
   (** Selects SRs that either have a VDI or we can create & destroy a VDI on them.
       This filter should be called from tests using [VDI.with_any] *)
@@ -86,3 +90,5 @@ end
 val sr : SR.srs -> (Qt.sr_info -> 'b, 'b) filter
 
 val vm_template : string -> (API.ref_VM -> 'b, 'b) filter
+
+val memtest_iso : ?prefix:string -> (API.vDI_t -> 'a, 'a) filter

ocaml/quicktest/quicktest.ml

@@ -19,12 +19,45 @@ let qchecks =
   |> List.map @@ fun (name, test) ->
      (name, List.map QCheck_alcotest.(to_alcotest ~long:true) test)
 
+let setup_tty () =
+  let style_renderer =
+    if !Quicktest_args.use_colour then
+      (* use default style, auto-detect color support *)
+      None
+    else
+      (* never use color *)
+      Some `None
+  in
+  Fmt_tty.setup_std_outputs ?style_renderer ()
+
+let wrap f =
+  setup_tty () ;
+  let open Quicktest_trace in
+  Opentelemetry.Globals.service_name := "quicktest" ;
+  TeeBackend.with_default_setup () @@ fun () ->
+  Sys.catch_break true ;
+  () |> Debug.with_thread_associated "quicktest" @@ fun () -> Qt_filter.wrap f
+
 let () =
   Quicktest_args.parse () ;
-  Qt_filter.wrap (fun () ->
+  wrap (fun () ->
       let suite =
         [
-          ("Quicktest_example", Quicktest_example.tests ())
+          ( "Quicktest_vm_calibrate_cleanup0"
+          , Quicktest_vm_calibrate.tests_cleanup ()
+          )
+        ; ("Quicktest_vm_calibrate", Quicktest_vm_calibrate.tests ())
+        ; ( "Quicktest_vm_calibrate_cleanup1"
+          , Quicktest_vm_calibrate.tests_cleanup ()
+          )
+        ; ( "Quicktest_vm_calibrate_cleanup00"
+          , Quicktest_vm_calibrate.tests_cleanup ()
+          )
+        ; ("Quicktest_vm_memory", Quicktest_vm_memory.tests ())
+        ; ( "Quicktest_vm_calibrate_cleanup2"
+          , Quicktest_vm_calibrate.tests_cleanup ()
+          )
+        ; ("Quicktest_example", Quicktest_example.tests ())
         ; ("Quicktest_message", Quicktest_message.tests ())
         ; ("xenstore", Quicktest_xenstore.tests ())
         ; ("cbt", Quicktest_cbt.tests ())