Merge pull request #4816 from robhoes/https-migration

Migration over HTTPS

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
               )
             )
       )

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] *)
 

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
         )
 

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

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)

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)

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,16 +241,17 @@ 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
   let f () =
     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

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] ->

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
          }
       )