Merge tag 'v1.124.0' into uefi

Conflicts:
	ocaml/xapi/xapi_xenops.ml

Author: edwintorok

ocaml/tests/test_sr_update_vdis.ml

@@ -25,6 +25,8 @@ let assert_snapshot_of_is_not_null ~__context ~vdi_snapshot =
     "VDI snapshot's `snapshot_of` reference has become null"
     true (vdi <> Ref.null)
 
+let default_vdi_info = Storage_interface.default_vdi_info
+
 (* CA-254515 *)
 (* Tests that a single VDI snapshot from the SR is properly updating the
    existing snapshot in the database; the test should pass if the `snapshot_of`
@@ -38,15 +40,15 @@ let test_update_existing_snapshot () =
   let vdi = T.make_vdi ~__context ~uuid:vdi_uuid ~location:vdi_uuid ~sR:sr () in
   let vdi_snapshot_uuid = T.make_uuid () in
   let vdi_snapshot = T.make_vdi ~__context ~uuid:vdi_snapshot_uuid ~sR:sr
-    ~location:vdi_snapshot_uuid ~snapshot_of:vdi ~is_a_snapshot:true () in
+      ~location:vdi_snapshot_uuid ~snapshot_of:vdi ~is_a_snapshot:true () in
 
   (* create mock snapshot record which we would get from an SR scan *)
   let vdi_snapshot_sr_record = Storage_interface.({ default_vdi_info with
-    vdi = vdi_snapshot_uuid;
-    uuid = Some vdi_snapshot_uuid;
-    is_a_snapshot = true;
-    snapshot_of = vdi_uuid;
-  }) in
+                                                    vdi = Storage_interface.Vdi.of_string vdi_snapshot_uuid;
+                                                    uuid = Some vdi_snapshot_uuid;
+                                                    is_a_snapshot = true;
+                                                    snapshot_of = Storage_interface.Vdi.of_string vdi_uuid;
+                                                  }) in
 
   (* attempt to reproduce the issue by updating the snapshot *)
   let vdi_snapshot_record = Db.VDI.get_record ~__context ~self:vdi_snapshot in
@@ -77,15 +79,15 @@ let test_update_new_vdi_and_snapshot () =
 
   (* create mock VDI/snapshot records which we would get from an SR scan *)
   let vdi_sr_record = Storage_interface.({ default_vdi_info with
-    vdi = vdi_uuid;
-    uuid = Some vdi_uuid;
-  }) in
+                                           vdi = Storage_interface.Vdi.of_string vdi_uuid;
+                                           uuid = Some vdi_uuid;
+                                         }) in
   let vdi_snapshot_sr_record = Storage_interface.({ default_vdi_info with
-    vdi = vdi_snapshot_uuid;
-    uuid = Some vdi_snapshot_uuid;
-    snapshot_of = vdi_uuid;
-    is_a_snapshot = true;
-  }) in
+                                                    vdi = Storage_interface.Vdi.of_string vdi_snapshot_uuid;
+                                                    uuid = Some vdi_snapshot_uuid;
+                                                    snapshot_of = Storage_interface.Vdi.of_string vdi_uuid;
+                                                    is_a_snapshot = true;
+                                                  }) in
 
   (* attempt to reproduce the issue by creating the snapshot before the VDI *)
   Xapi_sr.update_vdis ~__context ~sr [] [vdi_sr_record; vdi_snapshot_sr_record];
