CP-48623: reduce XenAPI.py connection rate and drop 4 useless API calls

ocaml/libs/uuid/uuidx.ml

@@ -83,3 +83,15 @@ let string_of_uuid = to_string
 let uuid_of_int_array = of_int_array
 
 let int_array_of_uuid = to_int_array
+
+module Hash = struct
+  (** Derive a deterministic UUID from a string: the same
+      string maps to the same UUID. We are using our own namespace; the
+      namespace is not a secret *)
+
+  let namespace =
+    let ns = "e93e0639-2bdb-4a59-8b46-352b3f408c19" in
+    Uuidm.(of_string ns |> Option.get)
+
+  let string str = Uuidm.v5 namespace str
+end

ocaml/libs/uuid/uuidx.mli

@@ -81,3 +81,11 @@ val make_cookie : unit -> cookie
 val cookie_of_string : string -> cookie
 
 val string_of_cookie : cookie -> string
+
+module Hash : sig
+  (** hash a string (deterministically) into a UUID. This uses
+      namespace UUID e93e0639-2bdb-4a59-8b46-352b3f408c19. *)
+
+  (* UUID Version 5 derived from argument string and namespace UUID *)
+  val string : string -> 'a t
+end

ocaml/message-switch/cli/dune

@@ -5,6 +5,7 @@
     cmdliner
     message-switch-core
     message-switch-unix
+    mtime
     rpclib.core
     rpclib.json
     threads.posix

ocaml/message-switch/cli/main.ml

@@ -76,23 +76,36 @@ let help =
   ; `P (Printf.sprintf "Check bug reports at %s" project_url)
   ]
 
+(* Durations, in nanoseconds *)
+let second = 1_000_000_000L
+
+let minute = 60_000_000_000L
+
+let hour = 3600_000_000_000L
+
+let day = 86400_000_000_000L
+
 (* Commands *)
 
 let diagnostics common_opts =
   Client.connect ~switch:common_opts.Common.path () >>|= fun t ->
   Client.diagnostics ~t () >>|= fun d ->
   let open Message_switch_core.Protocol in
-  let in_the_past = Int64.sub d.Diagnostics.current_time in
+  let in_the_past ts =
+    if d.Diagnostics.current_time < ts then
+      0L
+    else
+      Int64.sub d.Diagnostics.current_time ts
+  in
   let time f x =
-    let open Int64 in
-    let secs = div (f x) 1_000_000_000L in
-    let secs' = rem secs 60L in
-    let mins = div secs 60L in
-    let mins' = rem mins 60L in
-    let hours = div mins 60L in
-    let hours' = rem hours 24L in
-    let days = div hours 24L in
-    let fragment name = function
+    let timespan = f x in
+    let ( // ) = Int64.div in
+    let ( %% ) = Int64.rem in
+    let secs = timespan %% minute // second in
+    let mins = timespan %% hour // minute in
+    let hours = timespan %% day // hour in
+    let days = timespan // day in
+    let format name = function
       | 0L ->
           []
       | 1L ->
@@ -101,11 +114,10 @@ let diagnostics common_opts =
           [Printf.sprintf "%Ld %ss" n name]
     in
     let bits =
-      fragment "day" days
-      @ fragment "hour" hours'
-      @ fragment "min" mins'
-      @ fragment "second" secs'
-      @ []
+      format "day" days
+      @ format "hour" hours
+      @ format "min" mins
+      @ format "second" secs
     in
     let length = List.length bits in
     let _, rev_bits =
@@ -122,7 +134,16 @@ let diagnostics common_opts =
         )
         (0, []) bits
     in
-    String.concat "" (List.rev rev_bits) ^ "ago"
+    let format_secs ts =
+      Mtime.Span.(Format.asprintf "%a " pp (of_uint64_ns ts))
+    in
+    let timestrings =
+      if rev_bits = [] then
+        [format_secs (timespan %% minute)]
+      else
+        List.rev rev_bits
+    in
+    String.concat "" timestrings ^ "ago"
   in
   let origin = function
     | Anonymous id ->

ocaml/quicktest/qt.ml

@@ -132,26 +132,32 @@ module VM = struct
           Some x
   end
 
-  let install rpc session_id ~template ~name =
+  let install rpc session_id ~template ~name ?sr () =
     let template_uuid =
       Client.Client.VM.get_uuid ~rpc ~session_id ~self:template
     in
-    let newvm_uuid =
-      cli_cmd
-        [
-          "vm-install"
-        ; "template-uuid=" ^ template_uuid
-        ; "new-name-label=" ^ name
-        ]
+    let cmd =
+      ["vm-install"; "template-uuid=" ^ template_uuid; "new-name-label=" ^ name]
     in
+    let sr_uuid =
+      Option.map
+        (fun sr -> Client.Client.SR.get_uuid ~rpc ~session_id ~self:sr)
+        sr
+    in
+    let cmd =
+      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
 
   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 f =
-    let vm = install rpc session_id ~template ~name:"temp_quicktest_vm" in
+  let with_new rpc session_id ~template ?sr f =
+    let vm =
+      install rpc session_id ~template ~name:"temp_quicktest_vm" ?sr ()
+    in
     Xapi_stdext_pervasives.Pervasiveext.finally
       (fun () -> f vm)
       (fun () -> uninstall rpc session_id vm)

ocaml/quicktest/qt.mli

@@ -50,7 +50,12 @@ module VM : sig
   end
 
   val with_new :
-    rpc -> API.ref_session -> template:API.ref_VM -> (API.ref_VM -> 'a) -> 'a
+       rpc
+    -> API.ref_session
+    -> template:API.ref_VM
+    -> ?sr:API.ref_SR
+    -> (API.ref_VM -> 'a)
+    -> 'a
 
   val dom0_of_host : rpc -> API.ref_session -> API.ref_host -> API.ref_VM
   (** Return a host's domain zero *)

ocaml/quicktest/quicktest_vm_lifecycle.ml

@@ -91,12 +91,18 @@ let one rpc session_id vm test =
   | Halted ->
       wait_for_domid (fun domid' -> domid' = -1L)
 
-let test rpc session_id vm_template () =
-  Qt.VM.with_new rpc session_id ~template:vm_template (fun vm ->
+let test rpc session_id sr_info vm_template () =
+  let sr = sr_info.Qt.sr in
+  Qt.VM.with_new rpc session_id ~template:vm_template ~sr (fun vm ->
       List.iter (one rpc session_id vm) all_possible_tests
   )
 
 let tests () =
   let open Qt_filter in
-  [[("VM lifecycle tests", `Slow, test)] |> conn |> vm_template "CoreOS"]
+  [
+    [("VM lifecycle tests", `Slow, test)]
+    |> conn
+    |> sr SR.(all |> allowed_operations [`vdi_create])
+    |> vm_template "CoreOS"
+  ]
   |> List.concat

