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-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/storage_migrate.ml b/ocaml/xapi/storage_migrate.ml index b597bcb531f..3b87e6b4b53 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 @@ -722,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 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_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) diff --git a/ocaml/xapi/xapi_vm_migrate.ml b/ocaml/xapi/xapi_vm_migrate.ml index 0dc3d74fcee..724cdf2a095 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 @@ -231,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 = +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 @@ -240,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 + xenops_vgpu_map xenops_url compress verify_cert in progress := "sync_with_task" ; ignore (Xapi_xenops.sync_with_task __context queue_name t1) @@ -265,8 +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 + 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 @@ -275,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 = @@ -378,8 +390,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 @@ -402,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 ; + 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 ) @@ -1494,9 +1508,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 - migrate_with_retry ~__context queue_name dbg vm_uuid - xenops_vdi_map xenops_vif_map xenops_vgpu_map remote.xenops_url - compress ; + 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 + ~xenops_url:remote.xenops_url ~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..3ab2e34246f 100644 --- a/ocaml/xenopsd/cli/xn.ml +++ b/ocaml/xenopsd/cli/xn.ml @@ -1013,17 +1013,17 @@ let resume _copts disk x = let resume copts disk x = diagnose_error (need_vm (resume copts disk) x) -let migrate x url compress = - let open Vm in - let vm, _ = find_by_name x in - let compress = - match String.lowercase_ascii compress with +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" -> true | _ -> false in - Client.VM.migrate dbg vm.id [] [] [] url compress |> wait_for_task dbg + Client.VM.migrate dbg vm.Vm.id [] [] [] url (bool compress) (bool verify_cert) + |> wait_for_task dbg let trim limit str = let l = String.length str in @@ -1541,9 +1541,11 @@ let old_main () = | ["help"] | [] -> usage () ; exit 0 | ["migrate"; id; url] -> - migrate id url "false" |> task + migrate ~id ~url ~compress:"false" ~verify_cert:"false" |> task | ["migrate"; id; url; compress] -> - migrate id url compress |> task + migrate ~id ~url ~compress ~verify_cert:"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..3ff8c8d26db 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,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 - Open_uri.with_open_uri url (fun vm_fd -> + 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 = @@ -2539,7 +2545,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,8 +2574,9 @@ 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 -> - Sockopt.set_sock_keepalives vgpu_fd ; + Open_uri.with_open_uri ~verify_cert url (fun 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" ; @@ -3382,7 +3389,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 +3405,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 } )