@@ -107,10 +109,10 @@ let test_sharable_field_updated_for_existing_vdi () =
 
   (* SR.scan returned the correct vdi_info with the up-to-date sharable field *)
   let vdi_sr_record = Storage_interface.({ default_vdi_info with
-    vdi = vdi_uuid;
-    uuid = Some vdi_uuid;
-    sharable = true;
-  }) in
+                                           vdi = Storage_interface.Vdi.of_string vdi_uuid;
+                                           uuid = Some vdi_uuid;
+                                           sharable = true;
+                                         }) in
 
   (* When we call this function from our SR.scan XenAPI call for example, it should
      update the VDI's sharable field to the correct value returned by the
@@ -128,10 +130,10 @@ let test_sharable_field_correct_for_new_vdi () =
   (* We do not have this VDI in xapi's database. SR.scan returned it with the
      correct vdi_info containing the up-to-date sharable field. *)
   let vdi_sr_record = Storage_interface.({ default_vdi_info with
-    vdi = vdi_uuid;
-    uuid = Some vdi_uuid;
-    sharable = true;
-  }) in
+                                           vdi = Storage_interface.Vdi.of_string vdi_uuid;
+                                           uuid = Some vdi_uuid;
+                                           sharable = true;
+                                         }) in
 
   (* When we call this function from our SR.scan XenAPI call for example, it should
      add the VDI to xapi's database with the correct sharable field returned

ocaml/tests/test_storage_migrate_state.ml

@@ -24,30 +24,30 @@ end
 
 let sample_send_state = Storage_migrate.State.Send_state.({
     url = "url";
-    dest_sr = "dest_sr";
-    remote_info = Some {dp="remote_dp"; vdi="mirror_vdi"; url="remote_url"};
+    dest_sr = Storage_interface.Sr.of_string "dest_sr";
+    remote_info = Some {dp="remote_dp"; vdi=Storage_interface.Vdi.of_string "mirror_vdi"; url="remote_url"};
     local_dp = "local_dp";
     tapdev = Some (Tapctl.tapdev_of_rpc
-        (Rpc.Dict ["minor", Rpc.Int 0L; "tapdisk_pid", Rpc.Int 0L]));
+                     (Rpc.Dict ["minor", Rpc.Int 0L; "tapdisk_pid", Rpc.Int 0L]));
     failed = false;
     watchdog = None;
   })
 
 let sample_receive_state = Storage_migrate.State.Receive_state.({
-    sr = "my_sr";
-    dummy_vdi = "dummy_vdi";
-    leaf_vdi = "leaf_vdi";
+    sr = Storage_interface.Sr.of_string "my_sr";
+    dummy_vdi = Storage_interface.Vdi.of_string "dummy_vdi";
+    leaf_vdi = Storage_interface.Vdi.of_string "leaf_vdi";
     leaf_dp = "leaf_dp";
-    parent_vdi = "parent_vdi";
-    remote_vdi = "remote_vdi";
+    parent_vdi = Storage_interface.Vdi.of_string "parent_vdi";
+    remote_vdi = Storage_interface.Vdi.of_string "remote_vdi";
   })
 
 let sample_copy_state = Storage_migrate.State.Copy_state.({
     base_dp = "base_dp";
     leaf_dp = "leaf_dp";
     remote_dp = "remote_dp";
-    dest_sr = "dest_sr";
-    copy_vdi = "copy_vdi";
+    dest_sr = Storage_interface.Sr.of_string "dest_sr";
+    copy_vdi = Storage_interface.Vdi.of_string "copy_vdi";
     remote_url = "remote_url";
   })
 

ocaml/tests/test_vdi_cbt.ml

@@ -13,9 +13,9 @@
   *)
 
 
-let register_smapiv2_server (module S: Storage_interface.Server_impl with type context = unit) sr_ref =
-  let module S = Storage_interface.Server(S) in
-  let rpc = S.process () in
+let register_smapiv2_server (module S: Storage_interface.Server_impl) sr_ref =
+  let module S = Storage_interface.Server(S)() in
+  let rpc = S.process in
   let dummy_query_result = Storage_interface.({ driver=""; name=""; description=""; vendor=""; copyright=""; version=""; required_api_version=""; features=[]; configuration=[]; required_cluster_stack=[] }) in
   Storage_mux.register sr_ref rpc "" dummy_query_result
 
@@ -32,7 +32,7 @@ let make_smapiv2_storage_server ?vdi_enable_cbt ?vdi_disable_cbt ?vdi_list_chang
       let snapshot = default Storage_skeleton.VDI.snapshot vdi_snapshot
       let clone = default Storage_skeleton.VDI.clone vdi_snapshot
     end
-  end : Storage_interface.Server_impl with type context = unit)
+  end : Storage_interface.Server_impl)
 
 let register_smapiv2_server ?vdi_enable_cbt ?vdi_disable_cbt ?vdi_list_changed_blocks ?vdi_data_destroy ?vdi_snapshot ?vdi_clone sr_ref =
   let s = make_smapiv2_storage_server ?vdi_enable_cbt ?vdi_disable_cbt ?vdi_list_changed_blocks ?vdi_data_destroy ?vdi_snapshot ?vdi_clone () in
