Skip to content

Commit

Permalink
CA-390277: Stop using records on CLI cross-pool migrations
Browse files Browse the repository at this point in the history 
Using records in cross-pool migration code is dangerous, as the code interacts
with potentially newer hosts. This means that fields in the record might be
different from what's expected. In particular adding an enum field can break
the deserialization, and removing a field as well.

The tradeoff here is that there are more remote roundtrips to get the
data needed.

Signed-off-by: Pau Ruiz Safont <[email protected]>
  • Loading branch information
@psafont
psafont committed Jun 18, 2024
1 parent 2e39039 commit 5abccbf
Showing 1 changed file with 139 additions and 69 deletions.
208 changes: 139 additions & 69 deletions ocaml/xapi-cli-server/cli_operations.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -4312,54 +4312,98 @@ let vm_migrate printer rpc session_id params =
in
finally
(fun () ->
let host, host_record =
let all = Client.Host.get_all_records remote_rpc remote_session in
if List.mem_assoc "host" params then
let x = List.assoc "host" params in
try
List.find
(fun (_, h) ->
h.API.host_hostname = x
|| h.API.host_name_label = x
|| h.API.host_uuid = x
let host =
let host_matches x self =
let hostname () =
Client.Host.get_hostname ~rpc:remote_rpc
~session_id:remote_session ~self
in
let uuid () =
Client.Host.get_uuid ~rpc:remote_rpc ~session_id:remote_session
~self
in
let name_label () =
Client.Host.get_name_label ~rpc:remote_rpc
~session_id:remote_session ~self
in
hostname () = x || uuid () = x || name_label () = x
in
let matches, fail_msg =
match List.assoc_opt "host" params with
| Some x ->
(host_matches x, Printf.sprintf "Failed to find host: %s" x)
| None ->
( (fun _ -> true)
, Printf.sprintf "Failed to find a suitable host"
)
all
with Not_found ->
failwith (Printf.sprintf "Failed to find host: %s" x)
else
List.hd all
in
let all_hosts =
Client.Host.get_all ~rpc:remote_rpc ~session_id:remote_session
in
match List.filter matches all_hosts with
| host :: _ ->
host
| [] ->
failwith fail_msg
in
let network, network_record =
let all = Client.Network.get_all_records remote_rpc remote_session in
if List.mem_assoc "remote-network" params then
let x = List.assoc "remote-network" params in
try
List.find
(fun (_, net) ->
net.API.network_bridge = x
|| net.API.network_name_label = x
|| net.API.network_uuid = x
)
all
with Not_found ->
failwith (Printf.sprintf "Failed to find network: %s" x)
else
let pifs = host_record.API.host_PIFs in
let management_pifs =
List.filter
(fun pif ->
Client.PIF.get_management remote_rpc remote_session pif
)
pifs
let network =
let network_matches x self =
let bridge () =
Client.Network.get_bridge ~rpc:remote_rpc
~session_id:remote_session ~self
in
if List.length management_pifs = 0 then
failwith
(Printf.sprintf "Could not find management PIF on host %s"
host_record.API.host_uuid
) ;
let pif = List.hd management_pifs in
let net = Client.PIF.get_network remote_rpc remote_session pif in
(net, Client.Network.get_record remote_rpc remote_session net)
let uuid () =
Client.Network.get_uuid ~rpc:remote_rpc ~session_id:remote_session
~self
in
let name_label () =
Client.Network.get_name_label ~rpc:remote_rpc
~session_id:remote_session ~self
in
bridge () = x || uuid () = x || name_label () = x
in
match List.assoc_opt "remote-network" params with
| Some x -> (
let all_networks =
Client.Network.get_all ~rpc:remote_rpc
~session_id:remote_session
in
match List.filter (network_matches x) all_networks with
| network :: _ ->
network
| [] ->
failwith (Printf.sprintf "Failed to find network: %s" x)
)
| None -> (
let pifs =
Client.Host.get_PIFs ~rpc:remote_rpc ~session_id:remote_session
~self:host
in
let management_pifs =
List.filter
(fun self ->
Client.PIF.get_management ~rpc:remote_rpc
~session_id:remote_session ~self
)
pifs
in
match management_pifs with
| [] ->
let host_uuid =
Client.Host.get_uuid ~rpc:remote_rpc
~session_id:remote_session ~self:host
in
failwith
(Printf.sprintf "Could not find management PIF on host %s"
host_uuid
)
| pif :: _ ->
let net =
Client.PIF.get_network ~rpc:remote_rpc
~session_id:remote_session ~self:pif
in
net
)
in
let vif_map =
List.map
Expand Down Expand Up @@ -4400,43 +4444,62 @@ let vm_migrate printer rpc session_id params =
and among the choices of that the shared is preferred first(as it is recommended to have shared storage
in pool to host VMs), and then the one with the maximum available space *)
try
let query =
Printf.sprintf
{|(field "host"="%s") and (field "currently_attached"="true")|}
(Ref.string_of host)
in
let host_pbds =
Client.PBD.get_all_records_where remote_rpc remote_session query
let pbd_in_host self =
let host_of () =
Client.PBD.get_host ~rpc:remote_rpc ~session_id:remote_session
~self
in
let attached () =
Client.PBD.get_currently_attached ~rpc:remote_rpc
~session_id:remote_session ~self
in
host_of () = host && attached ()
in
let srs =
List.map
(fun (pbd_ref, pbd_rec) ->
( pbd_rec.API.pBD_SR
, Client.SR.get_record remote_rpc remote_session
pbd_rec.API.pBD_SR
)
)
host_pbds
Client.PBD.get_all ~rpc:remote_rpc ~session_id:remote_session
|> List.filter pbd_in_host
|> List.map (fun self ->
Client.PBD.get_SR ~rpc:remote_rpc
~session_id:remote_session ~self
)
in
(* In the following loop, the current SR:sr' will be compared with previous checked ones,
first if it is an ISO type, then pass this one for selection, then the only shared one from this and
previous one will be valued, and if not that case (both shared or none shared), choose the one with
more space available *)
let is_iso self =
let typ =
Client.SR.get_content_type ~rpc:remote_rpc
~session_id:remote_session ~self
in
typ = "iso"
in
let physical_size self =
Client.SR.get_physical_size ~rpc:remote_rpc
~session_id:remote_session ~self
in
let physical_utilisation self =
Client.SR.get_physical_utilisation ~rpc:remote_rpc
~session_id:remote_session ~self
in
let shared self =
Client.SR.get_shared ~rpc:remote_rpc ~session_id:remote_session
~self
in
let sr, _ =
List.fold_left
(fun (sr, free_space) ((_, sr_rec') as sr') ->
if sr_rec'.API.sR_content_type = "iso" then
(fun (sr, free_space) sr' ->
if is_iso sr' then
(sr, free_space)
else
let free_space' =
Int64.sub sr_rec'.API.sR_physical_size
sr_rec'.API.sR_physical_utilisation
Int64.sub (physical_size sr') (physical_utilisation sr')
in
match sr with
| None ->
(Some sr', free_space')
| Some ((_, sr_rec) as sr) -> (
match (sr_rec.API.sR_shared, sr_rec'.API.sR_shared) with
| Some sr -> (
match (shared sr, shared sr') with
| true, false ->
(Some sr, free_space)
| false, true ->
Expand All @@ -4450,7 +4513,7 @@ let vm_migrate printer rpc session_id params =
)
(None, Int64.zero) srs
in
match sr with Some (sr_ref, _) -> Some sr_ref | _ -> None
sr
with _ -> None
in
let vdi_map =
Expand Down Expand Up @@ -4509,13 +4572,20 @@ let vm_migrate printer rpc session_id params =
)
params
in
let host_name_label =
Client.Host.get_name_label ~rpc:remote_rpc ~session_id:remote_session
~self:host
in
let network_name_label =
Client.Network.get_name_label ~rpc:remote_rpc
~session_id:remote_session ~self:network
in
printer
(Cli_printer.PMsg
(Printf.sprintf
"Will migrate to remote host: %s, using remote network: %s. \
Here is the VDI mapping:"
host_record.API.host_name_label
network_record.API.network_name_label
host_name_label network_name_label
)
) ;
List.iter
Expand Down

0 comments on commit 5abccbf

Please sign in to comment.