CP-28427: add Bond.create test

Test creating a bond, setting up a GFS2 SR on one host,
and then join more hosts to the pool.

This allows to just rollback to snapshot, upload a new XAPI,
and run the bonding test to reproduce problems during pool join.

Signed-off-by: Edwin Török <[email protected]>

Author: edwintorok

lib/test_sr.ml

@@ -342,6 +342,40 @@ let make_pool ~uname ~pwd conf ips =
                 m "All hosts enabled in the pool, master is: %a" Ipaddr.V4.pp_hum master ) ;
             Lwt.return t ) )
 
+let destroy_pools ~uname ~pwd ips =
+  let destroy_pool master =
+    let ipstr = Ipaddr.V4.to_string master in
+    with_login ~uname ~pwd ipstr (fun t ->
+        step t (Printf.sprintf "Unplug PBDs on %s" ipstr) (fun ctx ->
+            rpc ctx @@ PBD.get_all_records
+            >>= Lwt_list.iter_p (fun (pbd, pbdr) ->
+                if pbdr.API.pBD_currently_attached then
+                  rpc ctx @@ PBD.unplug ~self:pbd
+                else Lwt.return_unit
+             )
+        ) >>= fun () ->
+        step t (Printf.sprintf "Destroy cluster if any on %s" ipstr) (fun ctx ->
+            rpc ctx @@ Cluster.get_all
+            >>= Lwt_list.iter_s (fun self ->
+                rpc ctx @@ Cluster.pool_force_destroy ~self
+              )
+        ) >>= fun () ->
+        step t (Printf.sprintf "Pool eject on %s's pool" ipstr) @@ fun ctx ->
+        rpc ctx @@ Host.get_all_records
+        >>= Lwt_list.iter_s (fun (host, hostr) ->
+          debug (fun m -> m "Host %s is %s" (Ref.string_of host) hostr.API.host_name_label);
+          if hostr.API.host_address <> ipstr then
+            rpc ctx @@ Pool.eject ~host
+          else Lwt.return_unit
+        )
+      )
+  in
+  debug (fun m -> m "Destroying pool(s)");
+  Lwt_list.map_p (get_master ~uname ~pwd) ips
+  >>= fun masters ->
+  List.sort_uniq Ipaddr.V4.compare masters
+  |> Lwt_list.iter_p destroy_pool
+
 let find_templates ctx label =
   rpc ctx @@ VM.get_by_name_label ~label
   >>= Lwt_list.filter_map_p (fun vm_ref ->

src/cmd_bonding.ml

@@ -0,0 +1,110 @@
+open Lwt.Infix
+open Testarossa
+open Cmd_types
+open Context
+open Xen_api_lwt_unix
+
+let ensure_vm_off ctx vifr =
+  let self = vifr.API.vIF_VM in
+  rpc ctx @@ VM.get_power_state ~self
+  >>= function
+  | `Halted -> Lwt.return_unit
+  | _ ->
+    rpc ctx @@ VM.shutdown ~vm:self
+
+let ensure_vm_on ctx (vm, vmr) =
+  match vmr.API.vM_power_state with
+  | `Halted -> rpc ctx @@ VM.start ~start_paused:false ~force:false ~vm
+  | _ -> Lwt.return_unit
+
+let ensure_vhosts_on conf =
+  match conf.physical with
+  | None -> Lwt.return_unit
+  | Some host ->
+  Context.with_login ~uname:conf.uname ~pwd:conf.pwd host (fun phys ->
+      Context.step phys "ensure vhosts are powered on" @@ fun ctx ->
+      Rollback.list_vms ctx
+      >>= Lwt_list.iter_p (ensure_vm_on ctx)
+  )
+
+let ensure_vhost_nics conf =
+  match conf.physical with
+  | None -> Lwt.return_unit
+  | Some host ->
+  Context.with_login ~uname:conf.uname ~pwd:conf.pwd host (fun phys ->
+      Context.step phys "ensure vhost has enough NICs" @@ fun ctx ->
+      Rollback.list_vms ctx
+      >>= Lwt_list.iter_p (fun (vm, vmr) ->
+          match vmr.API.vM_VIFs with
+          | [] -> Lwt.fail_with "No NICs"
+          | [ one ] ->
+            rpc ctx @@ VIF.get_network ~self:one
+            >>= fun network ->
+            rpc ctx @@ VIF.create ~device:"1" ~network ~vM:vm ~mAC:""
+              ~mTU:1500L ~other_config:[] ~qos_algorithm_type:""
+              ~qos_algorithm_params:[] ~locking_mode:`network_default
+              ~ipv4_allowed:[] ~ipv6_allowed:[]
+            >>= fun vif ->
+            debug (fun m -> m "VIF %s created" (Ref.string_of vif));
+            (* can't hotplug due to pure HVM mode *)
+            rpc ctx @@ VM.hard_reboot ~vm
+          | _ -> Lwt.return_unit
+      )
+  )
+
+let ensure_bonding_on_master conf =
+  let master = List.hd conf.hosts |> Ipaddr.V4.to_string in
+  Context.with_login ~uname:conf.uname ~pwd:conf.pwd master (fun t ->
+      step t "Create bond on master if needed" @@ fun ctx ->
+      rpc ctx @@ Pool.get_all
+      >>= fun pools ->
+      rpc ctx @@ Pool.get_master ~self:(List.hd pools)
+      >>= fun host ->
+      rpc ctx @@ PIF.scan ~host
+      >>= fun () ->
+      rpc ctx @@ Bond.get_all
+      >>= function
+      | [] ->
+        info (fun m -> m "No bond, creating one");
+        rpc ctx @@ Host.get_management_interface ~host
+        >>= fun pif ->
+        rpc ctx @@ PIF.get_record ~self:pif
+        >>= fun pifr ->
+        rpc ctx @@ Host.get_PIFs ~self:host
+        >>= fun members ->
+        rpc ctx @@ Network.create ~name_label:"bonded network"
+          ~name_description:"" ~mTU:1500L ~other_config:[]
+          ~bridge:"" ~managed:true ~tags:[]
+        >>= fun network ->
+        rpc ctx @@ Bond.create ~network ~members ~mAC:"" ~mode:`balanceslb ~properties:[]
+        >>= fun bond ->
+        debug (fun m -> m "Created bond %s" (Ref.string_of bond));
+        Lwt.return_unit
+      | _ -> Lwt.return_unit
+  )
+
+
+let do_prepare conf =
+  let master = List.hd conf.hosts |> Ipaddr.V4.to_string in
+  Context.with_login ~uname:conf.uname ~pwd:conf.pwd master (fun t ->
+  License.maybe_apply_license_pool t conf [Features.HA; Features.Corosync]
+  >>= fun () ->
+  Test_sr.enable_clustering t
+  >>= fun _cluster ->
+  (match (conf.iscsi, conf.iqn) with
+  | Some iscsi, Some iqn ->
+      Test_sr.get_gfs2_sr t ~iscsi ~iqn ?scsiid:conf.scsiid () >>= fun _gfs2 -> Lwt.return_unit
+  | _ -> Lwt.return_unit)
+  >>= fun () ->
+  Test_sr.make_pool ~uname:conf.uname ~pwd:conf.pwd conf conf.hosts)
+
+let run conf =
+  ensure_vhost_nics conf
+  >>= fun () ->
+  ensure_vhosts_on conf
+  >>= fun () ->
+ (* Test_sr.destroy_pools ~uname:conf.uname ~pwd:conf.pwd conf.hosts :
+  >>= fun () ->*)
+   ensure_bonding_on_master conf
+  >>= fun ()->
+  do_prepare conf

src/cmd_lwt.ml

@@ -120,3 +120,8 @@ let run ~common ~sdocs ~exits =
   let doc = "Run tests in a prepared environment" in
   let main () config skip_serial tests = lwt_main config (fun conf -> run_tests conf skip_serial tests) in
   (Term.(const main $ common $ config $ skip_serial $ tests), Term.info "run" ~doc ~sdocs ~exits)
+
+let bonding ~common ~sdocs ~exits =
+  let doc = "Run bonding tests" in
+  let main () config = lwt_main config Cmd_bonding.run in
+  Term.(const main $ common $ config), Term.info "bonding" ~doc ~sdocs ~exits

src/main.ml

@@ -64,4 +64,6 @@ let () =
       ; Cmd_lwt.prepare ~sdocs ~exits ~common
       ; Cmd_lwt.rollback ~sdocs ~exits ~common
       ; Cmd_init.list ~sdocs ~exits ~common
-      ; Cmd_lwt.run ~sdocs ~exits ~common ])
+      ; Cmd_lwt.run ~sdocs ~exits ~common
+      ; Cmd_lwt.bonding ~sdocs ~exits ~common
+      ])