@@ -47,32 +47,41 @@ let make_mock_server_infrastructure ~__context =
   let _: _ API.Ref.t = Test_common.make_pbd ~__context ~host ~sR ~currently_attached:true () in
   sR
 
+let alcotestable_of_def def =
+  let pp fmt a = Format.fprintf fmt "%s" (Rpcmarshal.marshal def.Rpc.Types.ty a |> Jsonrpc.to_string) in
+  Alcotest.testable pp (=)
+
+let alco_sr = alcotestable_of_def Storage_interface.Sr.t
+let alco_vdi = alcotestable_of_def Storage_interface.Vdi.t
+
 let test_cbt_enable_disable () =
   let __context = Test_common.make_test_database () in
   let sr_ref = Test_common.make_sr ~__context () in
   let sr_uuid = Db.SR.get_uuid ~__context ~self:sr_ref in
+  let sr = Storage_interface.Sr.of_string sr_uuid in
   let vdi_location = "test123" in
+  let vdi = Storage_interface.Vdi.of_string vdi_location in
   let vdi_ref = Test_common.make_vdi ~__context ~sR:sr_ref ~location:vdi_location () in
   let assert_vdi_cbt_enabled_is value msg =
     Alcotest.(check bool) msg value (Db.VDI.get_cbt_enabled ~__context ~self:vdi_ref) in
-  let check_params = Alcotest.(check (option (pair string string))) in
+  let check_params = Alcotest.(check (option (pair alco_sr alco_vdi))) in
 
   let enable_cbt_params = ref None in
   let disable_cbt_params = ref None in
   register_smapiv2_server
     ~vdi_enable_cbt:(fun _ ~dbg ~sr ~vdi -> enable_cbt_params := Some (sr, vdi))
     ~vdi_disable_cbt:(fun _ ~dbg ~sr ~vdi -> disable_cbt_params := Some (sr, vdi))
-    sr_uuid;
+    sr;
 
   Xapi_vdi.enable_cbt ~__context ~self:vdi_ref;
-   check_params "The parameters should be correctly passed to SMAPIv2 from VDI.enable_cbt" (Some (sr_uuid, vdi_location)) !enable_cbt_params;
+  check_params "The parameters should be correctly passed to SMAPIv2 from VDI.enable_cbt" (Some (sr, vdi)) !enable_cbt_params;
   assert_vdi_cbt_enabled_is true "cbt_enabled should be true when VDI.enable_cbt returns successfully";
 
   Xapi_vdi.enable_cbt ~__context ~self:vdi_ref;
   assert_vdi_cbt_enabled_is true "VDI.enable_cbt should be idempotent";
 
   Xapi_vdi.disable_cbt ~__context ~self:vdi_ref;
-  check_params "The parameters should be correctly passed to SMAPIv2 from VDI.disable_cbt" (Some (sr_uuid, vdi_location)) !disable_cbt_params;
+  check_params "The parameters should be correctly passed to SMAPIv2 from VDI.disable_cbt" (Some (sr, vdi)) !disable_cbt_params;
   assert_vdi_cbt_enabled_is false "cbt_enabled should be false when VDI.disable_cbt returns successfully";
 
   Xapi_vdi.disable_cbt ~__context ~self:vdi_ref;
@@ -279,12 +288,12 @@ let setup_test_for_data_destroy ?(vdi_data_destroy=(fun _ ~dbg ~sr ~vdi -> ()))
 
   let sR = make_mock_server_infrastructure ~__context in
   let vdi = Test_common.make_vdi ~__context ~is_a_snapshot:true ~managed:true ~cbt_enabled:true ~sR () in
-  register_smapiv2_server ~vdi_data_destroy (Db.SR.get_uuid ~__context ~self:sR);
+  register_smapiv2_server ~vdi_data_destroy (Db.SR.get_uuid ~__context ~self:sR |> Storage_interface.Sr.of_string);
   (__context, sR, vdi)
 
 let test_allowed_operations_updated_when_necessary () =
   let __context, sR, self = setup_test_for_data_destroy () in