ocaml/xapi/sm.ml

@@ -152,7 +152,7 @@ let sr_update ~dbg dconf driver sr =
   let call = Sm_exec.make_call ~sr_ref:sr dconf "sr_update" [] in
   Sm_exec.parse_unit (Sm_exec.exec_xmlrpc ~dbg (driver_filename driver) call)
 
-let vdi_create ~dbg dconf driver sr sm_config vdi_type size name_label
+let vdi_create ~dbg ?vdi_uuid dconf driver sr sm_config vdi_type size name_label
     name_description metadata_of_pool is_a_snapshot snapshot_time snapshot_of
     read_only =
   with_dbg ~dbg ~name:"vdi_create" @@ fun di ->
@@ -164,8 +164,8 @@ let vdi_create ~dbg dconf driver sr sm_config vdi_type size name_label
     ) ;
   srmaster_only dconf ;
   let call =
-    Sm_exec.make_call ~sr_ref:sr ~vdi_sm_config:sm_config ~vdi_type dconf
-      "vdi_create"
+    Sm_exec.make_call ?vdi_uuid ~sr_ref:sr ~vdi_sm_config:sm_config ~vdi_type
+      dconf "vdi_create"
       [
         sprintf "%Lu" size
       ; name_label

ocaml/xapi/sm_exec.ml

@@ -69,8 +69,8 @@ type call = {
 }
 
 let make_call ?driver_params ?sr_sm_config ?vdi_sm_config ?vdi_type
-    ?vdi_location ?new_uuid ?sr_ref ?vdi_ref (subtask_of, device_config) cmd
-    args =
+    ?vdi_location ?new_uuid ?sr_ref ?vdi_ref ?vdi_uuid
+    (subtask_of, device_config) cmd args =
   Server_helpers.exec_with_new_task "sm_exec" (fun __context ->
       (* Only allow a subset of calls if the SR has been introduced by a DR task. *)
       Option.iter
@@ -117,7 +117,22 @@ let make_call ?driver_params ?sr_sm_config ?vdi_sm_config ?vdi_type
           Option.map (fun self -> Db.VDI.get_location ~__context ~self) vdi_ref
       in
       let vdi_uuid =
-        Option.map (fun self -> Db.VDI.get_uuid ~__context ~self) vdi_ref
+        match (cmd, vdi_ref, vdi_uuid) with
+        | "vdi_create", None, (Some x as uuid) ->
+            debug "%s: cmd=%s vdi_uuid=%s" __FUNCTION__ cmd x ;
+            uuid
+            (* when creating a VDI we sometimes want to provide the UUID
+               rather than letting the backend pick one. This is to
+               support backup VDIs CP-46179. So in that case, use the
+               provided UUID but not for other commands *)
+        | _, None, Some uuid ->
+            warn "%s: cmd=%s vdi_uuid=%s - should not happen" __FUNCTION__ cmd
+              uuid ;
+            None
+        | _, Some self, _ ->
+            Db.VDI.get_uuid ~__context ~self |> Option.some
+        | _, None, None ->
+            None
       in
       let vdi_on_boot =
         Option.map

ocaml/xapi/storage_smapiv1.ml

@@ -691,19 +691,33 @@ module SMAPIv1 : Server_impl = struct
       let uuid = require_uuid vi in
       vdi_info_from_db ~__context (Db.VDI.get_by_uuid ~__context ~uuid)
 
-    let create _context ~dbg ~sr ~vdi_info =
+    let create _context ~dbg ~sr ~(vdi_info : Storage_interface.vdi_info) =
       with_dbg ~name:"VDI.create" ~dbg @@ fun di ->
       let dbg = Debuginfo.to_string di in
       try
         Server_helpers.exec_with_new_task "VDI.create"
           ~subtask_of:(Ref.of_string dbg) (fun __context ->
-            let sr = Db.SR.get_by_uuid ~__context ~uuid:(s_of_sr sr) in
+            let sr_uuid = s_of_sr sr in
+            let sr = Db.SR.get_by_uuid ~__context ~uuid:sr_uuid in
             let vi =
+              (* we want to set vdi_uuid when creating a backup VDI with
+                 a specific UUID. SM picks up vdi_uuid instead of creating
+                 a new random UUID; Cf. Xapi_vdi.create *)
+              let vdi_uuid =
+                match vdi_info.uuid with
+                | Some uuid when uuid = Uuidx.(Hash.string sr_uuid |> to_string)
+                  ->
+                    info "%s: creating a backup VDI %s" __FUNCTION__ uuid ;
+                    vdi_info.uuid
+                | _ ->
+                    None
+              in
               Sm.call_sm_functions ~__context ~sR:sr (fun device_config _type ->
-                  Sm.vdi_create ~dbg device_config _type sr vdi_info.sm_config
-                    vdi_info.ty vdi_info.virtual_size vdi_info.name_label
-                    vdi_info.name_description vdi_info.metadata_of_pool
-                    vdi_info.is_a_snapshot vdi_info.snapshot_time
+                  Sm.vdi_create ~dbg ?vdi_uuid device_config _type sr
+                    vdi_info.sm_config vdi_info.ty vdi_info.virtual_size
+                    vdi_info.name_label vdi_info.name_description
+                    vdi_info.metadata_of_pool vdi_info.is_a_snapshot
+                    vdi_info.snapshot_time
                     (s_of_vdi vdi_info.snapshot_of)
                     vdi_info.read_only
               )

ocaml/xapi/xapi_vdi.ml

@@ -625,13 +625,27 @@ let create ~__context ~name_label ~name_description ~sR ~virtual_size ~_type
     | `cbt_metadata ->
         "cbt_metadata"
   in
+  (* special case: we want to use a specific UUID for Pool Meta Data
+     Backup *)
+  let uuid_ =
+    match (_type, name_label) with
+    | `user, "Pool Metadata Backup" ->
+        let sr = Db.SR.get_uuid ~__context ~self:sR in
+        let uuid = Uuidx.(Hash.string sr |> to_string) in
+        info "%s: using deterministic UUID for '%s' VDI: %s" __FUNCTION__
+          name_label uuid ;
+        Some uuid
+    | _ ->
+        None
+  in
   let open Storage_access in
   let task = Context.get_task_id __context in
   let open Storage_interface in
   let vdi_info =
     {
       Storage_interface.default_vdi_info with
-      name_label
+      uuid= uuid_
+    ; name_label
     ; name_description
     ; ty= vdi_type
     ; read_only

pyproject.toml

@@ -83,7 +83,6 @@ expected_to_fail = [
     "scripts/examples/python/exportimport.py",
     # Other fixes needed:
     "scripts/examples/python/mini-xenrt.py",
-    "scripts/examples/python/XenAPI/XenAPI.py",
     "scripts/examples/python/monitor-unwanted-domains.py",
     "scripts/examples/python/shell.py",
     "scripts/examples/smapiv2.py",