From 930b3119596e3d43c8f529751e3909a664d765ad Mon Sep 17 00:00:00 2001 From: Rob Hoes Date: Tue, 4 Oct 2022 14:34:33 +0000 Subject: [PATCH 1/8] xenopsd: add verify_cert param to VM.migrate For the time being, only intra-pool migrations will have certificate checking turned on. The new parameter informs xenopsd about the choice. This only matters if an https URL is specified. Signed-off-by: Rob Hoes --- ocaml/xapi-idl/xen/xenops_interface.ml | 6 ++++++ ocaml/xapi/xapi_vm_migrate.ml | 10 ++++++---- ocaml/xenopsd/cli/xn.ml | 15 +++++++++------ ocaml/xenopsd/lib/xenops_server.ml | 13 +++++++++---- 4 files changed, 30 insertions(+), 14 deletions(-) diff --git a/ocaml/xapi-idl/xen/xenops_interface.ml b/ocaml/xapi-idl/xen/xenops_interface.ml index 506c5313c05..6d335c4d8de 100644 --- a/ocaml/xapi-idl/xen/xenops_interface.ml +++ b/ocaml/xapi-idl/xen/xenops_interface.ml @@ -665,6 +665,11 @@ module XenopsAPI (R : RPC) = struct ~description:["when true, use stream compression"] Types.bool in + let verify_cert = + Param.mk ~name:"verify_cert" + ~description:["when true, verify remote server certificate"] + Types.bool + in declare "VM.migrate" [] (debug_info_p @-> vm_id_p @@ -673,6 +678,7 @@ module XenopsAPI (R : RPC) = struct @-> pcimap @-> xenops_url @-> compress + @-> verify_cert @-> returning task_id_p err ) diff --git a/ocaml/xapi/xapi_vm_migrate.ml b/ocaml/xapi/xapi_vm_migrate.ml index 0dc3d74fcee..91fceeff476 100644 --- a/ocaml/xapi/xapi_vm_migrate.ml +++ b/ocaml/xapi/xapi_vm_migrate.ml @@ -232,7 +232,7 @@ let assert_licensed_storage_motion ~__context = Pool_features.assert_enabled ~__context ~f:Features.Storage_motion let rec migrate_with_retries ~__context queue_name max try_no dbg vm_uuid - xenops_vdi_map xenops_vif_map xenops_vgpu_map xenops compress = + xenops_vdi_map xenops_vif_map xenops_vgpu_map xenops compress verify_cert = let open Xapi_xenops_queue in let module Client = (val make_client queue_name : XENOPS) in let progress = ref "(none yet)" in @@ -240,7 +240,7 @@ let rec migrate_with_retries ~__context queue_name max try_no dbg vm_uuid progress := "Client.VM.migrate" ; let t1 = Client.VM.migrate dbg vm_uuid xenops_vdi_map xenops_vif_map - xenops_vgpu_map xenops compress + xenops_vgpu_map xenops compress verify_cert in progress := "sync_with_task" ; ignore (Xapi_xenops.sync_with_task __context queue_name t1) @@ -267,6 +267,7 @@ let rec migrate_with_retries ~__context queue_name max try_no dbg vm_uuid (Printexc.to_string e) !progress try_no max ; migrate_with_retries ~__context queue_name max (try_no + 1) dbg vm_uuid xenops_vdi_map xenops_vif_map xenops_vgpu_map xenops compress + verify_cert (* Something else went wrong *) | e -> debug @@ -403,7 +404,7 @@ let pool_migrate ~__context ~vm ~host ~options = Xapi_xenops.transform_xenops_exn ~__context ~vm queue_name (fun () -> migrate_with_retry ~__context queue_name dbg vm_uuid [] [] - xenops_vgpu_map xenops_url compress ; + xenops_vgpu_map xenops_url compress true ; (* Delete all record of this VM locally (including caches) *) Xapi_xenops.Xenopsd_metadata.delete ~__context vm_uuid ) @@ -1494,9 +1495,10 @@ let migrate_send' ~__context ~vm ~dest ~live:_ ~vdi_map ~vif_map ~vgpu_map (* can raise VGPU_mapping *) infer_vgpu_map ~__context ~remote new_vm in + let verify_cert = is_intra_pool in migrate_with_retry ~__context queue_name dbg vm_uuid xenops_vdi_map xenops_vif_map xenops_vgpu_map remote.xenops_url - compress ; + compress verify_cert ; Xapi_xenops.Xenopsd_metadata.delete ~__context vm_uuid ) with diff --git a/ocaml/xenopsd/cli/xn.ml b/ocaml/xenopsd/cli/xn.ml index 0833ed1913b..e5c64791484 100644 --- a/ocaml/xenopsd/cli/xn.ml +++ b/ocaml/xenopsd/cli/xn.ml @@ -1013,17 +1013,18 @@ let resume _copts disk x = let resume copts disk x = diagnose_error (need_vm (resume copts disk) x) -let migrate x url compress = +let migrate x url compress verify_cert = let open Vm in let vm, _ = find_by_name x in - let compress = - match String.lowercase_ascii compress with + let bool b = + match String.lowercase_ascii b with | "t" | "true" | "on" | "1" -> true | _ -> false in - Client.VM.migrate dbg vm.id [] [] [] url compress |> wait_for_task dbg + Client.VM.migrate dbg vm.id [] [] [] url (bool compress) (bool verify_cert) + |> wait_for_task dbg let trim limit str = let l = String.length str in @@ -1541,9 +1542,11 @@ let old_main () = | ["help"] | [] -> usage () ; exit 0 | ["migrate"; id; url] -> - migrate id url "false" |> task + migrate id url "false" "false" |> task | ["migrate"; id; url; compress] -> - migrate id url compress |> task + migrate id url compress "false" |> task + | ["migrate"; id; url; compress; verify_cert] -> + migrate id url compress verify_cert |> task | ["vbd-list"; id] -> vbd_list id | ["pci-add"; id; idx; bdf] -> diff --git a/ocaml/xenopsd/lib/xenops_server.ml b/ocaml/xenopsd/lib/xenops_server.ml index 002b5047935..35a4a4659ee 100644 --- a/ocaml/xenopsd/lib/xenops_server.ml +++ b/ocaml/xenopsd/lib/xenops_server.ml @@ -170,6 +170,7 @@ type vm_migrate_op = { ; vmm_tmp_src_id: Vm.id ; vmm_tmp_dest_id: Vm.id ; vmm_compress: bool + ; vmm_verify_cert: bool } [@@deriving rpcty] @@ -2406,6 +2407,9 @@ and perform_exn ?subtask ?result (op : operation) (t : Xenops_task.task_handle) f vgpu_fd in debug "%s compress memory: %b" __FUNCTION__ compress_memory ; + let verify_cert = + if vmm.vmm_verify_cert then Stunnel_client.pool () else None + in (* We need to perform version exchange here *) let module B = (val get_backend () : S) in B.VM.assert_can_save vm ; @@ -2462,7 +2466,7 @@ and perform_exn ?subtask ?result (op : operation) (t : Xenops_task.task_handle) let state = B.VM.get_state vm in info "VM %s has memory_limit = %Ld" id state.Vm.memory_limit ; let url = make_url "/migrate/vm/" new_dest_id in - Open_uri.with_open_uri url (fun vm_fd -> + Open_uri.with_open_uri ~verify_cert url (fun vm_fd -> let module Handshake = Xenops_migrate.Handshake in let do_request fd extra_cookies url = Sockopt.set_sock_keepalives fd ; @@ -2539,7 +2543,7 @@ and perform_exn ?subtask ?result (op : operation) (t : Xenops_task.task_handle) in let save ?vgpu_fd () = let url = make_url "/migrate/mem/" new_dest_id in - Open_uri.with_open_uri url (fun mem_fd -> + Open_uri.with_open_uri ~verify_cert url (fun mem_fd -> (* vm_fd: signaling channel, mem_fd: memory stream *) do_request mem_fd [] url ; Handshake.recv_success mem_fd ; @@ -2568,7 +2572,7 @@ and perform_exn ?subtask ?result (op : operation) (t : Xenops_task.task_handle) make_url "/migrate/vgpu/" (VGPU_DB.string_of_id (new_dest_id, dev_id)) in - Open_uri.with_open_uri url (fun vgpu_fd -> + Open_uri.with_open_uri ~verify_cert url (fun vgpu_fd -> Sockopt.set_sock_keepalives vgpu_fd ; do_request vgpu_fd [(cookie_vgpu_migration, "")] url ; Handshake.recv_success vgpu_fd ; @@ -3382,7 +3386,7 @@ module VM = struct let s3resume _ dbg id = queue_operation dbg id (Atomic (VM_s3resume id)) let migrate _context dbg id vmm_vdi_map vmm_vif_map vmm_vgpu_pci_map vmm_url - (compress : bool) = + (compress : bool) (verify_cert : bool) = let tmp_uuid_of uuid ~kind = Printf.sprintf "%s00000000000%c" (String.sub uuid 0 24) (match kind with `dest -> '1' | `src -> '0') @@ -3398,6 +3402,7 @@ module VM = struct ; vmm_tmp_src_id= tmp_uuid_of id ~kind:`src ; vmm_tmp_dest_id= tmp_uuid_of id ~kind:`dest ; vmm_compress= compress + ; vmm_verify_cert= verify_cert } ) From 39104748e974d3487b334f3bf2801c8b70ca35cb Mon Sep 17 00:00:00 2001 From: Rob Hoes Date: Fri, 30 Sep 2022 16:18:45 +0000 Subject: [PATCH 2/8] Switch VM.pool_migrate over to HTTPS This switches the xenopsd-to-xenopsd connection over to HTTPS, if enabled in the config file (currently off by default). Socket keepalives do not work when stunnel is used, as the given fd is the local connection to stunnel, and are not set in HTTPS mode. This is fine, because the stunnel client is already set up with keepalives. Signed-off-by: Rob Hoes --- ocaml/xapi/xapi_globs.ml | 7 +++++++ ocaml/xapi/xapi_vm_migrate.ml | 3 ++- ocaml/xenopsd/lib/xenops_server.ml | 7 +++++-- 3 files changed, 14 insertions(+), 3 deletions(-) diff --git a/ocaml/xapi/xapi_globs.ml b/ocaml/xapi/xapi_globs.ml index 9562150e6a3..6147f255a00 100644 --- a/ocaml/xapi/xapi_globs.ml +++ b/ocaml/xapi/xapi_globs.ml @@ -819,6 +819,8 @@ let web_dir = ref "/opt/xensource/www" let website_https_only = ref true +let migration_https_only = ref false + let cluster_stack_root = ref "/usr/libexec/xapi/cluster-stack" let cluster_stack_default = ref "xhad" @@ -1321,6 +1323,11 @@ let other_options = , (fun () -> string_of_bool !website_https_only) , "Allow access to the internal website using HTTPS only (no HTTP)" ) + ; ( "migration-https-only" + , Arg.Set migration_https_only + , (fun () -> string_of_bool !migration_https_only) + , "Exclusively use HTTPS for VM migration" + ) ; gen_list_option "repository-domain-name-allowlist" "space-separated list of allowed domain name in base URL in repository." (fun s -> s) diff --git a/ocaml/xapi/xapi_vm_migrate.ml b/ocaml/xapi/xapi_vm_migrate.ml index 91fceeff476..5a7ed654815 100644 --- a/ocaml/xapi/xapi_vm_migrate.ml +++ b/ocaml/xapi/xapi_vm_migrate.ml @@ -379,8 +379,9 @@ let pool_migrate ~__context ~vm ~host ~options = in debug "%s using stream compression=%b" __FUNCTION__ compress ; let ip = Http.Url.maybe_wrap_IPv6_literal address in + let scheme = if !Xapi_globs.migration_https_only then "https" else "http" in let xenops_url = - Printf.sprintf "http://%s/services/xenops?session_id=%s" ip session_id + Printf.sprintf "%s://%s/services/xenops?session_id=%s" scheme ip session_id in let vm_uuid = Db.VM.get_uuid ~__context ~self:vm in let xenops_vgpu_map = infer_vgpu_map ~__context vm in diff --git a/ocaml/xenopsd/lib/xenops_server.ml b/ocaml/xenopsd/lib/xenops_server.ml index 35a4a4659ee..3ff8c8d26db 100644 --- a/ocaml/xenopsd/lib/xenops_server.ml +++ b/ocaml/xenopsd/lib/xenops_server.ml @@ -2466,10 +2466,12 @@ and perform_exn ?subtask ?result (op : operation) (t : Xenops_task.task_handle) let state = B.VM.get_state vm in info "VM %s has memory_limit = %Ld" id state.Vm.memory_limit ; let url = make_url "/migrate/vm/" new_dest_id in + let https = Uri.scheme url = Some "https" in Open_uri.with_open_uri ~verify_cert url (fun vm_fd -> let module Handshake = Xenops_migrate.Handshake in let do_request fd extra_cookies url = - Sockopt.set_sock_keepalives fd ; + if not https then + Sockopt.set_sock_keepalives fd ; let module Request = Cohttp.Request.Make (Cohttp_posix_io.Unbuffered_IO) in let cookies = @@ -2573,7 +2575,8 @@ and perform_exn ?subtask ?result (op : operation) (t : Xenops_task.task_handle) (VGPU_DB.string_of_id (new_dest_id, dev_id)) in Open_uri.with_open_uri ~verify_cert url (fun vgpu_fd -> - Sockopt.set_sock_keepalives vgpu_fd ; + if not https then + Sockopt.set_sock_keepalives vgpu_fd ; do_request vgpu_fd [(cookie_vgpu_migration, "")] url ; Handshake.recv_success vgpu_fd ; debug "VM.migrate: Synchronisation point 1-vgpu" ; From c30fc1393283ac1693b1792229515b82f5c78d99 Mon Sep 17 00:00:00 2001 From: Rob Hoes Date: Fri, 7 Oct 2022 16:09:43 +0000 Subject: [PATCH 3/8] Switch host.migrate_receive over to HTTPS The host.migrate_receive call returns URLs for the sending host to use in its VM.migrate_send call. HTTPS URLs are returned based on the value of the config option. Signed-off-by: Rob Hoes --- ocaml/xapi/xapi_host.ml | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/ocaml/xapi/xapi_host.ml b/ocaml/xapi/xapi_host.ml index c956c630b7f..694183148b9 100644 --- a/ocaml/xapi/xapi_host.ml +++ b/ocaml/xapi/xapi_host.ml @@ -2552,13 +2552,14 @@ let migrate_receive ~__context ~host ~network ~options:_ = (Api_errors.interface_has_no_ip, [Ref.string_of pif]) ) ) ; + let scheme = if !Xapi_globs.migration_https_only then "https" else "http" in let sm_url = - Printf.sprintf "http://%s/services/SM?session_id=%s" + Printf.sprintf "%s://%s/services/SM?session_id=%s" scheme (Http.Url.maybe_wrap_IPv6_literal ip) new_session_id in let xenops_url = - Printf.sprintf "http://%s/services/xenops?session_id=%s" + Printf.sprintf "%s://%s/services/xenops?session_id=%s" scheme (Http.Url.maybe_wrap_IPv6_literal ip) new_session_id in @@ -2568,7 +2569,8 @@ let migrate_receive ~__context ~host ~network ~options:_ = Option.get (Helpers.get_management_ip_addr ~__context) in let master_url = - Printf.sprintf "http://%s/" (Http.Url.maybe_wrap_IPv6_literal master_address) + Printf.sprintf "%s://%s/" scheme + (Http.Url.maybe_wrap_IPv6_literal master_address) in [ (Xapi_vm_migrate._sm, sm_url) From 698f6e7630672e9fa75e98935a0e643415f0a60a Mon Sep 17 00:00:00 2001 From: Rob Hoes Date: Fri, 7 Oct 2022 16:26:30 +0000 Subject: [PATCH 4/8] Use HTTPS when redirecting storage calls The function is question redirects a local storage call to another host if the current host does not have access to the SR. This involves rewriting a localhost HTTP URL to a remote URL, which must be an HTTPS URL if storage migration is configured to use HTTPS. Signed-off-by: Rob Hoes --- ocaml/xapi/storage_migrate.ml | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/ocaml/xapi/storage_migrate.ml b/ocaml/xapi/storage_migrate.ml index b597bcb531f..3b8507fb76f 100644 --- a/ocaml/xapi/storage_migrate.ml +++ b/ocaml/xapi/storage_migrate.ml @@ -320,7 +320,9 @@ let rpc ~srcstr ~dststr (url, pool_secret) = let open Http.Url in match url with | Http h, d -> - ((Http {h with host= ip}, d), pool_secret) + ( (Http {h with host= ip; ssl= !Xapi_globs.migration_https_only}, d) + , pool_secret + ) | _ -> remote_url ip in From da27653889b8fe8d29451805068a259b6d11b6f4 Mon Sep 17 00:00:00 2001 From: Rob Hoes Date: Fri, 7 Oct 2022 16:27:26 +0000 Subject: [PATCH 5/8] Use HTTP for local storage calls Storage calls that are handled by the local host should always use HTTP, and not set up a connecting through stunnel. The SM URL that is passed to VM.migrate_send in the `dest` parameter, which comes from the return value of a call to host.migrate_receive, may be an HTTPS URL to the localhost, which needs to be rewritten upon receiving it. Signed-off-by: Rob Hoes --- ocaml/xapi/xapi_vm_migrate.ml | 12 +++++++++++- 1 file changed, 11 insertions(+), 1 deletion(-) diff --git a/ocaml/xapi/xapi_vm_migrate.ml b/ocaml/xapi/xapi_vm_migrate.ml index 5a7ed654815..10674bd1e73 100644 --- a/ocaml/xapi/xapi_vm_migrate.ml +++ b/ocaml/xapi/xapi_vm_migrate.ml @@ -109,7 +109,17 @@ let remote_of_dest ~__context dest = (* host unknown - this is a cross-pool migration *) Helpers.make_remote_rpc ~verify_cert:None remote_master_ip in - let sm_url = List.assoc _sm dest in + let sm_url = + let url = List.assoc _sm dest in + if Helpers.this_is_my_address ~__context remote_ip then + match Http.Url.of_string url with + | Http h, d -> + Http.Url.to_string (Http {h with Http.Url.ssl= false}, d) + | _ -> + url + else + url + in { rpc ; session= session_id From 65f95bddc0b6906787866af7f80d3a2a243d6cd6 Mon Sep 17 00:00:00 2001 From: Rob Hoes Date: Fri, 7 Oct 2022 16:28:41 +0000 Subject: [PATCH 6/8] Do not wait for stunnel disconnect When starting a mirroring process for a disk as part of a storage migration, xapi establishes the connection to the destination, but hands it over to tapdisk to do the actual mirroring over NBD. It is crucial that xapi just hands over the file descriptor and then continues with other business, without waiting for the connection to finish. This is how it works for TCP connections now. When switching to TLS connections, xapi starts an stunnel process as part of the connection setup, and hands over the stunnel fd to tapdisk. By default, this functionality then waits for stunnel to finish after the connection is eventually broken, thus introducing the unwanted blocking. We fix this by telling stunnel to disconnect, but not wait for this to actually happen. Signed-off-by: Rob Hoes --- ocaml/libs/http-svr/xmlrpc_client.ml | 4 ++-- ocaml/libs/http-svr/xmlrpc_client.mli | 3 ++- ocaml/xapi/storage_migrate.ml | 2 +- 3 files changed, 5 insertions(+), 4 deletions(-) diff --git a/ocaml/libs/http-svr/xmlrpc_client.ml b/ocaml/libs/http-svr/xmlrpc_client.ml index f60ee4de819..62e9ebaff77 100644 --- a/ocaml/libs/http-svr/xmlrpc_client.ml +++ b/ocaml/libs/http-svr/xmlrpc_client.ml @@ -304,7 +304,7 @@ let transport_of_url (scheme, _) = let port = Option.value ~default:443 h.port in SSL (SSL.make ~verify_cert:None (), h.host, port) -let with_transport transport f = +let with_transport ?(stunnel_wait_disconnect = true) transport f = match transport with | Unix path -> let fd = Unixext.open_connection_unix_fd path in @@ -373,7 +373,7 @@ let with_transport transport f = s_pid use_stunnel_cache ) else ( Unix.unlink st_proc.Stunnel.logfile ; - Stunnel.disconnect st_proc + Stunnel.disconnect ~wait:stunnel_wait_disconnect st_proc ) ) ) diff --git a/ocaml/libs/http-svr/xmlrpc_client.mli b/ocaml/libs/http-svr/xmlrpc_client.mli index f090fae4acc..66e1da40a13 100644 --- a/ocaml/libs/http-svr/xmlrpc_client.mli +++ b/ocaml/libs/http-svr/xmlrpc_client.mli @@ -46,7 +46,8 @@ val transport_of_url : Http.Url.t -> transport val string_of_transport : transport -> string (** [string_of_transport t] returns a debug-friendly version of [t] *) -val with_transport : transport -> (Unix.file_descr -> 'a) -> 'a +val with_transport : + ?stunnel_wait_disconnect:bool -> transport -> (Unix.file_descr -> 'a) -> 'a (** [with_transport transport f] calls [f fd] with [fd] connected via the requested [transport] *) diff --git a/ocaml/xapi/storage_migrate.ml b/ocaml/xapi/storage_migrate.ml index 3b8507fb76f..3b87e6b4b53 100644 --- a/ocaml/xapi/storage_migrate.ml +++ b/ocaml/xapi/storage_migrate.ml @@ -724,7 +724,7 @@ let start' ~task ~dbg ~sr ~vdi ~dp ~url ~dest = | Some tapdev -> let pid = Tapctl.get_tapdisk_pid tapdev in let path = Printf.sprintf "/var/run/blktap-control/nbdclient%d" pid in - with_transport transport + with_transport ~stunnel_wait_disconnect:false transport (with_http request (fun (_response, s) -> let control_fd = Unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in finally From 7120b89f069fdfc1b8f4c444339384b8ff049183 Mon Sep 17 00:00:00 2001 From: Rob Hoes Date: Wed, 12 Oct 2022 12:14:41 +0000 Subject: [PATCH 7/8] Named arguments in Xapi_vm_migrate.migrate_with_retry Signed-off-by: Rob Hoes --- ocaml/xapi/xapi_vm_migrate.ml | 28 +++++++++++++++------------- 1 file changed, 15 insertions(+), 13 deletions(-) diff --git a/ocaml/xapi/xapi_vm_migrate.ml b/ocaml/xapi/xapi_vm_migrate.ml index 10674bd1e73..724cdf2a095 100644 --- a/ocaml/xapi/xapi_vm_migrate.ml +++ b/ocaml/xapi/xapi_vm_migrate.ml @@ -241,8 +241,9 @@ let assert_can_migrate_vdis ~__context ~vdi_map = let assert_licensed_storage_motion ~__context = Pool_features.assert_enabled ~__context ~f:Features.Storage_motion -let rec migrate_with_retries ~__context queue_name max try_no dbg vm_uuid - xenops_vdi_map xenops_vif_map xenops_vgpu_map xenops compress verify_cert = +let rec migrate_with_retries ~__context ~queue_name ~max ~try_no ~dbg ~vm_uuid + ~xenops_vdi_map ~xenops_vif_map ~xenops_vgpu_map ~xenops_url ~compress + ~verify_cert = let open Xapi_xenops_queue in let module Client = (val make_client queue_name : XENOPS) in let progress = ref "(none yet)" in @@ -250,7 +251,7 @@ let rec migrate_with_retries ~__context queue_name max try_no dbg vm_uuid progress := "Client.VM.migrate" ; let t1 = Client.VM.migrate dbg vm_uuid xenops_vdi_map xenops_vif_map - xenops_vgpu_map xenops compress verify_cert + xenops_vgpu_map xenops_url compress verify_cert in progress := "sync_with_task" ; ignore (Xapi_xenops.sync_with_task __context queue_name t1) @@ -275,9 +276,9 @@ let rec migrate_with_retries ~__context queue_name max try_no dbg vm_uuid debug "xenops: will retry migration: caught %s from %s in attempt %d of %d." (Printexc.to_string e) !progress try_no max ; - migrate_with_retries ~__context queue_name max (try_no + 1) dbg vm_uuid - xenops_vdi_map xenops_vif_map xenops_vgpu_map xenops compress - verify_cert + migrate_with_retries ~__context ~queue_name ~max ~try_no:(try_no + 1) + ~dbg ~vm_uuid ~xenops_vdi_map ~xenops_vif_map ~xenops_vgpu_map + ~xenops_url ~compress ~verify_cert (* Something else went wrong *) | e -> debug @@ -286,8 +287,8 @@ let rec migrate_with_retries ~__context queue_name max try_no dbg vm_uuid (Printexc.to_string e) !progress try_no max ; raise e -let migrate_with_retry ~__context queue_name = - migrate_with_retries ~__context queue_name 3 1 +let migrate_with_retry ~__context ~queue_name = + migrate_with_retries ~__context ~queue_name ~max:3 ~try_no:1 (** detach the network of [vm] if it is migrating away to [destination] *) let detach_local_network_for_vm ~__context ~vm ~destination = @@ -414,8 +415,9 @@ let pool_migrate ~__context ~vm ~host ~options = info "xenops: VM.migrate %s to %s" vm_uuid xenops_url ; Xapi_xenops.transform_xenops_exn ~__context ~vm queue_name (fun () -> - migrate_with_retry ~__context queue_name dbg vm_uuid [] [] - xenops_vgpu_map xenops_url compress true ; + migrate_with_retry ~__context ~queue_name ~dbg ~vm_uuid + ~xenops_vdi_map:[] ~xenops_vif_map:[] ~xenops_vgpu_map + ~xenops_url ~compress ~verify_cert:true ; (* Delete all record of this VM locally (including caches) *) Xapi_xenops.Xenopsd_metadata.delete ~__context vm_uuid ) @@ -1507,9 +1509,9 @@ let migrate_send' ~__context ~vm ~dest ~live:_ ~vdi_map ~vif_map ~vgpu_map infer_vgpu_map ~__context ~remote new_vm in let verify_cert = is_intra_pool in - migrate_with_retry ~__context queue_name dbg vm_uuid - xenops_vdi_map xenops_vif_map xenops_vgpu_map remote.xenops_url - compress verify_cert ; + migrate_with_retry ~__context ~queue_name ~dbg ~vm_uuid + ~xenops_vdi_map ~xenops_vif_map ~xenops_vgpu_map + ~xenops_url:remote.xenops_url ~compress ~verify_cert ; Xapi_xenops.Xenopsd_metadata.delete ~__context vm_uuid ) with From a50df660096d25be0b6c9df4b9af712a0a3f793c Mon Sep 17 00:00:00 2001 From: Rob Hoes Date: Wed, 12 Oct 2022 12:18:02 +0000 Subject: [PATCH 8/8] Named arguments in Xn.migrate Signed-off-by: Rob Hoes --- ocaml/xenopsd/cli/xn.ml | 13 ++++++------- 1 file changed, 6 insertions(+), 7 deletions(-) diff --git a/ocaml/xenopsd/cli/xn.ml b/ocaml/xenopsd/cli/xn.ml index e5c64791484..3ab2e34246f 100644 --- a/ocaml/xenopsd/cli/xn.ml +++ b/ocaml/xenopsd/cli/xn.ml @@ -1013,9 +1013,8 @@ let resume _copts disk x = let resume copts disk x = diagnose_error (need_vm (resume copts disk) x) -let migrate x url compress verify_cert = - let open Vm in - let vm, _ = find_by_name x in +let migrate ~id ~url ~compress ~verify_cert = + let vm, _ = find_by_name id in let bool b = match String.lowercase_ascii b with | "t" | "true" | "on" | "1" -> @@ -1023,7 +1022,7 @@ let migrate x url compress verify_cert = | _ -> false in - Client.VM.migrate dbg vm.id [] [] [] url (bool compress) (bool verify_cert) + Client.VM.migrate dbg vm.Vm.id [] [] [] url (bool compress) (bool verify_cert) |> wait_for_task dbg let trim limit str = @@ -1542,11 +1541,11 @@ let old_main () = | ["help"] | [] -> usage () ; exit 0 | ["migrate"; id; url] -> - migrate id url "false" "false" |> task + migrate ~id ~url ~compress:"false" ~verify_cert:"false" |> task | ["migrate"; id; url; compress] -> - migrate id url compress "false" |> task + migrate ~id ~url ~compress ~verify_cert:"false" |> task | ["migrate"; id; url; compress; verify_cert] -> - migrate id url compress verify_cert |> task + migrate ~id ~url ~compress ~verify_cert |> task | ["vbd-list"; id] -> vbd_list id | ["pci-add"; id; idx; bdf] ->