-  register_smapiv2_server ~vdi_data_destroy:(fun _ ~dbg ~sr ~vdi -> ()) (Db.SR.get_uuid ~__context ~self:sR);
+  register_smapiv2_server ~vdi_data_destroy:(fun _ ~dbg ~sr ~vdi -> ()) (Db.SR.get_uuid ~__context ~self:sR |> Storage_interface.Sr.of_string);
 
   let assert_allowed_operations msg check =
     Alcotest.(check bool) msg true (check (Db.VDI.get_allowed_operations ~__context ~self))
@@ -354,10 +363,10 @@ let test_data_destroy =
     let __context, sR, vdi = setup_test_for_data_destroy ~vdi_data_destroy:(fun _ ~dbg ~sr ~vdi -> raise (Failure "error")) () in
     let original_type = Db.VDI.get_type ~__context ~self:vdi in
     try Xapi_vdi.data_destroy ~__context ~self:vdi with _ -> ();
-    Alcotest.check (Alcotest_comparators.vdi_type)
-      "data_destroy should not change the VDI's type to cbt_metadata when it did not succeed, it should preserve the original type"
-      original_type
-      (Db.VDI.get_type ~__context ~self:vdi)
+      Alcotest.check (Alcotest_comparators.vdi_type)
+        "data_destroy should not change the VDI's type to cbt_metadata when it did not succeed, it should preserve the original type"
+        original_type
+        (Db.VDI.get_type ~__context ~self:vdi)
   in
 
   let test_data_destroy_timing =
@@ -384,7 +393,7 @@ let test_data_destroy =
         ignore (bg (fun () -> (try Xapi_vdi._data_destroy ~__context ~self:vDI ~timeout with e -> raisedexn := Some e); completed := true));
         Thread.delay timebox_timeout;
         if not !completed then
-                Alcotest.fail (Printf.sprintf "data_destroy did not return in %f seconds" timebox_timeout);
+          Alcotest.fail (Printf.sprintf "data_destroy did not return in %f seconds" timebox_timeout);
         match !raisedexn with
         | None -> ()
         | Some e -> raise e
@@ -479,24 +488,27 @@ let test_vdi_list_changed_blocks () =
   let __context = Test_common.make_test_database () in
   let sR = make_mock_server_infrastructure ~__context in
   let sr_uuid = Db.SR.get_uuid ~__context ~self:sR in
+  let sr = Storage_interface.Sr.of_string sr_uuid in
 
   let list_changed_blocks_params = ref None in
   let list_changed_blocks_string = "listchangedblocks000" in
 
   let vdi_from_location = "vdi_from_location" in
-  let vdi_from = Test_common.make_vdi ~__context ~location:vdi_from_location ~is_a_snapshot:true ~managed:true ~cbt_enabled:true ~sR () in
+  let vdi_from_ref = Test_common.make_vdi ~__context ~location:vdi_from_location ~is_a_snapshot:true ~managed:true ~cbt_enabled:true ~sR () in
+  let vdi_from = Storage_interface.Vdi.of_string vdi_from_location in
   let vdi_to_location = "vdi_to_location" in
-  let vdi_to = Test_common.make_vdi ~__context~location:vdi_to_location  ~sR ~cbt_enabled:true ~managed:true () in
+  let vdi_to_ref = Test_common.make_vdi ~__context~location:vdi_to_location  ~sR ~cbt_enabled:true ~managed:true () in
+  let vdi_to = Storage_interface.Vdi.of_string vdi_to_location in
 
   register_smapiv2_server
     ~vdi_list_changed_blocks:(fun _ ~dbg ~sr ~vdi_from ~vdi_to -> list_changed_blocks_params := Some (sr,(vdi_from,vdi_to)); list_changed_blocks_string)
-    (Db.SR.get_uuid ~__context ~self:sR);
+    (Db.SR.get_uuid ~__context ~self:sR |> Storage_interface.Sr.of_string);
 
   Alcotest.(check string) "VDI.list_changed_blocks"
-    (Xapi_vdi.list_changed_blocks ~__context ~vdi_from ~vdi_to)
+    (Xapi_vdi.list_changed_blocks ~__context ~vdi_from:vdi_from_ref ~vdi_to:vdi_to_ref)
     list_changed_blocks_string;
