From 1bf250b4b22da93c3399604b79dca6c8594f5a1b Mon Sep 17 00:00:00 2001
From: Yann Dirson <yann.dirson@vates.fr>
Date: Tue, 5 Mar 2024 16:55:30 +0100
Subject: [PATCH] Quicktest_vm_lifecycle: use requested SR not default SR

This test did not exercised the SR type expected by user, and notably
failed when no default SR was defined.

Adds the option of installing a VM in a non-default SR using
VM.with_new.

Signed-off-by: Yann Dirson <yann.dirson@vates.fr>
---
 ocaml/quicktest/qt.ml                     | 26 ++++++++++++++---------
 ocaml/quicktest/qt.mli                    |  7 +++++-
 ocaml/quicktest/quicktest_vm_lifecycle.ml | 12 ++++++++---
 3 files changed, 31 insertions(+), 14 deletions(-)

diff --git a/ocaml/quicktest/qt.ml b/ocaml/quicktest/qt.ml
index 1764f12ce8f..d390f0dfc38 100644
--- a/ocaml/quicktest/qt.ml
+++ b/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)
diff --git a/ocaml/quicktest/qt.mli b/ocaml/quicktest/qt.mli
index f0edde13a56..15dbb785f28 100644
--- a/ocaml/quicktest/qt.mli
+++ b/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 *)
diff --git a/ocaml/quicktest/quicktest_vm_lifecycle.ml b/ocaml/quicktest/quicktest_vm_lifecycle.ml
index 88fd9b8d664..b3de6b5b309 100644
--- a/ocaml/quicktest/quicktest_vm_lifecycle.ml
+++ b/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