-  Alcotest.(check (option (pair string (pair string string)))) "VDI.list_changed_blocks parameters"
-    (Some (sr_uuid, (vdi_from_location, vdi_to_location)))
+  Alcotest.(check (option (pair alco_sr (pair alco_vdi alco_vdi)))) "VDI.list_changed_blocks parameters"
+    (Some (sr, (vdi_from, vdi_to)))
     !list_changed_blocks_params
 
 let test =

ocaml/xapi-consts/api_messages.ml

@@ -132,6 +132,7 @@ let host_cpu_features_down = addMessage "HOST_CPU_FEATURES_DOWN" 3L
 let host_cpu_features_up = addMessage "HOST_CPU_FEATURES_UP" 5L
 let pool_cpu_features_down = addMessage "POOL_CPU_FEATURES_DOWN" 5L
 let pool_cpu_features_up = addMessage "POOL_CPU_FEATURES_UP" 5L
+let host_low_memory = addMessage "HOST_LOW_MEMORY" 2L
 
 (* Cluster messages *)
 let cluster_host_enable_failed = addMessage "CLUSTER_HOST_ENABLE_FAILED" 3L

ocaml/xapi/attach_helpers.ml

@@ -101,17 +101,3 @@ let with_vbds rpc session_id __context vm vdis mode f =
            List.iter (Helpers.log_exn_continue "destroying VBD on VM"
                         (fun self -> Client.VBD.destroy rpc session_id self)) !vbds))
 
-(** Separates the implementations of the given backend returned from
-    the VDI.attach2 SMAPIv2 call based on their type *)
-let implementations_of_backend backend =
-  let open Storage_interface in
-  List.fold_left
-    (fun (xendisks, blockdevices, files, nbds) implementation ->
-       match implementation with
-       | XenDisk xendisk -> (xendisk::xendisks, blockdevices, files, nbds)
-       | BlockDevice blockdevice -> (xendisks, blockdevice::blockdevices, files, nbds)
-       | File file -> (xendisks, blockdevices, file::files, nbds)
-       | Nbd nbd -> (xendisks, blockdevices, files, nbd::nbds)
-    )
-    ([], [], [], [])
-    backend.implementations

ocaml/xapi/cli_operations.ml

@@ -1473,9 +1473,10 @@ let sr_probe printer rpc session_id params =
   try
     (* If it's the new format, try to print it more nicely *)
     let open Storage_interface in
-    match probe_result_of_rpc (Xmlrpc.of_string txt) with
-    | Raw x -> printer (Cli_printer.PList [ x ])
-    | Probe x -> failwith "Not implemented, this return type is for probe_ext"
+    match Rpcmarshal.unmarshal probe_result.Rpc.Types.ty (Xmlrpc.of_string txt) with
+    | Ok (Raw x) -> printer (Cli_printer.PList [ x ])
+    | Ok (Probe x) -> failwith "Not implemented, this return type is for probe_ext"
+    | Error (`Msg m) -> failwith (Printf.sprintf "Failed to unmarshal probe result: %s" m)
   with _ ->
     printer (Cli_printer.PList [txt])
 
@@ -1514,12 +1515,12 @@ let sr_probe_ext printer rpc session_id params =
     printer (Cli_printer.PMsg "The following SRs were found:");
     List.iteri
       (fun i (sr, probe_result) ->
-        printer (Cli_printer.PMsg (Printf.sprintf "SR %d:" i));
-        printer (Cli_printer.PTable [print_sr sr]);
-        printer (Cli_printer.PMsg (Printf.sprintf "SR %d configuration:" i));
-        printer (Cli_printer.PTable [probe_result.API.probe_result_configuration]);
-        printer (Cli_printer.PMsg (Printf.sprintf "SR %d extra information:" i));
-        printer (Cli_printer.PTable [probe_result.API.probe_result_extra_info]);
+         printer (Cli_printer.PMsg (Printf.sprintf "SR %d:" i));
+         printer (Cli_printer.PTable [print_sr sr]);
+         printer (Cli_printer.PMsg (Printf.sprintf "SR %d configuration:" i));
+         printer (Cli_printer.PTable [probe_result.API.probe_result_configuration]);
+         printer (Cli_printer.PMsg (Printf.sprintf "SR %d extra information:" i));
+         printer (Cli_printer.PTable [probe_result.API.probe_result_extra_info]);
       )
       srs;
   end;