exception ExitWithError of int
let bool_of_string param string =
- let s = String.lowercase string in
- match s with
- "true" -> true
- | "t" -> true
- | "1" -> true
- | "false" -> false
- | "f" -> false
- | "0" -> false
- | _ -> failwith ("Failed to parse parameter '"^param^"': expecting 'true' or 'false'")
+ let s = String.lowercase string in
+ match s with
+ "true" -> true
+ | "t" -> true
+ | "1" -> true
+ | "false" -> false
+ | "f" -> false
+ | "0" -> false
+ | _ -> failwith ("Failed to parse parameter '"^param^"': expecting 'true' or 'false'")
let get_bool_param params ?(default = false) param =
if List.mem_assoc param params
open Client
- (* Return the list of k=v pairs for maps *)
+(* Return the list of k=v pairs for maps *)
let read_map_params name params =
- let len = String.length name + 1 in (* include ':' *)
- let filter_params = List.filter (fun (p,_) -> (String.startswith name p) && (String.length p > len)) params in
- List.map (fun (k,v) -> String.sub k len (String.length k - len),v) filter_params
+ let len = String.length name + 1 in (* include ':' *)
+ let filter_params = List.filter (fun (p,_) -> (String.startswith name p) && (String.length p > len)) params in
+ List.map (fun (k,v) -> String.sub k len (String.length k - len),v) filter_params
let get_chunks fd =
- let buffer = Buffer.create 10240 in
- let rec f () =
- match unmarshal fd with
- | Blob (Chunk len) ->
- debug "Reading a chunk of %ld bytes" len;
- let data = really_read fd (Int32.to_int len) in
- Buffer.add_string buffer data;
- f()
- | Blob End ->
- Buffer.contents buffer
- | _ ->
- failwith "Thin CLI protocol error"
- in
- f()
+ let buffer = Buffer.create 10240 in
+ let rec f () =
+ match unmarshal fd with
+ | Blob (Chunk len) ->
+ debug "Reading a chunk of %ld bytes" len;
+ let data = really_read fd (Int32.to_int len) in
+ Buffer.add_string buffer data;
+ f()
+ | Blob End ->
+ Buffer.contents buffer
+ | _ ->
+ failwith "Thin CLI protocol error"
+ in
+ f()
let get_client_file fd filename =
- marshal fd (Command (Load filename));
- match unmarshal fd with
- | Response OK ->
- Some (get_chunks fd)
- | Response Failed ->
- None
- | _ ->
- failwith "Thin CLI protocol error"
+ marshal fd (Command (Load filename));
+ match unmarshal fd with
+ | Response OK ->
+ Some (get_chunks fd)
+ | Response Failed ->
+ None
+ | _ ->
+ failwith "Thin CLI protocol error"
let diagnostic_compact printer rpc session_id params =
- Gc.compact ()
+ Gc.compact ()
let diagnostic_gc_stats printer rpc session_id params =
- let stat = Gc.stat () in
- let table =
- ["minor_words",string_of_float stat.Gc.minor_words;
- "promoted_words",string_of_float stat.Gc.promoted_words;
- "major_words",string_of_float stat.Gc.major_words;
- "minor_collections",string_of_int stat.Gc.minor_collections;
- "major_collections",string_of_int stat.Gc.major_collections;
- "heap_words",string_of_int stat.Gc.heap_words;
- "heap_chunks",string_of_int stat.Gc.heap_chunks;
- "live_words",string_of_int stat.Gc.live_words;
- "live_blocks",string_of_int stat.Gc.live_blocks;
- "free_words",string_of_int stat.Gc.free_words;
- "free_blocks",string_of_int stat.Gc.free_blocks;
- "largest_free",string_of_int stat.Gc.largest_free;
- "fragments",string_of_int stat.Gc.fragments;
- "compactions",string_of_int stat.Gc.compactions;
- "top_heap_words",string_of_int stat.Gc.top_heap_words;
- ] in
- printer (Cli_printer.PTable [table])
+ let stat = Gc.stat () in
+ let table =
+ ["minor_words",string_of_float stat.Gc.minor_words;
+ "promoted_words",string_of_float stat.Gc.promoted_words;
+ "major_words",string_of_float stat.Gc.major_words;
+ "minor_collections",string_of_int stat.Gc.minor_collections;
+ "major_collections",string_of_int stat.Gc.major_collections;
+ "heap_words",string_of_int stat.Gc.heap_words;
+ "heap_chunks",string_of_int stat.Gc.heap_chunks;
+ "live_words",string_of_int stat.Gc.live_words;
+ "live_blocks",string_of_int stat.Gc.live_blocks;
+ "free_words",string_of_int stat.Gc.free_words;
+ "free_blocks",string_of_int stat.Gc.free_blocks;
+ "largest_free",string_of_int stat.Gc.largest_free;
+ "fragments",string_of_int stat.Gc.fragments;
+ "compactions",string_of_int stat.Gc.compactions;
+ "top_heap_words",string_of_int stat.Gc.top_heap_words;
+ ] in
+ printer (Cli_printer.PTable [table])
let diagnostic_timing_stats printer rpc session_id params =
- let table_of_host host =
- [ "host-uuid", Client.Host.get_uuid rpc session_id host;
- "host-name-label", Client.Host.get_name_label rpc session_id host ] @
- (try
- Client.Host.get_diagnostic_timing_stats rpc session_id host
- with e ->
- [ "Error", Api_errors.to_string e ]) in
- let all = List.map table_of_host (Client.Host.get_all rpc session_id) in
+ let table_of_host host =
+ [ "host-uuid", Client.Host.get_uuid rpc session_id host;
+ "host-name-label", Client.Host.get_name_label rpc session_id host ] @
+ (try
+ Client.Host.get_diagnostic_timing_stats rpc session_id host
+ with e ->
+ [ "Error", Api_errors.to_string e ]) in
+ let all = List.map table_of_host (Client.Host.get_all rpc session_id) in
- printer (Cli_printer.PTable all)
+ printer (Cli_printer.PTable all)
let diagnostic_db_stats printer rpc session_id params =
- let (n,avgtime,min,max) = Db_lock.report () in
- let (writes,reads,creates,drops,tasks,threads) = Stats.summarise_db_calls () in
- printer (Cli_printer.PMsg (Printf.sprintf "DB lock stats: n=%d avgtime=%f min=%f max=%f" n avgtime min max));
- printer (Cli_printer.PMsg "Reads:");
- printer (Cli_printer.PList reads);
- printer (Cli_printer.PMsg "Writes:");
- printer (Cli_printer.PList writes);
- printer (Cli_printer.PMsg "Creates:");
- printer (Cli_printer.PList creates);
- printer (Cli_printer.PMsg "Drops:");
- printer (Cli_printer.PList drops);
- printer (Cli_printer.PMsg "Tasks:");
- printer (Cli_printer.PTable (List.map (fun (name,ops)-> ("task",name)::ops) (List.sort (fun (t1,ops1) (t2,ops2)-> compare (List.length ops2) (List.length ops1)) tasks)));
- printer (Cli_printer.PMsg "Threads:");
- printer (Cli_printer.PTable (List.map (fun (id,ops)-> ("thread",string_of_int id)::ops) threads))
+ let (n,avgtime,min,max) = Db_lock.report () in
+ let (writes,reads,creates,drops,tasks,threads) = Stats.summarise_db_calls () in
+ printer (Cli_printer.PMsg (Printf.sprintf "DB lock stats: n=%d avgtime=%f min=%f max=%f" n avgtime min max));
+ printer (Cli_printer.PMsg "Reads:");
+ printer (Cli_printer.PList reads);
+ printer (Cli_printer.PMsg "Writes:");
+ printer (Cli_printer.PList writes);
+ printer (Cli_printer.PMsg "Creates:");
+ printer (Cli_printer.PList creates);
+ printer (Cli_printer.PMsg "Drops:");
+ printer (Cli_printer.PList drops);
+ printer (Cli_printer.PMsg "Tasks:");
+ printer (Cli_printer.PTable (List.map (fun (name,ops)-> ("task",name)::ops) (List.sort (fun (t1,ops1) (t2,ops2)-> compare (List.length ops2) (List.length ops1)) tasks)));
+ printer (Cli_printer.PMsg "Threads:");
+ printer (Cli_printer.PTable (List.map (fun (id,ops)-> ("thread",string_of_int id)::ops) threads))
let diagnostic_db_log printer rpc session_id params =
- Stats.log_stats := true;
- printer (Cli_printer.PMsg "Database/task statistics gathering enabled. Warning, this never releases memory! Restart xapi to reset.")
+ Stats.log_stats := true;
+ printer (Cli_printer.PMsg "Database/task statistics gathering enabled. Warning, this never releases memory! Restart xapi to reset.")
type host_license = {
- hostname: string;
- uuid: string;
- rstr: Features.feature list;
- license: License.license
+ hostname: string;
+ uuid: string;
+ rstr: Features.feature list;
+ license: License.license
}
let host_license_of_r host_r =
- let params = host_r.API.host_license_params in
- let rstr = Features.of_assoc_list params in
- let license = License.of_assoc_list params in
- { hostname = host_r.API.host_hostname;
- uuid = host_r.API.host_uuid;
- rstr = rstr;
- license = license }
+ let params = host_r.API.host_license_params in
+ let rstr = Features.of_assoc_list params in
+ let license = License.of_assoc_list params in
+ { hostname = host_r.API.host_hostname;
+ uuid = host_r.API.host_uuid;
+ rstr = rstr;
+ license = license }
let diagnostic_license_status printer rpc session_id params =
- let hosts = Client.Host.get_all_records rpc session_id in
- let heading = [ "Hostname"; "UUID"; "Features"; "Code"; "Free"; "Expiry"; "Days left" ] in
-
- let valid, invalid = List.partition (fun (_, host_r) -> try ignore(host_license_of_r host_r); true with _ -> false) hosts in
- let host_licenses = List.map (fun (_, host_r) -> host_license_of_r host_r) valid in
- (* Sort licenses into nearest-expiry first then free *)
- let host_licenses = List.sort (fun a b ->
- let a_expiry = a.license.License.expiry and b_expiry = b.license.License.expiry in
- let a_free = (Edition.of_string a.license.License.sku) = Edition.Free
- and b_free = (Edition.of_string b.license.License.sku) = Edition.Free in
- if a_expiry < b_expiry then -1
- else
- if a_expiry > b_expiry then 1
- else
- if a_free && not b_free then -1
- else
- if not a_free && b_free then 1
- else 0) host_licenses in
- let now = Unix.gettimeofday () in
- let hosts = List.map (fun h -> [ h.hostname;
- String.sub h.uuid 0 8;
- Features.to_compact_string h.rstr;
- Edition.to_short_string (Edition.of_string h.license.License.sku);
- string_of_bool ((Edition.of_string h.license.License.sku) = Edition.Free);
- Date.to_string (Date.of_float h.license.License.expiry);
- Printf.sprintf "%.1f" ((h.license.License.expiry -. now) /. (24. *. 60. *. 60.));
- ]) host_licenses in
- let invalid_hosts = List.map (fun (_, host_r) -> [ host_r.API.host_hostname;
- String.sub host_r.API.host_uuid 0 8;
- "-"; "-"; "-"; "-"; "-" ]) invalid in
- let __context = Context.make "diagnostic_license_status" in
- let pool = List.hd (Db.Pool.get_all ~__context) in
- let pool_features = Features.of_assoc_list (Db.Pool.get_restrictions ~__context ~self:pool) in
- let pool_free = List.fold_left (||) false (List.map (fun h -> (Edition.of_string h.license.License.sku) = Edition.Free) host_licenses) in
- let divider = [ "-"; "-"; "-"; "-"; "-"; "-"; "-" ] in
- let pool = [ "-"; "-"; Features.to_compact_string pool_features; "-"; string_of_bool pool_free; "-"; "-" ] in
- let table = heading :: divider :: hosts @ invalid_hosts @ [ divider; pool ] in
-
- (* Compute the required column widths *)
- let rec transpose x =
- if List.filter (fun x -> x <> []) x = []
- then []
- else
- let heads = List.map List.hd x in
- let tails = List.map List.tl x in
- heads :: (transpose tails) in
- let map f x = List.map (List.map f) x in
- let column_sizes = List.map (List.fold_left max 0) (transpose (map String.length table)) in
-
- List.iter
- (fun row ->
- printer (Cli_printer.PMsg (String.concat " " (List.map (fun (data, len) -> data ^ (String.make (len - String.length data) ' ')) (List.combine row column_sizes))))
- ) table
+ let hosts = Client.Host.get_all_records rpc session_id in
+ let heading = [ "Hostname"; "UUID"; "Features"; "Code"; "Free"; "Expiry"; "Days left" ] in
+
+ let valid, invalid = List.partition (fun (_, host_r) -> try ignore(host_license_of_r host_r); true with _ -> false) hosts in
+ let host_licenses = List.map (fun (_, host_r) -> host_license_of_r host_r) valid in
+ (* Sort licenses into nearest-expiry first then free *)
+ let host_licenses = List.sort (fun a b ->
+ let a_expiry = a.license.License.expiry and b_expiry = b.license.License.expiry in
+ let a_free = (Edition.of_string a.license.License.sku) = Edition.Free
+ and b_free = (Edition.of_string b.license.License.sku) = Edition.Free in
+ if a_expiry < b_expiry then -1
+ else
+ if a_expiry > b_expiry then 1
+ else
+ if a_free && not b_free then -1
+ else
+ if not a_free && b_free then 1
+ else 0) host_licenses in
+ let now = Unix.gettimeofday () in
+ let hosts = List.map (fun h -> [ h.hostname;
+ String.sub h.uuid 0 8;
+ Features.to_compact_string h.rstr;
+ Edition.to_short_string (Edition.of_string h.license.License.sku);
+ string_of_bool ((Edition.of_string h.license.License.sku) = Edition.Free);
+ Date.to_string (Date.of_float h.license.License.expiry);
+ Printf.sprintf "%.1f" ((h.license.License.expiry -. now) /. (24. *. 60. *. 60.));
+ ]) host_licenses in
+ let invalid_hosts = List.map (fun (_, host_r) -> [ host_r.API.host_hostname;
+ String.sub host_r.API.host_uuid 0 8;
+ "-"; "-"; "-"; "-"; "-" ]) invalid in
+ let __context = Context.make "diagnostic_license_status" in
+ let pool = List.hd (Db.Pool.get_all ~__context) in
+ let pool_features = Features.of_assoc_list (Db.Pool.get_restrictions ~__context ~self:pool) in
+ let pool_free = List.fold_left (||) false (List.map (fun h -> (Edition.of_string h.license.License.sku) = Edition.Free) host_licenses) in
+ let divider = [ "-"; "-"; "-"; "-"; "-"; "-"; "-" ] in
+ let pool = [ "-"; "-"; Features.to_compact_string pool_features; "-"; string_of_bool pool_free; "-"; "-" ] in
+ let table = heading :: divider :: hosts @ invalid_hosts @ [ divider; pool ] in
+
+ (* Compute the required column widths *)
+ let rec transpose x =
+ if List.filter (fun x -> x <> []) x = []
+ then []
+ else
+ let heads = List.map List.hd x in
+ let tails = List.map List.tl x in
+ heads :: (transpose tails) in
+ let map f x = List.map (List.map f) x in
+ let column_sizes = List.map (List.fold_left max 0) (transpose (map String.length table)) in
+
+ List.iter
+ (fun row ->
+ printer (Cli_printer.PMsg (String.concat " " (List.map (fun (data, len) -> data ^ (String.make (len - String.length data) ' ')) (List.combine row column_sizes))))
+ ) table
let get_hosts_by_name_or_id rpc session_id name =
- let hosts = Client.Host.get_all_records_where rpc session_id "true" in
- let allrecs = List.map (fun (host,host_r) -> let r = host_record rpc session_id host in r.setrefrec (host,host_r); r) hosts in
- let hosts = List.filter
- (fun x -> (safe_get_field (field_lookup x.fields "name-label") = name
- || (safe_get_field (field_lookup x.fields "uuid") = name))) allrecs in
- hosts
+ let hosts = Client.Host.get_all_records_where rpc session_id "true" in
+ let allrecs = List.map (fun (host,host_r) -> let r = host_record rpc session_id host in r.setrefrec (host,host_r); r) hosts in
+ let hosts = List.filter
+ (fun x -> (safe_get_field (field_lookup x.fields "name-label") = name
+ || (safe_get_field (field_lookup x.fields "uuid") = name))) allrecs in
+ hosts
let get_host_by_name_or_id rpc session_id name =
- let hosts = get_hosts_by_name_or_id rpc session_id name in
- if List.length hosts = 0 then (failwith ("Host "^name^" not found"));
- List.nth hosts 0
+ let hosts = get_hosts_by_name_or_id rpc session_id name in
+ if List.length hosts = 0 then (failwith ("Host "^name^" not found"));
+ List.nth hosts 0
let get_host_from_session rpc session_id =
- Client.Session.get_this_host rpc session_id session_id
+ Client.Session.get_this_host rpc session_id session_id
(* Create a VBD record in database and attempt to hotplug it, ignoring hotplug errors *)
let create_vbd_and_plug_with_other_config rpc session_id vm vdi device_name bootable rw cd unpluggable qtype qparams other_config =
- let vbd = Client.VBD.create ~rpc ~session_id ~vM:vm ~vDI:vdi ~userdevice:device_name ~bootable ~mode:rw
- ~_type:cd ~unpluggable ~empty:false ~qos_algorithm_type:qtype ~qos_algorithm_params:qparams ~other_config in
- try Client.VBD.plug rpc session_id vbd
- with Api_errors.Server_error(_, _) as e ->
- debug "VBD created but not hotplugged: %s" (Api_errors.to_string e)
+ let vbd = Client.VBD.create ~rpc ~session_id ~vM:vm ~vDI:vdi ~userdevice:device_name ~bootable ~mode:rw
+ ~_type:cd ~unpluggable ~empty:false ~qos_algorithm_type:qtype ~qos_algorithm_params:qparams ~other_config in
+ try Client.VBD.plug rpc session_id vbd
+ with Api_errors.Server_error(_, _) as e ->
+ debug "VBD created but not hotplugged: %s" (Api_errors.to_string e)
let create_vbd_and_plug rpc session_id vm vdi device_name bootable rw cd unpluggable qtype qparams =
- create_vbd_and_plug_with_other_config rpc session_id vm vdi device_name bootable rw cd unpluggable qtype qparams []
+ create_vbd_and_plug_with_other_config rpc session_id vm vdi device_name bootable rw cd unpluggable qtype qparams []
let create_owner_vbd_and_plug rpc session_id vm vdi device_name bootable rw cd unpluggable qtype qparams =
- create_vbd_and_plug_with_other_config rpc session_id vm vdi device_name bootable rw cd unpluggable qtype qparams [Xapi_globs.owner_key,""]
+ create_vbd_and_plug_with_other_config rpc session_id vm vdi device_name bootable rw cd unpluggable qtype qparams [Xapi_globs.owner_key,""]
(* ---------------------------------------------------------------------
(* Temporary hack for logging *)
let log_set_output printer _ session_id params =
- let logger = List.assoc "output" params in
- try
- let key = List.assoc "key" params in
- Log.validate logger;
- let level = try List.assoc "level" params with _ -> "all" in
- if level="all" then
- (Logs.add key [logger];
- printer (Cli_printer.PList ["Setting all logging output for key "^key^" to logger: "^logger]))
- else
- (let loglevel = Log.level_of_string level in
- Logs.set key loglevel [logger];
- printer (Cli_printer.PList ["Setting logging output at level "^level^" for key "^key^" to logger: "^logger]))
- with
- | Log.Unknown_level x -> failwith ("Unknown logging level "^x)
- | Not_found ->
- Logs.reset_all [ logger ];
- printer (Cli_printer.PList ["Resetting all logging output to logger: "^logger])
+ let logger = List.assoc "output" params in
+ try
+ let key = List.assoc "key" params in
+ Log.validate logger;
+ let level = try List.assoc "level" params with _ -> "all" in
+ if level="all" then
+ (Logs.add key [logger];
+ printer (Cli_printer.PList ["Setting all logging output for key "^key^" to logger: "^logger]))
+ else
+ (let loglevel = Log.level_of_string level in
+ Logs.set key loglevel [logger];
+ printer (Cli_printer.PList ["Setting logging output at level "^level^" for key "^key^" to logger: "^logger]))
+ with
+ | Log.Unknown_level x -> failwith ("Unknown logging level "^x)
+ | Not_found ->
+ Logs.reset_all [ logger ];
+ printer (Cli_printer.PList ["Resetting all logging output to logger: "^logger])
let log_get_keys printer _ session_id params =
- let keys = Debug.get_all_debug_keys () in
- printer (Cli_printer.PList keys)
+ let keys = Debug.get_all_debug_keys () in
+ printer (Cli_printer.PList keys)
let log_get printer _ session_id params =
- let logger = Logs.get_or_open "string" in
- let lines = Log.get_strings logger in
- printer (Cli_printer.PList (List.rev lines))
+ let logger = Logs.get_or_open "string" in
+ let lines = Log.get_strings logger in
+ printer (Cli_printer.PList (List.rev lines))
let log_reopen printer _ session_id params =
- Logs.reopen (); ()
+ Logs.reopen (); ()
let string_of_task_status task = match task.API.task_status with
- | `pending ->
- Printf.sprintf "%d %% complete "
- (int_of_float (task.API.task_progress *. 100.))
- | `success ->
- "Completed"
- | `failure ->
- "Failed"
- | `cancelling ->
- "Cancelling"
- | `cancelled ->
- "Cancelled"
+ | `pending ->
+ Printf.sprintf "%d %% complete "
+ (int_of_float (task.API.task_progress *. 100.))
+ | `success ->
+ "Completed"
+ | `failure ->
+ "Failed"
+ | `cancelling ->
+ "Cancelling"
+ | `cancelled ->
+ "Cancelled"
(*let task_list printer rpc session_id params =
let internal = try (List.assoc "internal" params)="true" with _ -> false in
let task_records = get_task_records rpc session_id in
let recs =
- List.map
- (fun (ref,task) ->
- let common =
- ["NAME",task.API.task_name_label;
- "uuid",task.API.task_uuid;
- "descr",task.API.task_name_description;
- "status", (string_of_task_status task);
- ] in
- (* If in show-internal mode, list the locks too *)
- let locks = if internal
- then List.map (fun lock -> "lock", lock)
- (Client.Task.get_locks rpc session_id ref)
- else [] in
- common @ locks)
- task_records
+ List.map
+ (fun (ref,task) ->
+ let common =
+ ["NAME",task.API.task_name_label;
+ "uuid",task.API.task_uuid;
+ "descr",task.API.task_name_description;
+ "status", (string_of_task_status task);
+ ] in
+(* If in show-internal mode, list the locks too *)
+ let locks = if internal
+ then List.map (fun lock -> "lock", lock)
+ (Client.Task.get_locks rpc session_id ref)
+ else [] in
+ common @ locks)
+ task_records
in
printer (Cli_printer.PTable recs)
-*)
+ *)
let user_password_change _ rpc session_id params =
- let old_pwd = List.assoc_default "old" params ""
- (* "new" must be in params here, since it is a required parameter. *)
- and new_pwd = List.assoc "new" params in
- Client.Session.change_password rpc session_id old_pwd new_pwd
+ let old_pwd = List.assoc_default "old" params ""
+ (* "new" must be in params here, since it is a required parameter. *)
+ and new_pwd = List.assoc "new" params in
+ Client.Session.change_password rpc session_id old_pwd new_pwd
(** Low level CLI interface **)
(* vm-param-list takes the uuid and lists either a default set of parameters, or those passed *)
let alltrue l =
- List.fold_left (&&) true l
+ List.fold_left (&&) true l
let get_set_names rlist =
- let sets = List.filter (fun r -> r.get_set <> None) rlist in
- List.map (fun r -> r.name) sets
+ let sets = List.filter (fun r -> r.get_set <> None) rlist in
+ List.map (fun r -> r.name) sets
let get_map_names rlist =
- let maps = List.filter (fun r -> r.get_map <> None) rlist in
- List.map (fun r -> r.name) maps
+ let maps = List.filter (fun r -> r.get_map <> None) rlist in
+ List.map (fun r -> r.name) maps
let safe_get_field x =
- try x.get ()
- with
- | Api_errors.Server_error(s,_) as e-> if s=Api_errors.handle_invalid then "<invalid reference>" else raise e
- | e -> raise e
+ try x.get ()
+ with
+ | Api_errors.Server_error(s,_) as e-> if s=Api_errors.handle_invalid then "<invalid reference>" else raise e
+ | e -> raise e
type fieldtype = Normal | Set of string | Map of string
let get_field_type fieldname record =
- if List.exists (fun field -> field.name=fieldname) record
- then Normal
- else
- begin
- (* New 'normal' behaviour is to split map name from key by the separator ':' *)
- if String.contains fieldname ':' then
- begin
- let i = String.index fieldname ':' in
- let real_fieldname = String.sub fieldname 0 i in
- try
- let field = List.find (fun field -> field.name=real_fieldname) record in
- if field.get_set <> None
- then Set field.name
- else if field.get_map <> None
- then Map field.name
- else failwith ("Field '"^(field.name)^"' is not a set or map")
- with
- Not_found -> failwith ("Unknown field '"^fieldname^"'")
- end
- else
- (* Old behaviour is to match like this: param-name-key=value *)
- begin
- (* Find all the maps, then sort in length order, longest first *)
- let mapfields = List.filter (fun field -> field.get_map <> None) record in
- let mapfields = List.sort (fun a b -> compare (String.length b.name) (String.length a.name)) mapfields in
- try
- (* Find the first (longest) matching field *)
- let field = List.find (fun field -> String.startswith (field.name^"-") fieldname) mapfields in
- Map field.name
- with
- Not_found ->
- let setfields = List.filter (fun field -> field.get_set <> None) record in
- let setfields = List.sort (fun a b -> compare (String.length b.name) (String.length a.name)) setfields in
- try
- let field = List.find (fun field -> String.startswith (field.name^"-") fieldname) setfields in
- Set field.name
- with
- _ -> failwith ("Unknown field '"^fieldname^"'")
- end
- end
+ if List.exists (fun field -> field.name=fieldname) record
+ then Normal
+ else
+ begin
+ (* New 'normal' behaviour is to split map name from key by the separator ':' *)
+ if String.contains fieldname ':' then
+ begin
+ let i = String.index fieldname ':' in
+ let real_fieldname = String.sub fieldname 0 i in
+ try
+ let field = List.find (fun field -> field.name=real_fieldname) record in
+ if field.get_set <> None
+ then Set field.name
+ else if field.get_map <> None
+ then Map field.name
+ else failwith ("Field '"^(field.name)^"' is not a set or map")
+ with
+ Not_found -> failwith ("Unknown field '"^fieldname^"'")
+ end
+ else
+ (* Old behaviour is to match like this: param-name-key=value *)
+ begin
+ (* Find all the maps, then sort in length order, longest first *)
+ let mapfields = List.filter (fun field -> field.get_map <> None) record in
+ let mapfields = List.sort (fun a b -> compare (String.length b.name) (String.length a.name)) mapfields in
+ try
+ (* Find the first (longest) matching field *)
+ let field = List.find (fun field -> String.startswith (field.name^"-") fieldname) mapfields in
+ Map field.name
+ with
+ Not_found ->
+ let setfields = List.filter (fun field -> field.get_set <> None) record in
+ let setfields = List.sort (fun a b -> compare (String.length b.name) (String.length a.name)) setfields in
+ try
+ let field = List.find (fun field -> String.startswith (field.name^"-") fieldname) setfields in
+ Set field.name
+ with
+ _ -> failwith ("Unknown field '"^fieldname^"'")
+ end
+ end
let filter_records_on_set_param records (k,v) s =
- (* On entry here, s is the name of the parameter, and k will be of the form s[:-]contains *)
- let n = String.length s in
- let contains = String.sub k (n + 1) (String.length k - n - 1) in
- if contains<>"contains" then failwith "Invalid syntax for set filtering (should be set-param:contains=key)";
- let filterfn record =
- let field = field_lookup record.fields s in
- let get_set = match field.get_set with
- | Some x -> x
- | None -> (failwith (Printf.sprintf "Client_records broken (field %s)" s))
- in
- try
- let set = get_set () in
- let set, v =
- if field.case_insensitive
- then List.map String.lowercase set, String.lowercase v
- else set, v in
- List.exists (fun member -> v=member) set
- with
- _ -> false
- in
- List.filter filterfn records
+ (* On entry here, s is the name of the parameter, and k will be of the form s[:-]contains *)
+ let n = String.length s in
+ let contains = String.sub k (n + 1) (String.length k - n - 1) in
+ if contains<>"contains" then failwith "Invalid syntax for set filtering (should be set-param:contains=key)";
+ let filterfn record =
+ let field = field_lookup record.fields s in
+ let get_set = match field.get_set with
+ | Some x -> x
+ | None -> (failwith (Printf.sprintf "Client_records broken (field %s)" s))
+ in
+ try
+ let set = get_set () in
+ let set, v =
+ if field.case_insensitive
+ then List.map String.lowercase set, String.lowercase v
+ else set, v in
+ List.exists (fun member -> v=member) set
+ with
+ _ -> false
+ in
+ List.filter filterfn records
let filter_records_on_map_param records (k,v) s =
- (* On entry here, s is the name of the parameter, and k will be of the form s[:-]key *)
- let n = String.length s in
- let key = String.sub k (n + 1) (String.length k - n - 1) in
- let filterfn record =
- let field = field_lookup record.fields s in
- let get_map = match field.get_map with
- | Some x -> x
- | None -> failwith (Printf.sprintf "Client_records broken (field %s)" s)
- in
- try
- let map = get_map () in
- let map, key, v =
- if field.case_insensitive
- then List.map (fun (k, v) -> String.lowercase k, v) map, String.lowercase key, String.lowercase v
- else map, key, v in
- List.mem_assoc key map && List.assoc key map = v
- with
- _ -> false
- in
- List.filter filterfn records
+ (* On entry here, s is the name of the parameter, and k will be of the form s[:-]key *)
+ let n = String.length s in
+ let key = String.sub k (n + 1) (String.length k - n - 1) in
+ let filterfn record =
+ let field = field_lookup record.fields s in
+ let get_map = match field.get_map with
+ | Some x -> x
+ | None -> failwith (Printf.sprintf "Client_records broken (field %s)" s)
+ in
+ try
+ let map = get_map () in
+ let map, key, v =
+ if field.case_insensitive
+ then List.map (fun (k, v) -> String.lowercase k, v) map, String.lowercase key, String.lowercase v
+ else map, key, v in
+ List.mem_assoc key map && List.assoc key map = v
+ with
+ _ -> false
+ in
+ List.filter filterfn records
let filter_records_on_normal_param records (k,v) =
- let filterfn record =
- let field = field_lookup record.fields k in
- let value = safe_get_field field in
- if field.case_insensitive
- then String.lowercase value = String.lowercase v
- else value=v
- in
- List.filter filterfn records
+ let filterfn record =
+ let field = field_lookup record.fields k in
+ let value = safe_get_field field in
+ if field.case_insensitive
+ then String.lowercase value = String.lowercase v
+ else value=v
+ in
+ List.filter filterfn records
let filter_records_on_fields records (k,v) =
- (* Ignore empty lists *)
- if records = [] then [] else begin
-
- (* We can only tell what types fields are by looking at a record itself. *)
- (* We use the first one *)
- let firstrec = List.hd records in
-
- (* Switch on the type of the field *)
- match get_field_type k firstrec.fields with
- Normal -> filter_records_on_normal_param records (k,v)
- | Map s -> filter_records_on_map_param records (k,v) s
- | Set s -> filter_records_on_set_param records (k,v) s
- end
+ (* Ignore empty lists *)
+ if records = [] then [] else begin
+
+ (* We can only tell what types fields are by looking at a record itself. *)
+ (* We use the first one *)
+ let firstrec = List.hd records in
+
+ (* Switch on the type of the field *)
+ match get_field_type k firstrec.fields with
+ Normal -> filter_records_on_normal_param records (k,v)
+ | Map s -> filter_records_on_map_param records (k,v) s
+ | Set s -> filter_records_on_set_param records (k,v) s
+ end
let stdparams = ["server";"password";"port";"username"; "minimal"; "force"; "multiple"; "compat"; "all"; "message-priority"]
let choose_params params defaults =
- if List.mem_assoc "params" params
- then
- let ps = List.assoc "params" params in
- (if ps="all" then [] else String.split_f (fun c -> c = ',') ps)
- else defaults
+ if List.mem_assoc "params" params
+ then
+ let ps = List.assoc "params" params in
+ (if ps="all" then [] else String.split_f (fun c -> c = ',') ps)
+ else defaults
let select_fields params records default_params =
- let params = choose_params params default_params in
- if params=[] then (List.map (fun record -> record.fields) records) else
- (List.map (fun record -> List.filter (fun field -> List.mem field.name params) record.fields) records)
+ let params = choose_params params default_params in
+ if params=[] then (List.map (fun record -> record.fields) records) else
+ (List.map (fun record -> List.filter (fun field -> List.mem field.name params) record.fields) records)
let print_field x =
- let append =
- if x.get_set <> None then
- (* Set *)
- if x.add_to_set = None then
- " (SRO)"
- else
- " (SRW)"
- else if x.get_map <> None then
- (* map *)
- if x.add_to_map = None then
- " (MRO)"
- else
- " (MRW)"
- else if x.set = None then
- " ( RO)"
- else
- " ( RW)"
- in
- let result = safe_get_field x in
- (x.name ^ append ^ (if x.deprecated then " [DEPRECATED]" else ""), result)
+ let append =
+ if x.get_set <> None then
+ (* Set *)
+ if x.add_to_set = None then
+ " (SRO)"
+ else
+ " (SRW)"
+ else if x.get_map <> None then
+ (* map *)
+ if x.add_to_map = None then
+ " (MRO)"
+ else
+ " (MRW)"
+ else if x.set = None then
+ " ( RO)"
+ else
+ " ( RW)"
+ in
+ let result = safe_get_field x in
+ (x.name ^ append ^ (if x.deprecated then " [DEPRECATED]" else ""), result)
type printer = Cli_printer.print_fn
type rpc = (Xml.xml -> Xml.xml)
type params = (string * string) list
let make_param_funs getall getallrecs getbyuuid record class_name def_filters def_list_params rpc session_id =
- let get_record2 rpc session_id x =
- let r = record rpc session_id x in
- r.fields
- in
+ let get_record2 rpc session_id x =
+ let r = record rpc session_id x in
+ r.fields
+ in
- let get_record rpc session_id uuid =
- get_record2 rpc session_id (getbyuuid ~rpc ~session_id ~uuid)
- in
+ let get_record rpc session_id uuid =
+ get_record2 rpc session_id (getbyuuid ~rpc ~session_id ~uuid)
+ in
- let list printer rpc session_id params : unit =
- let all = getallrecs ~rpc ~session_id ~expr:"true" in
- let all_recs = List.map (fun (r,x) -> let record = record rpc session_id r in record.setrefrec (r,x); record) all in
+ let list printer rpc session_id params : unit =
+ let all = getallrecs ~rpc ~session_id ~expr:"true" in
+ let all_recs = List.map (fun (r,x) -> let record = record rpc session_id r in record.setrefrec (r,x); record) all in
- (* Filter on everything on the cmd line except params=... *)
- let filter_params = List.filter (fun (p,_) -> not (List.mem p ("params"::stdparams))) params in
- (* Add in the default filters *)
- let filter_params = def_filters @ filter_params in
- (* Filter all the records *)
- let records = List.fold_left filter_records_on_fields all_recs filter_params in
+ (* Filter on everything on the cmd line except params=... *)
+ let filter_params = List.filter (fun (p,_) -> not (List.mem p ("params"::stdparams))) params in
+ (* Add in the default filters *)
+ let filter_params = def_filters @ filter_params in
+ (* Filter all the records *)
+ let records = List.fold_left filter_records_on_fields all_recs filter_params in
- let print_all = get_bool_param params "all" in
+ let print_all = get_bool_param params "all" in
- let print_params = select_fields params (if print_all then all_recs else records) def_list_params in
- let print_params = List.map (fun fields -> List.filter (fun field -> not field.hidden) fields) print_params in
- let print_params = List.map (fun fields -> List.map (fun field -> if field.expensive then makeexpensivefield field else field) fields) print_params in
+ let print_params = select_fields params (if print_all then all_recs else records) def_list_params in
+ let print_params = List.map (fun fields -> List.filter (fun field -> not field.hidden) fields) print_params in
+ let print_params = List.map (fun fields -> List.map (fun field -> if field.expensive then makeexpensivefield field else field) fields) print_params in
- printer (Cli_printer.PTable (List.map (List.map print_field) print_params))
- in
+ printer (Cli_printer.PTable (List.map (List.map print_field) print_params))
+ in
- let p_list printer rpc session_id params : unit =
- let record = get_record rpc session_id (List.assoc "uuid" params) in
- let record = List.filter (fun field -> not field.hidden) record in
- printer (Cli_printer.PTable [List.map print_field record])
- in
+ let p_list printer rpc session_id params : unit =
+ let record = get_record rpc session_id (List.assoc "uuid" params) in
+ let record = List.filter (fun field -> not field.hidden) record in
+ printer (Cli_printer.PTable [List.map print_field record])
+ in
- let p_get printer rpc session_id params : unit =
- let record = get_record rpc session_id (List.assoc "uuid" params) in
- let param = List.assoc "param-name" params in
- let x = field_lookup record param in
- let std () =
- printer (Cli_printer.PList [ safe_get_field x])
- in
- if List.mem_assoc "param-key" params then
- let key = List.assoc "param-key" params in
- match x.get_map with
- Some f ->
- let result =
- try List.assoc key (f ()) with _ -> failwith (Printf.sprintf "Key %s not found in map" key) in
- printer (Cli_printer.PList [result])
- | None -> std ()
- else std ()
- in
+ let p_get printer rpc session_id params : unit =
+ let record = get_record rpc session_id (List.assoc "uuid" params) in
+ let param = List.assoc "param-name" params in
+ let x = field_lookup record param in
+ let std () =
+ printer (Cli_printer.PList [ safe_get_field x])
+ in
+ if List.mem_assoc "param-key" params then
+ let key = List.assoc "param-key" params in
+ match x.get_map with
+ Some f ->
+ let result =
+ try List.assoc key (f ()) with _ -> failwith (Printf.sprintf "Key %s not found in map" key) in
+ printer (Cli_printer.PList [result])
+ | None -> std ()
+ else std ()
+ in
- let p_set (printer : printer) rpc session_id params =
- let record = get_record rpc session_id (List.assoc "uuid" params) in
- let set_params = List.filter (fun (p,_) -> not (List.mem p ("uuid"::stdparams))) params in
-
- let set_field (k,v) =
- let field_type = get_field_type k record in
- match field_type with
- | Map s ->
- let field=field_lookup record s in
- let n = String.length s in
- let key = String.sub k (n + 1) (String.length k - n - 1) in
- let get_map = match field.get_map with
- | Some x -> x
- | None -> failwith (Printf.sprintf "Broken Client_records (field %s)" s)
- in
- let add_to_map = match field.add_to_map with Some f -> f | None -> failwith ("Map field '"^s^"' is read-only.") in
- let remove_from_map = match field.remove_from_map with Some f -> f | None -> failwith (Printf.sprintf "Client_records broken (field %s)" s) in
- let map = get_map () in
- if List.mem_assoc key map then remove_from_map key;
- add_to_map key v
- | Set s -> failwith "Cannot param-set on set fields"
- | Normal ->
- let field=field_lookup record k in
- let set = match field.set, field.add_to_map with
- | Some f, _ -> f
- | None, Some f -> failwith ("Field '"^k^"' is a map or set. use the 'name:key=value' syntax.")
- | None, None -> failwith ("Field '"^k^"' is read-only.") in
- try
- set v
- with
- (Failure "int_of_string") -> failwith ("Parameter "^k^" must be an integer")
- | (Failure "float_of_string") -> failwith ("Parameter "^k^" must be a floating-point number")
- | (Invalid_argument "bool_of_string") -> failwith ("Parameter "^k^" must be a boolean (true or false)")
- | e -> raise e
- in
- List.iter set_field set_params
- in
+ let p_set (printer : printer) rpc session_id params =
+ let record = get_record rpc session_id (List.assoc "uuid" params) in
+ let set_params = List.filter (fun (p,_) -> not (List.mem p ("uuid"::stdparams))) params in
+
+ let set_field (k,v) =
+ let field_type = get_field_type k record in
+ match field_type with
+ | Map s ->
+ let field=field_lookup record s in
+ let n = String.length s in
+ let key = String.sub k (n + 1) (String.length k - n - 1) in
+ let get_map = match field.get_map with
+ | Some x -> x
+ | None -> failwith (Printf.sprintf "Broken Client_records (field %s)" s)
+ in
+ let add_to_map = match field.add_to_map with Some f -> f | None -> failwith ("Map field '"^s^"' is read-only.") in
+ let remove_from_map = match field.remove_from_map with Some f -> f | None -> failwith (Printf.sprintf "Client_records broken (field %s)" s) in
+ let map = get_map () in
+ if List.mem_assoc key map then remove_from_map key;
+ add_to_map key v
+ | Set s -> failwith "Cannot param-set on set fields"
+ | Normal ->
+ let field=field_lookup record k in
+ let set = match field.set, field.add_to_map with
+ | Some f, _ -> f
+ | None, Some f -> failwith ("Field '"^k^"' is a map or set. use the 'name:key=value' syntax.")
+ | None, None -> failwith ("Field '"^k^"' is read-only.") in
+ try
+ set v
+ with
+ (Failure "int_of_string") -> failwith ("Parameter "^k^" must be an integer")
+ | (Failure "float_of_string") -> failwith ("Parameter "^k^" must be a floating-point number")
+ | (Invalid_argument "bool_of_string") -> failwith ("Parameter "^k^" must be a boolean (true or false)")
+ | e -> raise e
+ in
+ List.iter set_field set_params
+ in
- let p_add (printer : printer) rpc session_id params =
- let record = get_record rpc session_id (List.assoc "uuid" params) in
- let param_name = List.assoc "param-name" params in
- let filter_params = List.filter (fun (p,_) -> not (List.mem p ("uuid"::"param-name"::"param-key"::stdparams))) params in
- match field_lookup record param_name with
- | { add_to_set = Some f } ->
- if List.mem_assoc "param-key" params then
- let key = List.assoc "param-key" params in
- f key
- else
- failwith "When adding a key to a set, use the syntax: *-param-add param-name=<name> param-key=<key>"
- | { add_to_map = Some f } -> List.iter (fun (k,x) -> f k x) filter_params
- | { get_set = Some _; add_to_set=None }
- | { get_map = Some _; add_to_map=None } ->
- failwith "Parameter is read-only"
- | _ -> failwith "Can only add to parameters of type Set or Map"
- in
+ let p_add (printer : printer) rpc session_id params =
+ let record = get_record rpc session_id (List.assoc "uuid" params) in
+ let param_name = List.assoc "param-name" params in
+ let filter_params = List.filter (fun (p,_) -> not (List.mem p ("uuid"::"param-name"::"param-key"::stdparams))) params in
+ match field_lookup record param_name with
+ | { add_to_set = Some f } ->
+ if List.mem_assoc "param-key" params then
+ let key = List.assoc "param-key" params in
+ f key
+ else
+ failwith "When adding a key to a set, use the syntax: *-param-add param-name=<name> param-key=<key>"
+ | { add_to_map = Some f } -> List.iter (fun (k,x) -> f k x) filter_params
+ | { get_set = Some _; add_to_set=None }
+ | { get_map = Some _; add_to_map=None } ->
+ failwith "Parameter is read-only"
+ | _ -> failwith "Can only add to parameters of type Set or Map"
+ in
- let p_remove (printer : printer) rpc session_id params =
- let record = get_record rpc session_id (List.assoc "uuid" params) in
- let param_name = List.assoc "param-name" params in
- let param_key = List.assoc "param-key" params in
- match field_lookup record param_name with
- | { get_set = Some g; remove_from_set = Some f } -> if List.mem param_key (g ()) then f param_key else failwith "Key is not in the set"
- | { get_map = Some g; remove_from_map = Some f } -> if List.mem_assoc param_key (g ()) then f param_key else failwith "Key is not in map"
- | _ -> failwith "Can only remove from parameters of type Set or Map"
- in
+ let p_remove (printer : printer) rpc session_id params =
+ let record = get_record rpc session_id (List.assoc "uuid" params) in
+ let param_name = List.assoc "param-name" params in
+ let param_key = List.assoc "param-key" params in
+ match field_lookup record param_name with
+ | { get_set = Some g; remove_from_set = Some f } -> if List.mem param_key (g ()) then f param_key else failwith "Key is not in the set"
+ | { get_map = Some g; remove_from_map = Some f } -> if List.mem_assoc param_key (g ()) then f param_key else failwith "Key is not in map"
+ | _ -> failwith "Can only remove from parameters of type Set or Map"
+ in
- let p_clear (printer : printer) rpc session_id params =
- let record = get_record rpc session_id (List.assoc "uuid" params) in
- let param_name = List.assoc "param-name" params in
- match field_lookup record param_name with
- | { get_set = Some f; remove_from_set = Some g } -> List.iter g (f ())
- | { get_map = Some f; remove_from_map = Some g } -> List.iter g (List.map fst (f ()))
- | { set = Some f } -> (try f "" with _ -> failwith "Cannot clear this parameter")
- | _ -> failwith "Can only clear RW parameters"
- in
+ let p_clear (printer : printer) rpc session_id params =
+ let record = get_record rpc session_id (List.assoc "uuid" params) in
+ let param_name = List.assoc "param-name" params in
+ match field_lookup record param_name with
+ | { get_set = Some f; remove_from_set = Some g } -> List.iter g (f ())
+ | { get_map = Some f; remove_from_map = Some g } -> List.iter g (List.map fst (f ()))
+ | { set = Some f } -> (try f "" with _ -> failwith "Cannot clear this parameter")
+ | _ -> failwith "Can only clear RW parameters"
+ in
- let gen_frontend (rpc:rpc) (session_id:API.ref_session) =
- let make_cmdtable_data (opname, reqd, optn, help, impl, std) =
- (opname,{reqd=reqd; optn=optn; help=help; implementation=No_fd impl; flags=if std then [Standard] else []})
- in
- try
- let all = List.filter (fun x -> not x.hidden) (record rpc session_id (Ref.null)).fields in
- let all_optn = List.map (fun r -> r.name) all in
- let settable = List.map (fun r -> r.name) (List.filter (fun r -> r.set <> None) all) in
- let settable = settable @ (List.map (fun r -> r.name ^ ":") (List.filter (fun r -> r.add_to_map <> None) all)) in
- let addable = List.map (fun r -> r.name) (List.filter (fun r -> r.add_to_set <> None || r.add_to_map <> None) all) in
- let clearable = List.map (fun r -> r.name) (List.filter (fun r -> r.set <> None || r.get_set <> None || r.get_map <> None) all) in
- (* We need the names of the set and map filters *)
- let sm_param_names =
- let sets = List.filter (fun field -> field.get_set <> None) all in
- List.map (fun field -> field.name^":contains") sets
- in
- let cli_name n = class_name^"-"^n in
- let plural = if class_name="patch" then "patches" else class_name^"s" in
- let ops = [(cli_name "list",[],"params"::all_optn@sm_param_names, "Lists all the "^plural^", filtering on the optional arguments. To filter on map parameters, use the syntax 'map-param:key=value'",list,(class_name="vm" || class_name="network" || class_name="sr"));
- (cli_name "param-list",["uuid"],[],"Lists all the parameters of the object specified by the uuid.",p_list,false);
- (cli_name "param-get",["uuid";"param-name"],["param-key"],"Gets the parameter specified of the object. If the parameter is a map of key=value pairs, use 'param-key=<key>' to get the value associated with a particular key.",p_get,false)] in
- let ops = if List.length settable > 0 then
- (cli_name "param-set",["uuid";],settable,"Sets the parameter specified. If param-value is not given, the parameter is set to a null value. To set a (key,value) pair in a map parameter, use the syntax 'map-param:key=value'.",p_set,false)::ops
- else ops in
- let ops = if List.length addable > 0 then
- ops @ [(cli_name "param-add",["uuid";"param-name"],["param-key"],"Adds to a set or map parameter. If the parameter is a set, use param-key=<key to add>. If the parameter is a map, pass the values to add as 'key=value' pairs.",p_add,false);
- (cli_name "param-remove",["uuid";"param-name";"param-key"],[],"Removes a member or a key,value pair from a set/map respectively.",p_remove,false)]
- else ops in
- let ops = if List.length clearable > 0 then
- ops @ [(cli_name "param-clear",["uuid";"param-name"],[],"Clears the specified parameter (param-name can be "^(String.concat "," clearable)^").",p_clear,false)]
- else ops in
- List.map make_cmdtable_data ops
- with _ -> []
- in
- gen_frontend rpc session_id
+ let gen_frontend (rpc:rpc) (session_id:API.ref_session) =
+ let make_cmdtable_data (opname, reqd, optn, help, impl, std) =
+ (opname,{reqd=reqd; optn=optn; help=help; implementation=No_fd impl; flags=if std then [Standard] else []})
+ in
+ try
+ let all = List.filter (fun x -> not x.hidden) (record rpc session_id (Ref.null)).fields in
+ let all_optn = List.map (fun r -> r.name) all in
+ let settable = List.map (fun r -> r.name) (List.filter (fun r -> r.set <> None) all) in
+ let settable = settable @ (List.map (fun r -> r.name ^ ":") (List.filter (fun r -> r.add_to_map <> None) all)) in
+ let addable = List.map (fun r -> r.name) (List.filter (fun r -> r.add_to_set <> None || r.add_to_map <> None) all) in
+ let clearable = List.map (fun r -> r.name) (List.filter (fun r -> r.set <> None || r.get_set <> None || r.get_map <> None) all) in
+ (* We need the names of the set and map filters *)
+ let sm_param_names =
+ let sets = List.filter (fun field -> field.get_set <> None) all in
+ List.map (fun field -> field.name^":contains") sets
+ in
+ let cli_name n = class_name^"-"^n in
+ let plural = if class_name="patch" then "patches" else class_name^"s" in
+ let ops = [(cli_name "list",[],"params"::all_optn@sm_param_names, "Lists all the "^plural^", filtering on the optional arguments. To filter on map parameters, use the syntax 'map-param:key=value'",list,(class_name="vm" || class_name="network" || class_name="sr"));
+ (cli_name "param-list",["uuid"],[],"Lists all the parameters of the object specified by the uuid.",p_list,false);
+ (cli_name "param-get",["uuid";"param-name"],["param-key"],"Gets the parameter specified of the object. If the parameter is a map of key=value pairs, use 'param-key=<key>' to get the value associated with a particular key.",p_get,false)] in
+ let ops = if List.length settable > 0 then
+ (cli_name "param-set",["uuid";],settable,"Sets the parameter specified. If param-value is not given, the parameter is set to a null value. To set a (key,value) pair in a map parameter, use the syntax 'map-param:key=value'.",p_set,false)::ops
+ else ops in
+ let ops = if List.length addable > 0 then
+ ops @ [(cli_name "param-add",["uuid";"param-name"],["param-key"],"Adds to a set or map parameter. If the parameter is a set, use param-key=<key to add>. If the parameter is a map, pass the values to add as 'key=value' pairs.",p_add,false);
+ (cli_name "param-remove",["uuid";"param-name";"param-key"],[],"Removes a member or a key,value pair from a set/map respectively.",p_remove,false)]
+ else ops in
+ let ops = if List.length clearable > 0 then
+ ops @ [(cli_name "param-clear",["uuid";"param-name"],[],"Clears the specified parameter (param-name can be "^(String.concat "," clearable)^").",p_clear,false)]
+ else ops in
+ List.map make_cmdtable_data ops
+ with _ -> []
+ in
+ gen_frontend rpc session_id
let gen_cmds rpc session_id =
(make_param_funs (Client.Pool.get_all) (Client.Pool.get_all_records_where) (Client.Pool.get_by_uuid) (pool_record) "pool" [] ["uuid";"name-label";"name-description";"master";"default-SR"] rpc session_id) @
- (make_param_funs (Client.PIF.get_all) (Client.PIF.get_all_records_where) (Client.PIF.get_by_uuid) (pif_record) "pif" [] ["uuid";"device";"VLAN";"mac";"network-uuid"; "currently-attached"] rpc session_id) @
- (make_param_funs (Client.Bond.get_all) (Client.Bond.get_all_records_where) (Client.Bond.get_by_uuid) (bond_record) "bond" [] ["uuid";"master";"slaves"] rpc session_id) @
- (make_param_funs (Client.VLAN.get_all) (Client.VLAN.get_all_records_where) (Client.VLAN.get_by_uuid) (vlan_record) "vlan" [] ["uuid";"tagged-PIF";"untagged-PIF"; "tag"] rpc session_id) @
- (make_param_funs (Client.Tunnel.get_all) (Client.Tunnel.get_all_records_where) (Client.Tunnel.get_by_uuid) (tunnel_record) "tunnel" [] ["uuid";"transport-PIF";"access-PIF";"status"] rpc session_id) @
- (make_param_funs (Client.VIF.get_all) (Client.VIF.get_all_records_where) (Client.VIF.get_by_uuid) (vif_record) "vif" [] ["uuid";"device";"vm-uuid";"network-uuid"] rpc session_id) @
- (make_param_funs (Client.Network.get_all) (Client.Network.get_all_records_where) (Client.Network.get_by_uuid) (net_record) "network" [] ["uuid";"name-label";"name-description";"bridge"] rpc session_id) @
- (make_param_funs (Client.Console.get_all) (Client.Console.get_all_records_where) (Client.Console.get_by_uuid) (console_record) "console" [] ["uuid";"vm-uuid";"vm-name-label";"protocol";"location"] rpc session_id) @
- (make_param_funs (Client.VM.get_all) (Client.VM.get_all_records_where) (Client.VM.get_by_uuid) (vm_record) "vm" [("is-a-template","false")] ["name-label";"uuid";"power-state"] rpc session_id) @
- (make_param_funs (Client.VM.get_all) (Client.VM.get_all_records_where) (Client.VM.get_by_uuid) (vm_record) "template" [("is-a-template","true");("is-a-snapshot","false")] ["name-label";"name-description";"uuid"] rpc session_id) @
- (make_param_funs (Client.VM.get_all) (Client.VM.get_all_records_where) (Client.VM.get_by_uuid) (vm_record) "snapshot" [("is-a-snapshot","true")] ["name-label";"name-description";"uuid";"snapshot_of"; "snapshot_time"; "is-snapshot-from-vmpp"] rpc session_id) @
- (make_param_funs (Client.Host.get_all) (Client.Host.get_all_records_where) (Client.Host.get_by_uuid) (host_record) "host" [] ["uuid";"name-label";"name-description"] rpc session_id) @
- (make_param_funs (Client.Host_cpu.get_all) (Client.Host_cpu.get_all_records_where) (Client.Host_cpu.get_by_uuid) (host_cpu_record) "host-cpu" [] ["uuid";"number";"vendor";"speed";"utilisation"] rpc session_id) @
-
- (make_param_funs (Client.Host_crashdump.get_all) (Client.Host_crashdump.get_all_records_where) (Client.Host_crashdump.get_by_uuid) (host_crashdump_record) "host-crashdump" [] ["uuid";"host";"timestamp";"size"] rpc session_id) @
- (make_param_funs (Client.Pool_patch.get_all) (Client.Pool_patch.get_all_records_where) (Client.Pool_patch.get_by_uuid) (pool_patch_record) "patch" [] ["uuid"; "name-label"; "name-description"; "size"; "hosts"; "after-apply-guidance"] rpc session_id) @
- (make_param_funs (Client.VDI.get_all) (Client.VDI.get_all_records_where) (Client.VDI.get_by_uuid) (vdi_record) "vdi" [] ["uuid";"name-label";"name-description";"virtual-size";"read-only";"sharable";"sr-uuid"] rpc session_id) @
- (make_param_funs (Client.VBD.get_all) (Client.VBD.get_all_records_where) (Client.VBD.get_by_uuid) (vbd_record) "vbd" [] ["uuid";"vm-uuid";"vm-name-label";"vdi-uuid";"device"; "empty"] rpc session_id) @
- (make_param_funs (Client.SR.get_all) (Client.SR.get_all_records_where) (Client.SR.get_by_uuid) (sr_record) "sr" [] ["uuid";"name-label";"name-description";"host";"type";"content-type"] rpc session_id) @
- (make_param_funs (Client.SM.get_all) (Client.SM.get_all_records_where) (Client.SM.get_by_uuid) (sm_record) "sm" [] ["uuid";"type"; "name-label";"name-description";"vendor"; "copyright"; "configuration"] rpc session_id) @
- (make_param_funs (Client.PBD.get_all) (Client.PBD.get_all_records_where) (Client.PBD.get_by_uuid) (pbd_record) "pbd" [] ["uuid";"host-uuid";"sr-uuid";"device-config";"currently-attached"] rpc session_id) @
- (make_param_funs (Client.Task.get_all) (Client.Task.get_all_records_where) (Client.Task.get_by_uuid) (task_record) "task" [] ["uuid";"name-label";"name-description";"status";"progress"] rpc session_id) @
- (make_param_funs (Client.Subject.get_all) (Client.Subject.get_all_records_where) (Client.Subject.get_by_uuid) (subject_record) "subject" [] ["uuid";"subject-identifier";"other-config";"roles"] rpc session_id) @
- (make_param_funs (Client.Role.get_all) (fun ~rpc ~session_id ~expr -> Client.Role.get_all_records_where ~rpc ~session_id ~expr:Xapi_role.expr_no_permissions)
- (Client.Role.get_by_uuid) (role_record) "role" [] ["uuid";"name";"description";"subroles"] rpc session_id) @
- (make_param_funs (Client.VMPP.get_all) (Client.VMPP.get_all_records_where) (Client.VMPP.get_by_uuid) (vmpp_record) "vmpp" [] ["uuid";"name-label";"name-description";"is-policy-enabled";"backup-type";"backup-retention-value";"backup-frequency";"backup-schedule";"is-backup-running";"backup-last-run-time";"archive-target-type";"archive-target-config";"archive-frequency";"archive-schedule";"is-archive-running";"archive-last-run-time";"is-alarm-enabled";"alarm-config";"VMs"] rpc session_id) @
-(*
- (make_param_funs (Client.Blob.get_all) (Client.Blob.get_all_records_where) (Client.Blob.get_by_uuid) (blob_record) "blob" [] ["uuid";"mime-type"] rpc session_id) @
-*)
- (make_param_funs (Client.Message.get_all) (Client.Message.get_all_records_where) (Client.Message.get_by_uuid) (message_record) "message" [] [] rpc session_id)
+ (make_param_funs (Client.PIF.get_all) (Client.PIF.get_all_records_where) (Client.PIF.get_by_uuid) (pif_record) "pif" [] ["uuid";"device";"VLAN";"mac";"network-uuid"; "currently-attached"] rpc session_id) @
+ (make_param_funs (Client.Bond.get_all) (Client.Bond.get_all_records_where) (Client.Bond.get_by_uuid) (bond_record) "bond" [] ["uuid";"master";"slaves"] rpc session_id) @
+ (make_param_funs (Client.VLAN.get_all) (Client.VLAN.get_all_records_where) (Client.VLAN.get_by_uuid) (vlan_record) "vlan" [] ["uuid";"tagged-PIF";"untagged-PIF"; "tag"] rpc session_id) @
+ (make_param_funs (Client.Tunnel.get_all) (Client.Tunnel.get_all_records_where) (Client.Tunnel.get_by_uuid) (tunnel_record) "tunnel" [] ["uuid";"transport-PIF";"access-PIF";"status"] rpc session_id) @
+ (make_param_funs (Client.VIF.get_all) (Client.VIF.get_all_records_where) (Client.VIF.get_by_uuid) (vif_record) "vif" [] ["uuid";"device";"vm-uuid";"network-uuid"] rpc session_id) @
+ (make_param_funs (Client.Network.get_all) (Client.Network.get_all_records_where) (Client.Network.get_by_uuid) (net_record) "network" [] ["uuid";"name-label";"name-description";"bridge"] rpc session_id) @
+ (make_param_funs (Client.Console.get_all) (Client.Console.get_all_records_where) (Client.Console.get_by_uuid) (console_record) "console" [] ["uuid";"vm-uuid";"vm-name-label";"protocol";"location"] rpc session_id) @
+ (make_param_funs (Client.VM.get_all) (Client.VM.get_all_records_where) (Client.VM.get_by_uuid) (vm_record) "vm" [("is-a-template","false")] ["name-label";"uuid";"power-state"] rpc session_id) @
+ (make_param_funs (Client.VM.get_all) (Client.VM.get_all_records_where) (Client.VM.get_by_uuid) (vm_record) "template" [("is-a-template","true");("is-a-snapshot","false")] ["name-label";"name-description";"uuid"] rpc session_id) @
+ (make_param_funs (Client.VM.get_all) (Client.VM.get_all_records_where) (Client.VM.get_by_uuid) (vm_record) "snapshot" [("is-a-snapshot","true")] ["name-label";"name-description";"uuid";"snapshot_of"; "snapshot_time"; "is-snapshot-from-vmpp"] rpc session_id) @
+ (make_param_funs (Client.Host.get_all) (Client.Host.get_all_records_where) (Client.Host.get_by_uuid) (host_record) "host" [] ["uuid";"name-label";"name-description"] rpc session_id) @
+ (make_param_funs (Client.Host_cpu.get_all) (Client.Host_cpu.get_all_records_where) (Client.Host_cpu.get_by_uuid) (host_cpu_record) "host-cpu" [] ["uuid";"number";"vendor";"speed";"utilisation"] rpc session_id) @
+
+ (make_param_funs (Client.Host_crashdump.get_all) (Client.Host_crashdump.get_all_records_where) (Client.Host_crashdump.get_by_uuid) (host_crashdump_record) "host-crashdump" [] ["uuid";"host";"timestamp";"size"] rpc session_id) @
+ (make_param_funs (Client.Pool_patch.get_all) (Client.Pool_patch.get_all_records_where) (Client.Pool_patch.get_by_uuid) (pool_patch_record) "patch" [] ["uuid"; "name-label"; "name-description"; "size"; "hosts"; "after-apply-guidance"] rpc session_id) @
+ (make_param_funs (Client.VDI.get_all) (Client.VDI.get_all_records_where) (Client.VDI.get_by_uuid) (vdi_record) "vdi" [] ["uuid";"name-label";"name-description";"virtual-size";"read-only";"sharable";"sr-uuid"] rpc session_id) @
+ (make_param_funs (Client.VBD.get_all) (Client.VBD.get_all_records_where) (Client.VBD.get_by_uuid) (vbd_record) "vbd" [] ["uuid";"vm-uuid";"vm-name-label";"vdi-uuid";"device"; "empty"] rpc session_id) @
+ (make_param_funs (Client.SR.get_all) (Client.SR.get_all_records_where) (Client.SR.get_by_uuid) (sr_record) "sr" [] ["uuid";"name-label";"name-description";"host";"type";"content-type"] rpc session_id) @
+ (make_param_funs (Client.SM.get_all) (Client.SM.get_all_records_where) (Client.SM.get_by_uuid) (sm_record) "sm" [] ["uuid";"type"; "name-label";"name-description";"vendor"; "copyright"; "configuration"] rpc session_id) @
+ (make_param_funs (Client.PBD.get_all) (Client.PBD.get_all_records_where) (Client.PBD.get_by_uuid) (pbd_record) "pbd" [] ["uuid";"host-uuid";"sr-uuid";"device-config";"currently-attached"] rpc session_id) @
+ (make_param_funs (Client.Task.get_all) (Client.Task.get_all_records_where) (Client.Task.get_by_uuid) (task_record) "task" [] ["uuid";"name-label";"name-description";"status";"progress"] rpc session_id) @
+ (make_param_funs (Client.Subject.get_all) (Client.Subject.get_all_records_where) (Client.Subject.get_by_uuid) (subject_record) "subject" [] ["uuid";"subject-identifier";"other-config";"roles"] rpc session_id) @
+ (make_param_funs (Client.Role.get_all) (fun ~rpc ~session_id ~expr -> Client.Role.get_all_records_where ~rpc ~session_id ~expr:Xapi_role.expr_no_permissions)
+ (Client.Role.get_by_uuid) (role_record) "role" [] ["uuid";"name";"description";"subroles"] rpc session_id) @
+ (make_param_funs (Client.VMPP.get_all) (Client.VMPP.get_all_records_where) (Client.VMPP.get_by_uuid) (vmpp_record) "vmpp" [] ["uuid";"name-label";"name-description";"is-policy-enabled";"backup-type";"backup-retention-value";"backup-frequency";"backup-schedule";"is-backup-running";"backup-last-run-time";"archive-target-type";"archive-target-config";"archive-frequency";"archive-schedule";"is-archive-running";"archive-last-run-time";"is-alarm-enabled";"alarm-config";"VMs"] rpc session_id) @
+ (*
+ (make_param_funs (Client.Blob.get_all) (Client.Blob.get_all_records_where) (Client.Blob.get_by_uuid) (blob_record) "blob" [] ["uuid";"mime-type"] rpc session_id) @
+ *)
+ (make_param_funs (Client.Message.get_all) (Client.Message.get_all_records_where) (Client.Message.get_by_uuid) (message_record) "message" [] [] rpc session_id)
@ (make_param_funs (Client.Secret.get_all) (Client.Secret.get_all_records_where) (Client.Secret.get_by_uuid) (secret_record) "secret" [] [] rpc session_id)
-(*
- @ (make_param_funs (Client.Alert.get_all) (Client.Alert.get_all_records_where) (Client.Alert.get_by_uuid) (alert_record) "alert" [] ["uuid";"message";"level";"timestamp";"system";"task"] rpc session_id)
-*)
+ (*
+ @ (make_param_funs (Client.Alert.get_all) (Client.Alert.get_all_records_where) (Client.Alert.get_by_uuid) (alert_record) "alert" [] ["uuid";"message";"level";"timestamp";"system";"task"] rpc session_id)
+ *)
(* NB, might want to put these back in at some point
* let zurich_params_gone =
*)
let message_create printer rpc session_id params =
- let body = List.assoc "body" params in
- let priority = try Int64.of_string (List.assoc "priority" params) with _ -> failwith "Priority field should be an integer" in
- let name = List.assoc "name" params in
- let uuid,cls =
- if (List.mem_assoc "vm-uuid" params) then
- List.assoc "vm-uuid" params, `VM
- else if (List.mem_assoc "pool-uuid" params) then
- List.assoc "pool-uuid" params, `Pool
- else if (List.mem_assoc "sr-uuid" params) then
- List.assoc "sr-uuid" params, `SR
- else if (List.mem_assoc "host-uuid" params) then
- List.assoc "host-uuid" params, `Host
- else
- raise (Cli_util.Cli_failure "Need one of: vm-uuid, host-uuid, sr-uuid or pool-uuid")
- in
- ignore(Client.Message.create rpc session_id name priority cls uuid body)
+ let body = List.assoc "body" params in
+ let priority = try Int64.of_string (List.assoc "priority" params) with _ -> failwith "Priority field should be an integer" in
+ let name = List.assoc "name" params in
+ let uuid,cls =
+ if (List.mem_assoc "vm-uuid" params) then
+ List.assoc "vm-uuid" params, `VM
+ else if (List.mem_assoc "pool-uuid" params) then
+ List.assoc "pool-uuid" params, `Pool
+ else if (List.mem_assoc "sr-uuid" params) then
+ List.assoc "sr-uuid" params, `SR
+ else if (List.mem_assoc "host-uuid" params) then
+ List.assoc "host-uuid" params, `Host
+ else
+ raise (Cli_util.Cli_failure "Need one of: vm-uuid, host-uuid, sr-uuid or pool-uuid")
+ in
+ ignore(Client.Message.create rpc session_id name priority cls uuid body)
let message_destroy printer rpc session_id params =
- let uuid = List.assoc "uuid" params in
- let message = Client.Message.get_by_uuid rpc session_id uuid in
- Client.Message.destroy rpc session_id message
+ let uuid = List.assoc "uuid" params in
+ let message = Client.Message.get_by_uuid rpc session_id uuid in
+ Client.Message.destroy rpc session_id message
(* Pool operations *)
let pool_enable_binary_storage printer rpc session_id params =
- Client.Pool.enable_binary_storage rpc session_id
+ Client.Pool.enable_binary_storage rpc session_id
let pool_disable_binary_storage printer rpc session_id params =
- Client.Pool.disable_binary_storage rpc session_id
+ Client.Pool.disable_binary_storage rpc session_id
let pool_ha_enable printer rpc session_id params =
- let config = read_map_params "ha-config" params in
- let uuids = if List.mem_assoc "heartbeat-sr-uuids" params then String.split ',' (List.assoc "heartbeat-sr-uuids" params) else [] in
- let srs = List.map (fun uuid -> Client.SR.get_by_uuid rpc session_id uuid) uuids in
- Client.Pool.enable_ha rpc session_id srs config
+ let config = read_map_params "ha-config" params in
+ let uuids = if List.mem_assoc "heartbeat-sr-uuids" params then String.split ',' (List.assoc "heartbeat-sr-uuids" params) else [] in
+ let srs = List.map (fun uuid -> Client.SR.get_by_uuid rpc session_id uuid) uuids in
+ Client.Pool.enable_ha rpc session_id srs config
let pool_ha_disable printer rpc session_id params =
- Client.Pool.disable_ha rpc session_id
+ Client.Pool.disable_ha rpc session_id
let pool_ha_prevent_restarts_for printer rpc session_id params =
- let seconds = Int64.of_string (List.assoc "seconds" params) in
- Client.Pool.ha_prevent_restarts_for rpc session_id seconds
+ let seconds = Int64.of_string (List.assoc "seconds" params) in
+ Client.Pool.ha_prevent_restarts_for rpc session_id seconds
let pool_ha_compute_max_host_failures_to_tolerate printer rpc session_id params =
- let n = Client.Pool.ha_compute_max_host_failures_to_tolerate rpc session_id in
- printer (Cli_printer.PList [ Int64.to_string n ])
+ let n = Client.Pool.ha_compute_max_host_failures_to_tolerate rpc session_id in
+ printer (Cli_printer.PList [ Int64.to_string n ])
let pool_ha_compute_hypothetical_max_host_failures_to_tolerate printer rpc session_id params =
- (* Walk through the params in order constructing a VM -> restart_priority map *)
- let vms = List.map snd (List.filter (fun (k, _) -> k = "vm-uuid") params)
- and pri = List.map snd (List.filter (fun (k, _) -> k = "restart-priority") params) in
- if List.length vms <> (List.length pri) then failwith "Call requires an equal number of vm-uuid and restart-priority arguments";
- let vms = List.map (fun uuid -> Client.VM.get_by_uuid rpc session_id uuid) vms in
- let n = Client.Pool.ha_compute_hypothetical_max_host_failures_to_tolerate rpc session_id (List.combine vms pri) in
- printer (Cli_printer.PList [ Int64.to_string n ])
+ (* Walk through the params in order constructing a VM -> restart_priority map *)
+ let vms = List.map snd (List.filter (fun (k, _) -> k = "vm-uuid") params)
+ and pri = List.map snd (List.filter (fun (k, _) -> k = "restart-priority") params) in
+ if List.length vms <> (List.length pri) then failwith "Call requires an equal number of vm-uuid and restart-priority arguments";
+ let vms = List.map (fun uuid -> Client.VM.get_by_uuid rpc session_id uuid) vms in
+ let n = Client.Pool.ha_compute_hypothetical_max_host_failures_to_tolerate rpc session_id (List.combine vms pri) in
+ printer (Cli_printer.PList [ Int64.to_string n ])
let pool_ha_compute_vm_failover_plan printer rpc session_id params =
- let host_uuids = String.split ',' (List.assoc "host-uuids" params) in
- let hosts = List.map (fun uuid -> Client.Host.get_by_uuid rpc session_id uuid) host_uuids in
- (* For now select all VMs resident on the given hosts *)
- let vms = List.concat (List.map (fun host -> Client.Host.get_resident_VMs rpc session_id host) hosts) in
- let vms = List.filter (fun vm -> not(Client.VM.get_is_control_domain rpc session_id vm)) vms in
- let plan = Client.Pool.ha_compute_vm_failover_plan rpc session_id hosts vms in
- let table = List.map (fun (vm, result) ->
- Printf.sprintf "%s (%s)" (Client.VM.get_uuid rpc session_id vm) (Client.VM.get_name_label rpc session_id vm),
- if List.mem_assoc "host" result then begin
- let host = Ref.of_string (List.assoc "host" result) in
- Printf.sprintf "%s (%s)" (Client.Host.get_uuid rpc session_id host) (Client.Host.get_name_label rpc session_id host)
- end else if List.mem_assoc "error_code" result then begin
- List.assoc "error_code" result
- end else "UNKNOWN") plan in
- printer (Cli_printer.PTable [ ("VM", "Destination Host or Error") :: table ])
+ let host_uuids = String.split ',' (List.assoc "host-uuids" params) in
+ let hosts = List.map (fun uuid -> Client.Host.get_by_uuid rpc session_id uuid) host_uuids in
+ (* For now select all VMs resident on the given hosts *)
+ let vms = List.concat (List.map (fun host -> Client.Host.get_resident_VMs rpc session_id host) hosts) in
+ let vms = List.filter (fun vm -> not(Client.VM.get_is_control_domain rpc session_id vm)) vms in
+ let plan = Client.Pool.ha_compute_vm_failover_plan rpc session_id hosts vms in
+ let table = List.map (fun (vm, result) ->
+ Printf.sprintf "%s (%s)" (Client.VM.get_uuid rpc session_id vm) (Client.VM.get_name_label rpc session_id vm),
+ if List.mem_assoc "host" result then begin
+ let host = Ref.of_string (List.assoc "host" result) in
+ Printf.sprintf "%s (%s)" (Client.Host.get_uuid rpc session_id host) (Client.Host.get_name_label rpc session_id host)
+ end else if List.mem_assoc "error_code" result then begin
+ List.assoc "error_code" result
+ end else "UNKNOWN") plan in
+ printer (Cli_printer.PTable [ ("VM", "Destination Host or Error") :: table ])
let host_ha_xapi_healthcheck fd printer rpc session_id params =
- try
- let result = Client.Host.ha_xapi_healthcheck rpc session_id in
- if not(result) then begin
- marshal fd (Command (PrintStderr "Host.ha_xapi_healthcheck reports false"));
- raise (ExitWithError 2) (* comms failure exits with error 1 in the thin CLI itself *)
- end;
- marshal fd (Command (Print "xapi is healthy."))
- with e ->
- marshal fd (Command (PrintStderr (Printf.sprintf "Host.ha_xapi_healthcheck threw exception: %s" (ExnHelper.string_of_exn e))));
- raise (ExitWithError 3)
+ try
+ let result = Client.Host.ha_xapi_healthcheck rpc session_id in
+ if not(result) then begin
+ marshal fd (Command (PrintStderr "Host.ha_xapi_healthcheck reports false"));
+ raise (ExitWithError 2) (* comms failure exits with error 1 in the thin CLI itself *)
+ end;
+ marshal fd (Command (Print "xapi is healthy."))
+ with e ->
+ marshal fd (Command (PrintStderr (Printf.sprintf "Host.ha_xapi_healthcheck threw exception: %s" (ExnHelper.string_of_exn e))));
+ raise (ExitWithError 3)
let pool_sync_database printer rpc session_id params =
- Client.Pool.sync_database rpc session_id
+ Client.Pool.sync_database rpc session_id
let pool_designate_new_master printer rpc session_id params =
- let host_uuid=List.assoc "host-uuid" params in
- let host = Client.Host.get_by_uuid rpc session_id host_uuid in
- Client.Pool.designate_new_master rpc session_id host
+ let host_uuid=List.assoc "host-uuid" params in
+ let host = Client.Host.get_by_uuid rpc session_id host_uuid in
+ Client.Pool.designate_new_master rpc session_id host
let pool_join printer rpc session_id params =
- try
- let force = get_bool_param params "force" in
- if force then
- Client.Pool.join_force ~rpc ~session_id
- ~master_address:(List.assoc "master-address" params)
- ~master_username:(List.assoc "master-username" params)
- ~master_password:(List.assoc "master-password" params)
- else
- Client.Pool.join ~rpc ~session_id
- ~master_address:(List.assoc "master-address" params)
- ~master_username:(List.assoc "master-username" params)
- ~master_password:(List.assoc "master-password" params);
- printer (Cli_printer.PList ["Host agent will restart and attempt to join pool in "^(string_of_int Xapi_globs.fuse_time)^" seconds..."])
- with
- | Api_errors.Server_error(code, params) when code=Api_errors.pool_joining_host_connection_failed ->
- printer (Cli_printer.PList ["Host cannot contact destination host: connection refused.";
- "Check destination host has services running and accessible from this host."])
+ try
+ let force = get_bool_param params "force" in
+ if force then
+ Client.Pool.join_force ~rpc ~session_id
+ ~master_address:(List.assoc "master-address" params)
+ ~master_username:(List.assoc "master-username" params)
+ ~master_password:(List.assoc "master-password" params)
+ else
+ Client.Pool.join ~rpc ~session_id
+ ~master_address:(List.assoc "master-address" params)
+ ~master_username:(List.assoc "master-username" params)
+ ~master_password:(List.assoc "master-password" params);
+ printer (Cli_printer.PList ["Host agent will restart and attempt to join pool in "^(string_of_int Xapi_globs.fuse_time)^" seconds..."])
+ with
+ | Api_errors.Server_error(code, params) when code=Api_errors.pool_joining_host_connection_failed ->
+ printer (Cli_printer.PList ["Host cannot contact destination host: connection refused.";
+ "Check destination host has services running and accessible from this host."])
let pool_eject fd printer rpc session_id params =
- let host_uuid = List.assoc "host-uuid" params in
- let host=Client.Host.get_by_uuid rpc session_id host_uuid in
- let force = get_bool_param params "force" in
-
- let go () =
- Client.Pool.eject ~rpc ~session_id ~host;
- printer (Cli_printer.PList ["Specified host will attempt to restart as a master of a new pool in "^(string_of_int Xapi_globs.fuse_time)^" seconds..."]) in
-
- if force
- then go ()
- else begin
-
- (* Best-effort attempt to warn the user that VDIs in local SRs are going to be lost. *)
- let warnings =
- try
- (* Find local SRs *)
- let pbds = Client.Host.get_PBDs rpc session_id host in
- (* Find the subset of SRs which cannot be seen from other hosts *)
- let srs = List.concat
- (List.map
- (fun pbd ->
- try
- let sr = Client.PBD.get_SR rpc session_id pbd in
- let other_pbds = Client.SR.get_PBDs rpc session_id sr in
- let other_hosts = List.map (fun pbd -> Client.PBD.get_host rpc session_id pbd) other_pbds in
- let other_hosts_than_me = List.filter (fun other -> other <> host) other_hosts in
- if other_hosts_than_me = []
- then [ sr ] else []
- with _ -> []) pbds) in
- let warnings = ref [] in
- List.iter
- (fun sr ->
- try
- let vdis = Client.SR.get_VDIs rpc session_id sr in
- List.iter
- (fun vdi ->
- try
- let uuid = Client.VDI.get_uuid rpc session_id vdi
- and name_label = Client.VDI.get_name_label rpc session_id vdi in
- warnings := Printf.sprintf "VDI: %s (%s)" uuid name_label :: !warnings
- with _ -> ()
- ) vdis
- with _ -> ()
- ) srs;
- !warnings
- with _ -> []
- in
-
- marshal fd (Command (Print "WARNING: Ejecting a host from the pool will reinitialise that host's local SRs."));
- marshal fd (Command (Print "WARNING: Any data contained with the local SRs will be lost."));
- if warnings <> [] then begin
- marshal fd (Command (Print "The following VDI objects will be destroyed:"));
- List.iter (fun msg -> marshal fd (Command (Print msg))) warnings
- end;
- if user_says_yes fd
- then go ()
- end
+ let host_uuid = List.assoc "host-uuid" params in
+ let host=Client.Host.get_by_uuid rpc session_id host_uuid in
+ let force = get_bool_param params "force" in
+
+ let go () =
+ Client.Pool.eject ~rpc ~session_id ~host;
+ printer (Cli_printer.PList ["Specified host will attempt to restart as a master of a new pool in "^(string_of_int Xapi_globs.fuse_time)^" seconds..."]) in
+
+ if force
+ then go ()
+ else begin
+
+ (* Best-effort attempt to warn the user that VDIs in local SRs are going to be lost. *)
+ let warnings =
+ try
+ (* Find local SRs *)
+ let pbds = Client.Host.get_PBDs rpc session_id host in
+ (* Find the subset of SRs which cannot be seen from other hosts *)
+ let srs = List.concat
+ (List.map
+ (fun pbd ->
+ try
+ let sr = Client.PBD.get_SR rpc session_id pbd in
+ let other_pbds = Client.SR.get_PBDs rpc session_id sr in
+ let other_hosts = List.map (fun pbd -> Client.PBD.get_host rpc session_id pbd) other_pbds in
+ let other_hosts_than_me = List.filter (fun other -> other <> host) other_hosts in
+ if other_hosts_than_me = []
+ then [ sr ] else []
+ with _ -> []) pbds) in
+ let warnings = ref [] in
+ List.iter
+ (fun sr ->
+ try
+ let vdis = Client.SR.get_VDIs rpc session_id sr in
+ List.iter
+ (fun vdi ->
+ try
+ let uuid = Client.VDI.get_uuid rpc session_id vdi
+ and name_label = Client.VDI.get_name_label rpc session_id vdi in
+ warnings := Printf.sprintf "VDI: %s (%s)" uuid name_label :: !warnings
+ with _ -> ()
+ ) vdis
+ with _ -> ()
+ ) srs;
+ !warnings
+ with _ -> []
+ in
+
+ marshal fd (Command (Print "WARNING: Ejecting a host from the pool will reinitialise that host's local SRs."));
+ marshal fd (Command (Print "WARNING: Any data contained with the local SRs will be lost."));
+ if warnings <> [] then begin
+ marshal fd (Command (Print "The following VDI objects will be destroyed:"));
+ List.iter (fun msg -> marshal fd (Command (Print msg))) warnings
+ end;
+ if user_says_yes fd
+ then go ()
+ end
let pool_emergency_reset_master printer rpc session_id params =
- let master_address = List.assoc "master-address" params in
- Client.Pool.emergency_reset_master ~rpc ~session_id ~master_address;
- printer (Cli_printer.PList ["Host agent will restart and become slave of "^master_address^" in "^(string_of_int Xapi_globs.fuse_time)^" seconds..."])
+ let master_address = List.assoc "master-address" params in
+ Client.Pool.emergency_reset_master ~rpc ~session_id ~master_address;
+ printer (Cli_printer.PList ["Host agent will restart and become slave of "^master_address^" in "^(string_of_int Xapi_globs.fuse_time)^" seconds..."])
let pool_emergency_transition_to_master printer rpc session_id params =
- Client.Pool.emergency_transition_to_master ~rpc ~session_id;
- printer (Cli_printer.PList ["Host agent will restart and transition to master in "^(string_of_int Xapi_globs.fuse_time)^" seconds..."])
+ Client.Pool.emergency_transition_to_master ~rpc ~session_id;
+ printer (Cli_printer.PList ["Host agent will restart and transition to master in "^(string_of_int Xapi_globs.fuse_time)^" seconds..."])
let pool_recover_slaves printer rpc session_id params =
- let hosts = Client.Pool.recover_slaves ~rpc ~session_id in
- let host_uuids = List.map (fun href -> Client.Host.get_uuid rpc session_id href) hosts in
- printer (Cli_printer.PList host_uuids)
+ let hosts = Client.Pool.recover_slaves ~rpc ~session_id in
+ let host_uuids = List.map (fun href -> Client.Host.get_uuid rpc session_id href) hosts in
+ printer (Cli_printer.PList host_uuids)
let pool_initialize_wlb printer rpc session_id params =
let wlb_url = List.assoc "wlb_url" params in
Client.Pool.initialize_wlb ~rpc ~session_id ~wlb_url ~wlb_username ~wlb_password ~xenserver_username ~xenserver_password
let pool_deconfigure_wlb printer rpc session_id params =
- Client.Pool.deconfigure_wlb ~rpc ~session_id
+ Client.Pool.deconfigure_wlb ~rpc ~session_id
let pool_send_wlb_configuration printer rpc session_id params =
- let len = String.length "config:" in
- let filter_params = List.filter (fun (p,_) -> (String.startswith "config" p) && (String.length p > len)) params in
- let config = List.map (fun (k,v) -> String.sub k len (String.length k - len),v) filter_params in
- Client.Pool.send_wlb_configuration ~rpc ~session_id ~config
+ let len = String.length "config:" in
+ let filter_params = List.filter (fun (p,_) -> (String.startswith "config" p) && (String.length p > len)) params in
+ let config = List.map (fun (k,v) -> String.sub k len (String.length k - len),v) filter_params in
+ Client.Pool.send_wlb_configuration ~rpc ~session_id ~config
let pool_retrieve_wlb_configuration printer rpc session_id params =
- printer (Cli_printer.PTable [(Client.Pool.retrieve_wlb_configuration ~rpc ~session_id)])
+ printer (Cli_printer.PTable [(Client.Pool.retrieve_wlb_configuration ~rpc ~session_id)])
let pool_retrieve_wlb_recommendations printer rpc session_id params =
- let table t =
- List.map (fun (vm, recom) -> (Printf.sprintf "%s (%s)" (Client.VM.get_uuid rpc session_id vm) (Client.VM.get_name_label rpc session_id vm), String.concat " " recom)) t
- in
- printer (Cli_printer.PTable ([("VM", "Host, OptID, RecID, Reason") :: table (Client.Pool.retrieve_wlb_recommendations ~rpc ~session_id)]))
+ let table t =
+ List.map (fun (vm, recom) -> (Printf.sprintf "%s (%s)" (Client.VM.get_uuid rpc session_id vm) (Client.VM.get_name_label rpc session_id vm), String.concat " " recom)) t
+ in
+ printer (Cli_printer.PTable ([("VM", "Host, OptID, RecID, Reason") :: table (Client.Pool.retrieve_wlb_recommendations ~rpc ~session_id)]))
let pool_send_test_post printer rpc session_id params =
- let host = List.assoc "dest-host" params in
- let port = Int64.of_string (List.assoc "dest-port" params) in
- let body = List.assoc "body" params in
- printer (Cli_printer.PMsg
- (Client.Pool.send_test_post ~rpc ~session_id ~host ~port ~body))
+ let host = List.assoc "dest-host" params in
+ let port = Int64.of_string (List.assoc "dest-port" params) in
+ let body = List.assoc "body" params in
+ printer (Cli_printer.PMsg
+ (Client.Pool.send_test_post ~rpc ~session_id ~host ~port ~body))
let pool_certificate_install fd printer rpc session_id params =
- let filename = List.assoc "filename" params in
- match get_client_file fd filename with
- | Some cert ->
- Client.Pool.certificate_install ~rpc ~session_id ~name:filename
- ~cert
- | None ->
- marshal fd (Command (PrintStderr "Failed to read certificate"));
- raise (ExitWithError 1)
+ let filename = List.assoc "filename" params in
+ match get_client_file fd filename with
+ | Some cert ->
+ Client.Pool.certificate_install ~rpc ~session_id ~name:filename
+ ~cert
+ | None ->
+ marshal fd (Command (PrintStderr "Failed to read certificate"));
+ raise (ExitWithError 1)
let pool_certificate_uninstall printer rpc session_id params =
- let name = List.assoc "name" params in
- Client.Pool.certificate_uninstall ~rpc ~session_id ~name
+ let name = List.assoc "name" params in
+ Client.Pool.certificate_uninstall ~rpc ~session_id ~name
let pool_certificate_list printer rpc session_id params =
- printer (Cli_printer.PList
- (Client.Pool.certificate_list ~rpc ~session_id))
+ printer (Cli_printer.PList
+ (Client.Pool.certificate_list ~rpc ~session_id))
let pool_crl_install fd printer rpc session_id params =
- let filename = List.assoc "filename" params in
- match get_client_file fd filename with
- | Some cert ->
- Client.Pool.crl_install ~rpc ~session_id ~name:filename ~cert
- | None ->
- marshal fd (Command (PrintStderr "Failed to read CRL"));
- raise (ExitWithError 1)
+ let filename = List.assoc "filename" params in
+ match get_client_file fd filename with
+ | Some cert ->
+ Client.Pool.crl_install ~rpc ~session_id ~name:filename ~cert
+ | None ->
+ marshal fd (Command (PrintStderr "Failed to read CRL"));
+ raise (ExitWithError 1)
let pool_crl_uninstall printer rpc session_id params =
- let name = List.assoc "name" params in
- Client.Pool.crl_uninstall ~rpc ~session_id ~name
+ let name = List.assoc "name" params in
+ Client.Pool.crl_uninstall ~rpc ~session_id ~name
let pool_crl_list printer rpc session_id params =
- printer (Cli_printer.PList
- (Client.Pool.crl_list ~rpc ~session_id))
+ printer (Cli_printer.PList
+ (Client.Pool.crl_list ~rpc ~session_id))
let pool_certificate_sync printer rpc session_id params =
- Client.Pool.certificate_sync ~rpc ~session_id
+ Client.Pool.certificate_sync ~rpc ~session_id
let pool_enable_redo_log printer rpc session_id params =
- let sr = Client.SR.get_by_uuid rpc session_id (List.assoc "sr-uuid" params) in
- Client.Pool.enable_redo_log ~rpc ~session_id ~sr
+ let sr = Client.SR.get_by_uuid rpc session_id (List.assoc "sr-uuid" params) in
+ Client.Pool.enable_redo_log ~rpc ~session_id ~sr
let pool_disable_redo_log printer rpc session_id params =
- Client.Pool.disable_redo_log ~rpc ~session_id
+ Client.Pool.disable_redo_log ~rpc ~session_id
let pool_set_vswitch_controller printer rpc session_id params =
let address = List.assoc "address" params in
Client.Pool.set_vswitch_controller ~rpc ~session_id ~address
let vdi_type_of_string = function
- | "system" -> `system
- | "user" -> `user
- | "suspend" -> `suspend
- | "crashdump" -> `crashdump
- | x -> failwith (Printf.sprintf "Unknown vdi type: %s" x)
+ | "system" -> `system
+ | "user" -> `user
+ | "suspend" -> `suspend
+ | "crashdump" -> `crashdump
+ | x -> failwith (Printf.sprintf "Unknown vdi type: %s" x)
let vdi_create printer rpc session_id params =
- let sR = Client.SR.get_by_uuid rpc session_id (List.assoc "sr-uuid" params) in
- let name_label=List.assoc "name-label" params in
- let str_type = List.assoc "type" params in
- let virtual_size = Record_util.bytes_of_string "virtual-size" (List.assoc "virtual-size" params) in
- let ty = vdi_type_of_string str_type in
+ let sR = Client.SR.get_by_uuid rpc session_id (List.assoc "sr-uuid" params) in
+ let name_label=List.assoc "name-label" params in
+ let str_type = List.assoc "type" params in
+ let virtual_size = Record_util.bytes_of_string "virtual-size" (List.assoc "virtual-size" params) in
+ let ty = vdi_type_of_string str_type in
- let sm_config=read_map_params "sm-config" params in
+ let sm_config=read_map_params "sm-config" params in
- let vdi = Client.VDI.create ~rpc ~session_id ~name_label ~name_description:"" ~sR ~virtual_size ~_type:ty
- ~sharable:false ~read_only:false ~xenstore_data:[] ~other_config:[] ~sm_config ~tags:[] in
- let vdi_uuid = Client.VDI.get_uuid rpc session_id vdi in
- printer (Cli_printer.PList [vdi_uuid])
+ let vdi = Client.VDI.create ~rpc ~session_id ~name_label ~name_description:"" ~sR ~virtual_size ~_type:ty
+ ~sharable:false ~read_only:false ~xenstore_data:[] ~other_config:[] ~sm_config ~tags:[] in
+ let vdi_uuid = Client.VDI.get_uuid rpc session_id vdi in
+ printer (Cli_printer.PList [vdi_uuid])
let vdi_introduce printer rpc session_id params =
- let uuid = List.assoc "uuid" params in
- let sR = Client.SR.get_by_uuid rpc session_id (List.assoc "sr-uuid" params) in
- (* CA-13140: Some of the backends set their own name-labels, and the VDI introduce will
- not override them if we pass in the empty string. *)
- let name_label = try List.assoc "name-label" params with _ -> "" in
- let name_description = if List.mem_assoc "name-description" params then List.assoc "name-description" params else "" in
- let _type = vdi_type_of_string (List.assoc "type" params) in
- let sharable = get_bool_param params "sharable" in
- let read_only = get_bool_param params "read-only" in
- (* NB call is new so backwards compat other-config- not required *)
- let other_config = read_map_params "other-config" params in
- let xenstore_data = read_map_params "xenstore-data" params in
- let sm_config = read_map_params "sm-config" params in
- let location = List.assoc "location" params in
- let vdi = Client.VDI.introduce ~rpc ~session_id ~uuid ~name_label ~name_description
- ~sR ~_type ~sharable ~read_only ~other_config ~location ~xenstore_data ~sm_config in
- (* round-trip catches partial application errors *)
- let vdi_uuid = Client.VDI.get_uuid ~rpc ~session_id ~self:vdi in
- printer (Cli_printer.PList [ vdi_uuid ])
+ let uuid = List.assoc "uuid" params in
+ let sR = Client.SR.get_by_uuid rpc session_id (List.assoc "sr-uuid" params) in
+ (* CA-13140: Some of the backends set their own name-labels, and the VDI introduce will
+ not override them if we pass in the empty string. *)
+ let name_label = try List.assoc "name-label" params with _ -> "" in
+ let name_description = if List.mem_assoc "name-description" params then List.assoc "name-description" params else "" in
+ let _type = vdi_type_of_string (List.assoc "type" params) in
+ let sharable = get_bool_param params "sharable" in
+ let read_only = get_bool_param params "read-only" in
+ (* NB call is new so backwards compat other-config- not required *)
+ let other_config = read_map_params "other-config" params in
+ let xenstore_data = read_map_params "xenstore-data" params in
+ let sm_config = read_map_params "sm-config" params in
+ let location = List.assoc "location" params in
+ let vdi = Client.VDI.introduce ~rpc ~session_id ~uuid ~name_label ~name_description
+ ~sR ~_type ~sharable ~read_only ~other_config ~location ~xenstore_data ~sm_config in
+ (* round-trip catches partial application errors *)
+ let vdi_uuid = Client.VDI.get_uuid ~rpc ~session_id ~self:vdi in
+ printer (Cli_printer.PList [ vdi_uuid ])
let vdi_resize printer rpc session_id params =
- let vdi = Client.VDI.get_by_uuid rpc session_id (List.assoc "uuid" params) in
- let new_size = Record_util.bytes_of_string "disk-size" (List.assoc "disk-size" params) in
- let online = List.mem_assoc "online" params && (List.assoc "online" params = "true") in
- if online
- then Client.VDI.resize_online rpc session_id vdi new_size
- else Client.VDI.resize rpc session_id vdi new_size
+ let vdi = Client.VDI.get_by_uuid rpc session_id (List.assoc "uuid" params) in
+ let new_size = Record_util.bytes_of_string "disk-size" (List.assoc "disk-size" params) in
+ let online = List.mem_assoc "online" params && (List.assoc "online" params = "true") in
+ if online
+ then Client.VDI.resize_online rpc session_id vdi new_size
+ else Client.VDI.resize rpc session_id vdi new_size
let vdi_generate_config printer rpc session_id params =
- let vdi = Client.VDI.get_by_uuid rpc session_id (List.assoc "uuid" params) in
- let host = Client.Host.get_by_uuid rpc session_id (List.assoc "host-uuid" params) in
- printer (Cli_printer.PList [ Client.VDI.generate_config rpc session_id host vdi ])
+ let vdi = Client.VDI.get_by_uuid rpc session_id (List.assoc "uuid" params) in
+ let host = Client.Host.get_by_uuid rpc session_id (List.assoc "host-uuid" params) in
+ printer (Cli_printer.PList [ Client.VDI.generate_config rpc session_id host vdi ])
let vdi_copy printer rpc session_id params =
- let vdi = Client.VDI.get_by_uuid rpc session_id (List.assoc "uuid" params) in
- let sr = Client.SR.get_by_uuid rpc session_id (List.assoc "sr-uuid" params) in
- let newvdi = Client.VDI.copy rpc session_id vdi sr in
- let newuuid = Client.VDI.get_uuid rpc session_id newvdi in
- printer (Cli_printer.PList [newuuid])
+ let vdi = Client.VDI.get_by_uuid rpc session_id (List.assoc "uuid" params) in
+ let sr = Client.SR.get_by_uuid rpc session_id (List.assoc "sr-uuid" params) in
+ let newvdi = Client.VDI.copy rpc session_id vdi sr in
+ let newuuid = Client.VDI.get_uuid rpc session_id newvdi in
+ printer (Cli_printer.PList [newuuid])
let vdi_clone printer rpc session_id params =
- let vdi = Client.VDI.get_by_uuid rpc session_id (List.assoc "uuid" params) in
- let driver_params = read_map_params "driver-params" params in
- let name_label = try Some (List.assoc "new-name-label" params) with Not_found -> None in
- let name_description = try Some (List.assoc "new-name-description" params) with Not_found -> None in
- let newvdi = Client.VDI.clone rpc session_id vdi driver_params in
- maybe (fun x -> Client.VDI.set_name_label rpc session_id newvdi x) name_label;
- maybe (fun x -> Client.VDI.set_name_description rpc session_id newvdi x) name_description;
- let newuuid = Client.VDI.get_uuid rpc session_id newvdi in
- printer (Cli_printer.PList [newuuid])
+ let vdi = Client.VDI.get_by_uuid rpc session_id (List.assoc "uuid" params) in
+ let driver_params = read_map_params "driver-params" params in
+ let name_label = try Some (List.assoc "new-name-label" params) with Not_found -> None in
+ let name_description = try Some (List.assoc "new-name-description" params) with Not_found -> None in
+ let newvdi = Client.VDI.clone rpc session_id vdi driver_params in
+ maybe (fun x -> Client.VDI.set_name_label rpc session_id newvdi x) name_label;
+ maybe (fun x -> Client.VDI.set_name_description rpc session_id newvdi x) name_description;
+ let newuuid = Client.VDI.get_uuid rpc session_id newvdi in
+ printer (Cli_printer.PList [newuuid])
let vdi_snapshot printer rpc session_id params =
- let vdi = Client.VDI.get_by_uuid rpc session_id (List.assoc "uuid" params) in
- let driver_params = read_map_params "driver-params" params in
- let newvdi = Client.VDI.snapshot rpc session_id vdi driver_params in
- let newuuid = Client.VDI.get_uuid rpc session_id newvdi in
- printer (Cli_printer.PList [newuuid])
+ let vdi = Client.VDI.get_by_uuid rpc session_id (List.assoc "uuid" params) in
+ let driver_params = read_map_params "driver-params" params in
+ let newvdi = Client.VDI.snapshot rpc session_id vdi driver_params in
+ let newuuid = Client.VDI.get_uuid rpc session_id newvdi in
+ printer (Cli_printer.PList [newuuid])
let vdi_destroy printer rpc session_id params =
- let vdi = Client.VDI.get_by_uuid rpc session_id (List.assoc "uuid" params) in
- Client.VDI.destroy rpc session_id vdi
+ let vdi = Client.VDI.get_by_uuid rpc session_id (List.assoc "uuid" params) in
+ Client.VDI.destroy rpc session_id vdi
let vdi_forget printer rpc session_id params =
- let vdi = Client.VDI.get_by_uuid rpc session_id (List.assoc "uuid" params) in
- Client.VDI.forget rpc session_id vdi
+ let vdi = Client.VDI.get_by_uuid rpc session_id (List.assoc "uuid" params) in
+ Client.VDI.forget rpc session_id vdi
let vdi_update printer rpc session_id params =
- let vdi = Client.VDI.get_by_uuid rpc session_id (List.assoc "uuid" params) in
- Client.VDI.update rpc session_id vdi
+ let vdi = Client.VDI.get_by_uuid rpc session_id (List.assoc "uuid" params) in
+ Client.VDI.update rpc session_id vdi
let vdi_unlock printer rpc session_id params =
- let vdi = Client.VDI.get_by_uuid rpc session_id (List.assoc "uuid" params) in
- if not(List.mem_assoc "force" params)
- then failwith "This operation is extremely dangerous and may cause data loss. This operation must be forced (use --force).";
- Client.VDI.force_unlock rpc session_id vdi
+ let vdi = Client.VDI.get_by_uuid rpc session_id (List.assoc "uuid" params) in
+ if not(List.mem_assoc "force" params)
+ then failwith "This operation is extremely dangerous and may cause data loss. This operation must be forced (use --force).";
+ Client.VDI.force_unlock rpc session_id vdi
let diagnostic_vdi_status printer rpc session_id params =
- let vdi = Client.VDI.get_by_uuid rpc session_id (List.assoc "uuid" params) in
- let vdi_r = vdi_record rpc session_id vdi in
- let vdi_fields = List.filter
- (fun x -> List.mem x.name [ "uuid"; "name-label"; "sr-uuid"; "mode"; "read-only"; "sharable"; "storage-lock" ]) vdi_r.fields in
- printer (Cli_printer.PTable [List.map print_field vdi_fields]);
- let all_vbds = Client.VDI.get_VBDs rpc session_id vdi in
- let all_vbd_records = List.map (vbd_record rpc session_id) all_vbds in
- let active_records = List.filter (fun x -> (field_lookup (x.fields) "currently-attached").get() = "true") all_vbd_records in
- let inactive_records = set_difference all_vbd_records active_records in
- let show_vbds records =
- List.iter (fun vbd_record ->
- let fields = List.filter (fun x -> List.mem x.name [ "uuid"; "userdevice"; "device"; "empty"; "mode"; "type"; "storage-lock" ]) vbd_record.fields in
- printer (Cli_printer.PTable [List.map print_field fields])) records in
- if active_records = []
- then printer (Cli_printer.PList [ "no active VBDs." ])
- else begin
- printer (Cli_printer.PList [ "active VBDs:" ]);
- show_vbds active_records;
- end;
- if inactive_records <> [] then begin
- printer (Cli_printer.PList [ "inactive VBDs:" ]);
- show_vbds inactive_records
- end
+ let vdi = Client.VDI.get_by_uuid rpc session_id (List.assoc "uuid" params) in
+ let vdi_r = vdi_record rpc session_id vdi in
+ let vdi_fields = List.filter
+ (fun x -> List.mem x.name [ "uuid"; "name-label"; "sr-uuid"; "mode"; "read-only"; "sharable"; "storage-lock" ]) vdi_r.fields in
+ printer (Cli_printer.PTable [List.map print_field vdi_fields]);
+ let all_vbds = Client.VDI.get_VBDs rpc session_id vdi in
+ let all_vbd_records = List.map (vbd_record rpc session_id) all_vbds in
+ let active_records = List.filter (fun x -> (field_lookup (x.fields) "currently-attached").get() = "true") all_vbd_records in
+ let inactive_records = set_difference all_vbd_records active_records in
+ let show_vbds records =
+ List.iter (fun vbd_record ->
+ let fields = List.filter (fun x -> List.mem x.name [ "uuid"; "userdevice"; "device"; "empty"; "mode"; "type"; "storage-lock" ]) vbd_record.fields in
+ printer (Cli_printer.PTable [List.map print_field fields])) records in
+ if active_records = []
+ then printer (Cli_printer.PList [ "no active VBDs." ])
+ else begin
+ printer (Cli_printer.PList [ "active VBDs:" ]);
+ show_vbds active_records;
+ end;
+ if inactive_records <> [] then begin
+ printer (Cli_printer.PList [ "inactive VBDs:" ]);
+ show_vbds inactive_records
+ end
(* Print a table of hosts, reporting whether a VM can start on each host and if not, why not! *)
let print_assert_exception e =
- let rec get_arg n xs =
- match n,xs with
- 1,x::_ -> x
- | n,_::xs -> get_arg (n-1) xs
- | _ -> "<server did not provide reference>" in
- match e with
- Api_errors.Server_error(code, params) when code=Api_errors.vm_requires_sr ->
- "VM requires access to SR: "^(Cli_util.ref_convert (get_arg 2 params))
- | Api_errors.Server_error(code, params) when code=Api_errors.host_disabled ->
- "Host disabled (use 'xe host-enable' to re-enable)"
- | Api_errors.Server_error(code, params) when code=Api_errors.host_not_live ->
- "Host down"
- | Api_errors.Server_error(code, params) when code=Api_errors.host_not_enough_free_memory ->
- Printf.sprintf "Not enough free memory"
- | Api_errors.Server_error(code, params) when code=Api_errors.vm_requires_net ->
- "VM requires access to network: "^(Cli_util.ref_convert (get_arg 2 params))
- | Api_errors.Server_error(code, params) when code=Api_errors.host_cannot_attach_network ->
- "Host cannot attach to network: "^(Cli_util.ref_convert (get_arg 2 params))
- | Api_errors.Server_error(code, params) when code=Api_errors.vm_hvm_required ->
- "HVM not supported"
- | Api_errors.Server_error(code, [key; v] ) when code=Api_errors.invalid_value ->
- Printf.sprintf "Field has invalid value: %s = %s" key v
-
- (* Used by VM.assert_agile: *)
- | Api_errors.Server_error(code, [ sr ]) when code=Api_errors.ha_constraint_violation_sr_not_shared ->
- Printf.sprintf "VM requires access to non-shared SR: %s. SR must both be marked as shared and a properly configured PBD must be plugged-in on every host" (Cli_util.ref_convert sr)
- | Api_errors.Server_error(code, [ net]) when code = Api_errors.ha_constraint_violation_network_not_shared ->
- Printf.sprintf "VM requires access to non-shared Network: %s. Network must either be entirely virtual or there must be a PIF connecting to this Network on every host." (Cli_util.ref_convert net)
-
- | e -> Printexc.to_string e
+ let rec get_arg n xs =
+ match n,xs with
+ 1,x::_ -> x
+ | n,_::xs -> get_arg (n-1) xs
+ | _ -> "<server did not provide reference>" in
+ match e with
+ Api_errors.Server_error(code, params) when code=Api_errors.vm_requires_sr ->
+ "VM requires access to SR: "^(Cli_util.ref_convert (get_arg 2 params))
+ | Api_errors.Server_error(code, params) when code=Api_errors.host_disabled ->
+ "Host disabled (use 'xe host-enable' to re-enable)"
+ | Api_errors.Server_error(code, params) when code=Api_errors.host_not_live ->
+ "Host down"
+ | Api_errors.Server_error(code, params) when code=Api_errors.host_not_enough_free_memory ->
+ Printf.sprintf "Not enough free memory"
+ | Api_errors.Server_error(code, params) when code=Api_errors.vm_requires_net ->
+ "VM requires access to network: "^(Cli_util.ref_convert (get_arg 2 params))
+ | Api_errors.Server_error(code, params) when code=Api_errors.host_cannot_attach_network ->
+ "Host cannot attach to network: "^(Cli_util.ref_convert (get_arg 2 params))
+ | Api_errors.Server_error(code, params) when code=Api_errors.vm_hvm_required ->
+ "HVM not supported"
+ | Api_errors.Server_error(code, [key; v] ) when code=Api_errors.invalid_value ->
+ Printf.sprintf "Field has invalid value: %s = %s" key v
+
+ (* Used by VM.assert_agile: *)
+ | Api_errors.Server_error(code, [ sr ]) when code=Api_errors.ha_constraint_violation_sr_not_shared ->
+ Printf.sprintf "VM requires access to non-shared SR: %s. SR must both be marked as shared and a properly configured PBD must be plugged-in on every host" (Cli_util.ref_convert sr)
+ | Api_errors.Server_error(code, [ net]) when code = Api_errors.ha_constraint_violation_network_not_shared ->
+ Printf.sprintf "VM requires access to non-shared Network: %s. Network must either be entirely virtual or there must be a PIF connecting to this Network on every host." (Cli_util.ref_convert net)
+
+ | e -> Printexc.to_string e
let print_vm_host_report printer rpc session_id vm_ref =
- let hosts = Client.Host.get_all rpc session_id in
- let table = List.map (fun host -> Client.Host.get_name_label rpc session_id host,
- try Client.VM.assert_can_boot_here rpc session_id vm_ref host; "OK"
- with e -> "Cannot start here ["^(print_assert_exception e)^"]") hosts in
- printer (Cli_printer.PTable [table])
+ let hosts = Client.Host.get_all rpc session_id in
+ let table = List.map (fun host -> Client.Host.get_name_label rpc session_id host,
+ try Client.VM.assert_can_boot_here rpc session_id vm_ref host; "OK"
+ with e -> "Cannot start here ["^(print_assert_exception e)^"]") hosts in
+ printer (Cli_printer.PTable [table])
let diagnostic_vm_status printer rpc session_id params =
- let vm = Client.VM.get_by_uuid rpc session_id (List.assoc "uuid" params) in
- let vm_r = vm_record rpc session_id vm in
- let vm_fields = List.filter
- (fun x -> List.mem x.name [ "uuid"; "name-label"; "power-state"; "possible-hosts"]) vm_r.fields in
-
- printer (Cli_printer.PTable [List.map print_field vm_fields]);
- printer (Cli_printer.PList [ "Checking to see whether disks are attachable" ]);
- let show_vbds records =
- List.iter (fun vbd_record ->
- let fields = List.filter (fun x -> List.mem x.name [ "uuid"; "userdevice"; "device"; "vdi-uuid"; "empty"; "mode"; "type"; "storage-lock"; "attachable" ]) vbd_record.fields in
- printer (Cli_printer.PTable [List.map print_field fields])) records in
- let all_vbds = Client.VM.get_VBDs rpc session_id vm in
- let all_vbd_records = List.map (vbd_record rpc session_id) all_vbds in
- show_vbds all_vbd_records;
- printer (Cli_printer.PList [ "Checking to see whether VM can boot on each host" ]);
- print_vm_host_report printer rpc session_id vm;
- printer (Cli_printer.PList [
- try Client.VM.assert_agile rpc session_id vm; "VM is agile."
- with e -> "VM is not agile because: " ^ (print_assert_exception e) ])
+ let vm = Client.VM.get_by_uuid rpc session_id (List.assoc "uuid" params) in
+ let vm_r = vm_record rpc session_id vm in
+ let vm_fields = List.filter
+ (fun x -> List.mem x.name [ "uuid"; "name-label"; "power-state"; "possible-hosts"]) vm_r.fields in
+
+ printer (Cli_printer.PTable [List.map print_field vm_fields]);
+ printer (Cli_printer.PList [ "Checking to see whether disks are attachable" ]);
+ let show_vbds records =
+ List.iter (fun vbd_record ->
+ let fields = List.filter (fun x -> List.mem x.name [ "uuid"; "userdevice"; "device"; "vdi-uuid"; "empty"; "mode"; "type"; "storage-lock"; "attachable" ]) vbd_record.fields in
+ printer (Cli_printer.PTable [List.map print_field fields])) records in
+ let all_vbds = Client.VM.get_VBDs rpc session_id vm in
+ let all_vbd_records = List.map (vbd_record rpc session_id) all_vbds in
+ show_vbds all_vbd_records;
+ printer (Cli_printer.PList [ "Checking to see whether VM can boot on each host" ]);
+ print_vm_host_report printer rpc session_id vm;
+ printer (Cli_printer.PList [
+ try Client.VM.assert_agile rpc session_id vm; "VM is agile."
+ with e -> "VM is not agile because: " ^ (print_assert_exception e) ])
(* VBD create destroy list param-list param-get param-set param-add param-remove *)
let vbd_create printer rpc session_id params =
- let vM=Client.VM.get_by_uuid ~rpc ~session_id ~uuid:(List.assoc "vm-uuid" params) in
- let empty = not(List.mem_assoc "vdi-uuid" params) in
- let vDI =
- if empty
- then Ref.null
- else Client.VDI.get_by_uuid ~rpc ~session_id ~uuid:(List.assoc "vdi-uuid" params) in
- let bootable = get_bool_param params "bootable" in
- let mode =
- if List.mem_assoc "mode" params
- then match String.lowercase (List.assoc "mode" params) with
- | "ro" -> `RO | "rw" -> `RW
- | x -> failwith (Printf.sprintf "Unknown mode: %s (should be \"ro\" or \"rw\"" x)
- else `RW in
- let _type =
- if List.mem_assoc "type" params
- then match String.lowercase (List.assoc "type" params) with
- | "cd" -> `CD | "disk" -> `Disk
- | x -> failwith (Printf.sprintf "Unknown type: %s (should be \"cd\" or \"disk\"" x)
- else `Disk in
- let unpluggable = get_bool_param params ~default:true "unpluggable" in
- if _type=`Disk && empty then failwith "Empty VBDs can only be made for type=CD";
- let vbd=Client.VBD.create ~rpc ~session_id ~vM ~vDI ~userdevice:(List.assoc "device" params)
- ~bootable
- ~mode
- ~_type
- ~unpluggable
- ~empty
- ~qos_algorithm_type:""
- ~qos_algorithm_params:[] ~other_config:[] in
- let vbd_uuid=Client.VBD.get_uuid rpc session_id vbd in
- printer (Cli_printer.PList [vbd_uuid])
+ let vM=Client.VM.get_by_uuid ~rpc ~session_id ~uuid:(List.assoc "vm-uuid" params) in
+ let empty = not(List.mem_assoc "vdi-uuid" params) in
+ let vDI =
+ if empty
+ then Ref.null
+ else Client.VDI.get_by_uuid ~rpc ~session_id ~uuid:(List.assoc "vdi-uuid" params) in
+ let bootable = get_bool_param params "bootable" in
+ let mode =
+ if List.mem_assoc "mode" params
+ then match String.lowercase (List.assoc "mode" params) with
+ | "ro" -> `RO | "rw" -> `RW
+ | x -> failwith (Printf.sprintf "Unknown mode: %s (should be \"ro\" or \"rw\"" x)
+ else `RW in
+ let _type =
+ if List.mem_assoc "type" params
+ then match String.lowercase (List.assoc "type" params) with
+ | "cd" -> `CD | "disk" -> `Disk
+ | x -> failwith (Printf.sprintf "Unknown type: %s (should be \"cd\" or \"disk\"" x)
+ else `Disk in
+ let unpluggable = get_bool_param params ~default:true "unpluggable" in
+ if _type=`Disk && empty then failwith "Empty VBDs can only be made for type=CD";
+ let vbd=Client.VBD.create ~rpc ~session_id ~vM ~vDI ~userdevice:(List.assoc "device" params)
+ ~bootable
+ ~mode
+ ~_type
+ ~unpluggable
+ ~empty
+ ~qos_algorithm_type:""
+ ~qos_algorithm_params:[] ~other_config:[] in
+ let vbd_uuid=Client.VBD.get_uuid rpc session_id vbd in
+ printer (Cli_printer.PList [vbd_uuid])
let vbd_destroy printer rpc session_id params =
- let self = Client.VBD.get_by_uuid ~rpc ~session_id ~uuid:(List.assoc "uuid" params) in
- Client.VBD.destroy ~rpc ~session_id ~self
+ let self = Client.VBD.get_by_uuid ~rpc ~session_id ~uuid:(List.assoc "uuid" params) in
+ Client.VBD.destroy ~rpc ~session_id ~self
let vbd_eject printer rpc session_id params =
- let self = Client.VBD.get_by_uuid ~rpc ~session_id ~uuid:(List.assoc "uuid" params) in
- Client.VBD.eject rpc session_id self
+ let self = Client.VBD.get_by_uuid ~rpc ~session_id ~uuid:(List.assoc "uuid" params) in
+ Client.VBD.eject rpc session_id self
let vbd_insert printer rpc session_id params =
- let self = Client.VBD.get_by_uuid ~rpc ~session_id ~uuid:(List.assoc "uuid" params) in
- let vdi_uuid = List.assoc "vdi-uuid" params in
- let vdi = Client.VDI.get_by_uuid rpc session_id vdi_uuid in
- Client.VBD.insert rpc session_id self vdi
+ let self = Client.VBD.get_by_uuid ~rpc ~session_id ~uuid:(List.assoc "uuid" params) in
+ let vdi_uuid = List.assoc "vdi-uuid" params in
+ let vdi = Client.VDI.get_by_uuid rpc session_id vdi_uuid in
+ Client.VBD.insert rpc session_id self vdi
let vbd_plug printer rpc session_id params =
- let vbd = Client.VBD.get_by_uuid ~rpc ~session_id ~uuid:(List.assoc "uuid" params) in
- Client.VBD.plug rpc session_id vbd
+ let vbd = Client.VBD.get_by_uuid ~rpc ~session_id ~uuid:(List.assoc "uuid" params) in
+ Client.VBD.plug rpc session_id vbd
let vbd_unplug printer rpc session_id params =
- let vbd = Client.VBD.get_by_uuid ~rpc ~session_id ~uuid:(List.assoc "uuid" params) in
- let timeout =
- if List.mem_assoc "timeout" params then
- (try float_of_string (List.assoc "timeout" params) with _ -> failwith "Failed to parse parameter 'timeout': expecting a float")
- else 0. in
- let force = get_bool_param params "force" in
- let start = Unix.gettimeofday () in
- try
- (if force then Client.VBD.unplug_force else Client.VBD.unplug) rpc session_id vbd
- with Api_errors.Server_error(code, _) as e when code = Api_errors.device_detach_rejected ->
- (* enter polling mode *)
- let unplugged = ref false in
- while not(!unplugged) && (Unix.gettimeofday () -. start < timeout) do
- Thread.delay 5.;
- unplugged := not(Client.VBD.get_currently_attached rpc session_id vbd)
- done;
- if not(!unplugged) then raise e
+ let vbd = Client.VBD.get_by_uuid ~rpc ~session_id ~uuid:(List.assoc "uuid" params) in
+ let timeout =
+ if List.mem_assoc "timeout" params then
+ (try float_of_string (List.assoc "timeout" params) with _ -> failwith "Failed to parse parameter 'timeout': expecting a float")
+ else 0. in
+ let force = get_bool_param params "force" in
+ let start = Unix.gettimeofday () in
+ try
+ (if force then Client.VBD.unplug_force else Client.VBD.unplug) rpc session_id vbd
+ with Api_errors.Server_error(code, _) as e when code = Api_errors.device_detach_rejected ->
+ (* enter polling mode *)
+ let unplugged = ref false in
+ while not(!unplugged) && (Unix.gettimeofday () -. start < timeout) do
+ Thread.delay 5.;
+ unplugged := not(Client.VBD.get_currently_attached rpc session_id vbd)
+ done;
+ if not(!unplugged) then raise e
let vbd_pause printer rpc session_id params =
- let vbd = Client.VBD.get_by_uuid ~rpc ~session_id ~uuid:(List.assoc "uuid" params) in
- let token = Client.VBD.pause rpc session_id vbd in
- printer (Cli_printer.PList [token])
+ let vbd = Client.VBD.get_by_uuid ~rpc ~session_id ~uuid:(List.assoc "uuid" params) in
+ let token = Client.VBD.pause rpc session_id vbd in
+ printer (Cli_printer.PList [token])
let vbd_unpause printer rpc session_id params =
- let vbd = Client.VBD.get_by_uuid ~rpc ~session_id ~uuid:(List.assoc "uuid" params) in
- let token = List.assoc "token" params in
- Client.VBD.unpause rpc session_id vbd token
+ let vbd = Client.VBD.get_by_uuid ~rpc ~session_id ~uuid:(List.assoc "uuid" params) in
+ let token = List.assoc "token" params in
+ Client.VBD.unpause rpc session_id vbd token
(* SR scan *)
let sr_scan printer rpc session_id params =
- let sr_uuid = List.assoc "uuid" params in
- let sr_ref = Client.SR.get_by_uuid rpc session_id sr_uuid in
- Client.SR.scan rpc session_id sr_ref
+ let sr_uuid = List.assoc "uuid" params in
+ let sr_ref = Client.SR.get_by_uuid rpc session_id sr_uuid in
+ Client.SR.scan rpc session_id sr_ref
let parse_host_uuid rpc session_id params =
- if List.mem_assoc "host-uuid" params then
- let host_uuid=List.assoc "host-uuid" params in
- Client.Host.get_by_uuid rpc session_id host_uuid
- else
- let pool = List.hd (Client.Pool.get_all rpc session_id) in
- Client.Pool.get_master rpc session_id pool
+ if List.mem_assoc "host-uuid" params then
+ let host_uuid=List.assoc "host-uuid" params in
+ Client.Host.get_by_uuid rpc session_id host_uuid
+ else
+ let pool = List.hd (Client.Pool.get_all rpc session_id) in
+ Client.Pool.get_master rpc session_id pool
let parse_device_config params =
- (* Ack! We're supposed to use the format device-config:key=value but we need to match device-config-key=value for *)
- (* backwards compatability *)
- let len = String.length "device-config:" in
- let filter_params = List.filter (fun (p,_) -> (String.startswith "device-config" p) && (String.length p > len)) params in
- List.map (fun (k,v) -> String.sub k len (String.length k - len),v) filter_params
+ (* Ack! We're supposed to use the format device-config:key=value but we need to match device-config-key=value for *)
+ (* backwards compatability *)
+ let len = String.length "device-config:" in
+ let filter_params = List.filter (fun (p,_) -> (String.startswith "device-config" p) && (String.length p > len)) params in
+ List.map (fun (k,v) -> String.sub k len (String.length k - len),v) filter_params
(* SR create destroy list param-list param-get param-set param-add param-remove *)
- let sr_create printer rpc session_id params =
- let name_label=List.assoc "name-label" params in
- let host = parse_host_uuid rpc session_id params in
- let physical_size=
- try
- Record_util.bytes_of_string "physical-size" (List.assoc "physical-size" params)
- with _ -> 0L in
- let _type=List.assoc "type" params in
- let content_type = List.assoc_default "content-type" params "" in
- let shared = get_bool_param params "shared" in
-
- let device_config = parse_device_config params in
-
- let len = String.length "sm-config:" in
- let filter_params = List.filter (fun (p,_) -> (String.startswith "sm-config" p) && (String.length p > len)) params in
- let sm_config = List.map (fun (k,v) -> String.sub k len (String.length k - len),v) filter_params in
-
- let sr=Client.SR.create ~rpc ~session_id ~host ~device_config ~name_label
- ~name_description:""
- ~physical_size ~_type ~content_type ~shared:shared ~sm_config in
- let sr_uuid=Client.SR.get_uuid ~rpc ~session_id ~self:sr in
- printer (Cli_printer.PList [sr_uuid])
+let sr_create printer rpc session_id params =
+ let name_label=List.assoc "name-label" params in
+ let host = parse_host_uuid rpc session_id params in
+ let physical_size=
+ try
+ Record_util.bytes_of_string "physical-size" (List.assoc "physical-size" params)
+ with _ -> 0L in
+ let _type=List.assoc "type" params in
+ let content_type = List.assoc_default "content-type" params "" in
+ let shared = get_bool_param params "shared" in
+
+ let device_config = parse_device_config params in
+
+ let len = String.length "sm-config:" in
+ let filter_params = List.filter (fun (p,_) -> (String.startswith "sm-config" p) && (String.length p > len)) params in
+ let sm_config = List.map (fun (k,v) -> String.sub k len (String.length k - len),v) filter_params in
+
+ let sr=Client.SR.create ~rpc ~session_id ~host ~device_config ~name_label
+ ~name_description:""
+ ~physical_size ~_type ~content_type ~shared:shared ~sm_config in
+ let sr_uuid=Client.SR.get_uuid ~rpc ~session_id ~self:sr in
+ printer (Cli_printer.PList [sr_uuid])
let sr_introduce printer rpc session_id params =
- let name_label=List.assoc "name-label" params in
- let _type=List.assoc "type" params in
- let content_type = List.assoc_default "content-type" params "" in
- let uuid = List.assoc "uuid" params in
- let shared = get_bool_param params "shared" in
- let _ = Client.SR.introduce ~rpc ~session_id ~uuid ~name_label ~name_description:"" ~_type ~content_type ~shared ~sm_config:[] in
- printer (Cli_printer.PList [uuid])
+ let name_label=List.assoc "name-label" params in
+ let _type=List.assoc "type" params in
+ let content_type = List.assoc_default "content-type" params "" in
+ let uuid = List.assoc "uuid" params in
+ let shared = get_bool_param params "shared" in
+ let _ = Client.SR.introduce ~rpc ~session_id ~uuid ~name_label ~name_description:"" ~_type ~content_type ~shared ~sm_config:[] in
+ printer (Cli_printer.PList [uuid])
let sr_probe printer rpc session_id params =
- let host = parse_host_uuid rpc session_id params in
- let _type = List.assoc "type" params in
- let device_config = parse_device_config params in
- let sm_config = read_map_params "sm-config" params in
- printer (Cli_printer.PList
- [Client.SR.probe ~rpc ~session_id
- ~host ~_type ~device_config ~sm_config])
+ let host = parse_host_uuid rpc session_id params in
+ let _type = List.assoc "type" params in
+ let device_config = parse_device_config params in
+ let sm_config = read_map_params "sm-config" params in
+ printer (Cli_printer.PList
+ [Client.SR.probe ~rpc ~session_id
+ ~host ~_type ~device_config ~sm_config])
let sr_destroy printer rpc session_id params =
- let uuid = List.assoc "uuid" params in
- let sr = Client.SR.get_by_uuid rpc session_id uuid in
- Client.SR.destroy rpc session_id sr
+ let uuid = List.assoc "uuid" params in
+ let sr = Client.SR.get_by_uuid rpc session_id uuid in
+ Client.SR.destroy rpc session_id sr
let sr_forget printer rpc session_id params =
- let uuid = List.assoc "uuid" params in
- let sr = Client.SR.get_by_uuid rpc session_id uuid in
- Client.SR.forget rpc session_id sr
+ let uuid = List.assoc "uuid" params in
+ let sr = Client.SR.get_by_uuid rpc session_id uuid in
+ Client.SR.forget rpc session_id sr
let sr_update printer rpc session_id params =
- let sr = Client.SR.get_by_uuid rpc session_id (List.assoc "uuid" params) in
- Client.SR.update rpc session_id sr
+ let sr = Client.SR.get_by_uuid rpc session_id (List.assoc "uuid" params) in
+ Client.SR.update rpc session_id sr
(* PIF destroy* list param-list param-get param-set param-add param-remove *)
let pbd_create printer rpc session_id params =
- let host_uuid = List.assoc "host-uuid" params in
- let sr_uuid = List.assoc "sr-uuid" params in
-
- (* Ack! We're supposed to use the format device-config:key=value but we need to match device-config-key=value for *)
- (* backwards compatability *)
- let len = String.length "device-config:" in
- let filter_params = List.filter (fun (p,_) -> (String.startswith "device-config" p) && (String.length p > len)) params in
- let device_config = List.map (fun (k,v) -> String.sub k len (String.length k - len),v) filter_params in
-
- let host = Client.Host.get_by_uuid rpc session_id host_uuid in
- let sr = Client.SR.get_by_uuid rpc session_id sr_uuid in
- let pbd = Client.PBD.create rpc session_id host sr device_config [] in
- let uuid = Client.PBD.get_uuid rpc session_id pbd in
- printer (Cli_printer.PList [uuid])
+ let host_uuid = List.assoc "host-uuid" params in
+ let sr_uuid = List.assoc "sr-uuid" params in
+
+ (* Ack! We're supposed to use the format device-config:key=value but we need to match device-config-key=value for *)
+ (* backwards compatability *)
+ let len = String.length "device-config:" in
+ let filter_params = List.filter (fun (p,_) -> (String.startswith "device-config" p) && (String.length p > len)) params in
+ let device_config = List.map (fun (k,v) -> String.sub k len (String.length k - len),v) filter_params in
+
+ let host = Client.Host.get_by_uuid rpc session_id host_uuid in
+ let sr = Client.SR.get_by_uuid rpc session_id sr_uuid in
+ let pbd = Client.PBD.create rpc session_id host sr device_config [] in
+ let uuid = Client.PBD.get_uuid rpc session_id pbd in
+ printer (Cli_printer.PList [uuid])
let pbd_destroy printer rpc session_id params =
- let uuid = List.assoc "uuid" params in
- let pbd = Client.PBD.get_by_uuid rpc session_id uuid in
- Client.PBD.destroy rpc session_id pbd
+ let uuid = List.assoc "uuid" params in
+ let pbd = Client.PBD.get_by_uuid rpc session_id uuid in
+ Client.PBD.destroy rpc session_id pbd
let pbd_plug printer rpc session_id params =
- let pbd = Client.PBD.get_by_uuid ~rpc ~session_id ~uuid:(List.assoc "uuid" params) in
- Client.PBD.plug rpc session_id pbd
+ let pbd = Client.PBD.get_by_uuid ~rpc ~session_id ~uuid:(List.assoc "uuid" params) in
+ Client.PBD.plug rpc session_id pbd
let pbd_unplug printer rpc session_id params =
- let pbd = Client.PBD.get_by_uuid ~rpc ~session_id ~uuid:(List.assoc "uuid" params) in
- Client.PBD.unplug rpc session_id pbd
+ let pbd = Client.PBD.get_by_uuid ~rpc ~session_id ~uuid:(List.assoc "uuid" params) in
+ Client.PBD.unplug rpc session_id pbd
let vif_create printer rpc session_id params =
- let device = List.assoc "device" params in
- let network_uuid = List.assoc "network-uuid" params in
- let vm_uuid=List.assoc "vm-uuid" params in
- let mac=List.assoc_default "mac" params "" in
- let mac=if mac="random" then (Record_util.random_mac_local ()) else mac in
- let vm=Client.VM.get_by_uuid rpc session_id vm_uuid in
- let network=Client.Network.get_by_uuid rpc session_id network_uuid in
- let mtu = Client.Network.get_MTU rpc session_id network in
- let vif = Client.VIF.create rpc session_id device network vm mac mtu [] "" [] in
- let uuid = Client.VIF.get_uuid rpc session_id vif in
- printer (Cli_printer.PList [uuid])
+ let device = List.assoc "device" params in
+ let network_uuid = List.assoc "network-uuid" params in
+ let vm_uuid=List.assoc "vm-uuid" params in
+ let mac=List.assoc_default "mac" params "" in
+ let mac=if mac="random" then (Record_util.random_mac_local ()) else mac in
+ let vm=Client.VM.get_by_uuid rpc session_id vm_uuid in
+ let network=Client.Network.get_by_uuid rpc session_id network_uuid in
+ let mtu = Client.Network.get_MTU rpc session_id network in
+ let vif = Client.VIF.create rpc session_id device network vm mac mtu [] "" [] in
+ let uuid = Client.VIF.get_uuid rpc session_id vif in
+ printer (Cli_printer.PList [uuid])
let vif_destroy printer rpc session_id params =
- let uuid = List.assoc "uuid" params in
- let vif = Client.VIF.get_by_uuid rpc session_id uuid in
- Client.VIF.destroy rpc session_id vif
+ let uuid = List.assoc "uuid" params in
+ let vif = Client.VIF.get_by_uuid rpc session_id uuid in
+ Client.VIF.destroy rpc session_id vif
let vif_plug printer rpc session_id params =
- let uuid = List.assoc "uuid" params in
- let vif = Client.VIF.get_by_uuid rpc session_id uuid in
- Client.VIF.plug rpc session_id vif
+ let uuid = List.assoc "uuid" params in
+ let vif = Client.VIF.get_by_uuid rpc session_id uuid in
+ Client.VIF.plug rpc session_id vif
let vif_unplug printer rpc session_id params =
- let uuid = List.assoc "uuid" params in
- let vif = Client.VIF.get_by_uuid rpc session_id uuid in
- Client.VIF.unplug rpc session_id vif
+ let uuid = List.assoc "uuid" params in
+ let vif = Client.VIF.get_by_uuid rpc session_id uuid in
+ Client.VIF.unplug rpc session_id vif
let net_create printer rpc session_id params =
- let network = List.assoc "name-label" params in
- let descr = List.assoc_default "name-description" params "" in
- let mtu = if List.mem_assoc "MTU" params then Int64.of_string (List.assoc "MTU" params) else 1500L in
- let net = Client.Network.create rpc session_id network descr mtu [] [] in
- let uuid = Client.Network.get_uuid rpc session_id net in
- printer (Cli_printer.PList [uuid])
+ let network = List.assoc "name-label" params in
+ let descr = List.assoc_default "name-description" params "" in
+ let mtu = if List.mem_assoc "MTU" params then Int64.of_string (List.assoc "MTU" params) else 1500L in
+ let net = Client.Network.create rpc session_id network descr mtu [] [] in
+ let uuid = Client.Network.get_uuid rpc session_id net in
+ printer (Cli_printer.PList [uuid])
let net_destroy printer rpc session_id params =
- let network = Client.Network.get_by_uuid rpc session_id (List.assoc "uuid" params) in
- ignore(Client.Network.destroy rpc session_id network)
+ let network = Client.Network.get_by_uuid rpc session_id (List.assoc "uuid" params) in
+ ignore(Client.Network.destroy rpc session_id network)
let net_attach printer rpc session_id params =
- let network = Client.Network.get_by_uuid rpc session_id (List.assoc "uuid" params) in
- let host = Client.Host.get_by_uuid rpc session_id (List.assoc "host-uuid" params) in
- let () = Client.Network.attach rpc session_id network host in ()
+ let network = Client.Network.get_by_uuid rpc session_id (List.assoc "uuid" params) in
+ let host = Client.Host.get_by_uuid rpc session_id (List.assoc "host-uuid" params) in
+ let () = Client.Network.attach rpc session_id network host in ()
let vm_create printer rpc session_id params =
- let name_label=List.assoc "name-label" params in
- let name_description=List.assoc_default "name-description" params "" in
- let ( ** ) = Int64.mul in
- let mib = 1024L ** 1024L in
- let memory_max = 256L ** mib in
- let memory_min = 128L ** mib in
- let vm = Client.VM.create ~rpc ~session_id ~name_label ~name_description ~user_version:0L ~is_a_template:false
- ~blocked_operations:[]
- ~affinity:Ref.null
- ~memory_target:memory_max
- ~memory_static_max:memory_max
- ~memory_dynamic_max:memory_max
- ~memory_dynamic_min:memory_min
- ~memory_static_min:memory_min
- ~vCPUs_params:[] ~vCPUs_max:1L ~vCPUs_at_startup:1L
- ~actions_after_shutdown:`destroy ~actions_after_reboot:`restart ~actions_after_crash:`destroy ~pV_bootloader:""
- ~pV_kernel:"" ~pV_ramdisk:"" ~pV_args:"" ~pV_bootloader_args:"" ~pV_legacy_args:"" ~hVM_boot_policy:""
- ~hVM_boot_params:[] ~hVM_shadow_multiplier:1. ~platform:[] ~pCI_bus:"" ~other_config:[] ~xenstore_data:[] ~recommendations:"" ~ha_always_run:false ~ha_restart_priority:""
- ~tags:[] ~protection_policy:Ref.null ~is_snapshot_from_vmpp:false in
- let uuid=Client.VM.get_uuid rpc session_id vm in
- printer (Cli_printer.PList [uuid])
+ let name_label=List.assoc "name-label" params in
+ let name_description=List.assoc_default "name-description" params "" in
+ let ( ** ) = Int64.mul in
+ let mib = 1024L ** 1024L in
+ let memory_max = 256L ** mib in
+ let memory_min = 128L ** mib in
+ let vm = Client.VM.create ~rpc ~session_id ~name_label ~name_description ~user_version:0L ~is_a_template:false
+ ~blocked_operations:[]
+ ~affinity:Ref.null
+ ~memory_target:memory_max
+ ~memory_static_max:memory_max
+ ~memory_dynamic_max:memory_max
+ ~memory_dynamic_min:memory_min
+ ~memory_static_min:memory_min
+ ~vCPUs_params:[] ~vCPUs_max:1L ~vCPUs_at_startup:1L
+ ~actions_after_shutdown:`destroy ~actions_after_reboot:`restart ~actions_after_crash:`destroy ~pV_bootloader:""
+ ~pV_kernel:"" ~pV_ramdisk:"" ~pV_args:"" ~pV_bootloader_args:"" ~pV_legacy_args:"" ~hVM_boot_policy:""
+ ~hVM_boot_params:[] ~hVM_shadow_multiplier:1. ~platform:[] ~pCI_bus:"" ~other_config:[] ~xenstore_data:[] ~recommendations:"" ~ha_always_run:false ~ha_restart_priority:""
+ ~tags:[] ~protection_policy:Ref.null ~is_snapshot_from_vmpp:false in
+ let uuid=Client.VM.get_uuid rpc session_id vm in
+ printer (Cli_printer.PList [uuid])
let vm_destroy printer rpc session_id params =
- let uuid = List.assoc "uuid" params in
- let vm = Client.VM.get_by_uuid rpc session_id uuid in
- Client.VM.destroy rpc session_id vm
+ let uuid = List.assoc "uuid" params in
+ let vm = Client.VM.get_by_uuid rpc session_id uuid in
+ Client.VM.destroy rpc session_id vm
(* Event *)
(*
-let dodiff fd orig_values tbl reference =
+ let dodiff fd orig_values tbl reference =
let (r,orig_tbl) = try List.find (fun (x,x_rec) -> x=reference) orig_values with _ -> ("",[]) in
let changed = List.filter (fun (n,v) -> try v <> List.assoc n orig_tbl with _ -> true) tbl in
List.iter (fun (n,v) -> marshal fd (Command (Print (Printf.sprintf "%s: %s\n" n v)))) changed
-let diagnostic_event_deltas fd printer rpc session_id params =
+ let diagnostic_event_deltas fd printer rpc session_id params =
let classes=[List.assoc "class" params] in
let orig = match List.hd classes with
- | "vm" -> List.map (fun vm -> (Ref.string_of vm),(vm_record rpc session_id vm).fields) (Client.VM.get_all rpc session_id)
- | "vdi" -> List.map (fun vdi -> (Ref.string_of vdi),(vdi_record rpc session_id vdi).fields) (Client.VDI.get_all rpc session_id)
- | "sr" -> List.map (fun sr -> (Ref.string_of sr),(sr_record rpc session_id sr).fields) (Client.SR.get_all rpc session_id)
- | _ -> []
+ | "vm" -> List.map (fun vm -> (Ref.string_of vm),(vm_record rpc session_id vm).fields) (Client.VM.get_all rpc session_id)
+ | "vdi" -> List.map (fun vdi -> (Ref.string_of vdi),(vdi_record rpc session_id vdi).fields) (Client.VDI.get_all rpc session_id)
+ | "sr" -> List.map (fun sr -> (Ref.string_of sr),(sr_record rpc session_id sr).fields) (Client.SR.get_all rpc session_id)
+ | _ -> []
in
let orig_values = List.map (fun (r,x) -> (r,List.map (fun r -> (r.name,safe_get_field r)) x)) orig in
Client.Event.register ~rpc ~session_id ~classes;
while true do
- let events = Event_types.events_of_xmlrpc (Client.Event.next ~rpc ~session_id) in
- marshal fd (Command (Print (Printf.sprintf "Got %d event(s)!\n" (List.length events))));
- let doevent event =
- let tbl = match Event_helper.record_of_event event with
+ let events = Event_types.events_of_xmlrpc (Client.Event.next ~rpc ~session_id) in
+ marshal fd (Command (Print (Printf.sprintf "Got %d event(s)!\n" (List.length events))));
+ let doevent event =
+ let tbl = match Event_helper.record_of_event event with
(* | Event_helper.VM x -> let record = vm_record rpc session_id (Ref.of_string event.Event_types.reference) in record.set_ref x; tbl
- | Event_helper.VDI x -> let record = vdi_record rpc session_id (Ref.of_string event.Event_types.reference) in f x; tbl
- | Event_helper.SR x -> let record = sr_record rpc session_id (Ref.of_string event.Event_types.reference) in f x; tbl*)
- | _ -> failwith "bah!"
- in
- let record = List.map (fun r -> (r.name,safe_get_field r)) tbl in
- let reference = event.Event_types.reference in
- dodiff fd orig_values record reference
- in
- List.iter doevent events
+ | Event_helper.VDI x -> let record = vdi_record rpc session_id (Ref.of_string event.Event_types.reference) in f x; tbl
+ | Event_helper.SR x -> let record = sr_record rpc session_id (Ref.of_string event.Event_types.reference) in f x; tbl*)
+ | _ -> failwith "bah!"
+ in
+ let record = List.map (fun r -> (r.name,safe_get_field r)) tbl in
+ let reference = event.Event_types.reference in
+ dodiff fd orig_values record reference
+ in
+ List.iter doevent events
done
-*)
+ *)
exception Finished
| "role" -> List.map (fun x -> (role_record rpc session_id x).fields) (Client.Role.get_all rpc session_id)
| "vmpp" -> List.map (fun x -> (vmpp_record rpc session_id x).fields) (Client.VMPP.get_all rpc session_id)
| "secret" -> List.map (fun x -> (secret_record rpc session_id x).fields) (Client.Secret.get_all rpc session_id)
-(* | "alert" -> List.map (fun x -> (alert_record rpc session_id x).fields) (Client.Alert.get_all rpc session_id) *)
+ (* | "alert" -> List.map (fun x -> (alert_record rpc session_id x).fields) (Client.Alert.get_all rpc session_id) *)
| _ -> failwith ("Cli listening for class '"^classname^"' not currently implemented")
in
let events = Event_types.events_of_xmlrpc (Client.Event.next ~rpc ~session_id) in
let doevent event =
let tbl = match Event_helper.record_of_event event with
- | Event_helper.VM (r,x) -> let record = vm_record rpc session_id r in record.setrefrec (r,x); record.fields
- | Event_helper.VDI (r,x) -> let record = vdi_record rpc session_id r in record.setrefrec (r,x); record.fields
- | Event_helper.SR (r,x) -> let record = sr_record rpc session_id r in record.setrefrec (r,x); record.fields
- | Event_helper.Host (r,x) -> let record = host_record rpc session_id r in record.setrefrec (r,x); record.fields
- | Event_helper.Network (r,x) -> let record = net_record rpc session_id r in record.setrefrec (r,x); record.fields
- | Event_helper.VIF (r,x) -> let record = vif_record rpc session_id r in record.setrefrec (r,x); record.fields
- | Event_helper.PIF (r,x) -> let record = pif_record rpc session_id r in record.setrefrec (r,x); record.fields
- | Event_helper.VBD (r,x) -> let record = vbd_record rpc session_id r in record.setrefrec (r,x); record.fields
- | Event_helper.PBD (r,x) -> let record = pbd_record rpc session_id r in record.setrefrec (r,x); record.fields
- | Event_helper.Pool (r,x) -> let record = pool_record rpc session_id r in record.setrefrec (r,x); record.fields
- | Event_helper.Task (r,x) -> let record = task_record rpc session_id r in record.setrefrec (r,x); record.fields
- | Event_helper.VMPP (r,x) -> let record = vmpp_record rpc session_id r in record.setrefrec (r,x); record.fields
- | Event_helper.Secret (r,x) -> let record = secret_record rpc session_id r in record.setrefrec (r,x); record.fields
- | _ -> failwith ("Cli listening for class '"^classname^"' not currently implemented")
- in
- let record = List.map (fun r -> (r.name,fun () -> safe_get_field r)) tbl in
- if record_matches record then raise Finished
- in
- List.iter doevent events
+ | Event_helper.VM (r,x) -> let record = vm_record rpc session_id r in record.setrefrec (r,x); record.fields
+ | Event_helper.VDI (r,x) -> let record = vdi_record rpc session_id r in record.setrefrec (r,x); record.fields
+ | Event_helper.SR (r,x) -> let record = sr_record rpc session_id r in record.setrefrec (r,x); record.fields
+ | Event_helper.Host (r,x) -> let record = host_record rpc session_id r in record.setrefrec (r,x); record.fields
+ | Event_helper.Network (r,x) -> let record = net_record rpc session_id r in record.setrefrec (r,x); record.fields
+ | Event_helper.VIF (r,x) -> let record = vif_record rpc session_id r in record.setrefrec (r,x); record.fields
+ | Event_helper.PIF (r,x) -> let record = pif_record rpc session_id r in record.setrefrec (r,x); record.fields
+ | Event_helper.VBD (r,x) -> let record = vbd_record rpc session_id r in record.setrefrec (r,x); record.fields
+ | Event_helper.PBD (r,x) -> let record = pbd_record rpc session_id r in record.setrefrec (r,x); record.fields
+ | Event_helper.Pool (r,x) -> let record = pool_record rpc session_id r in record.setrefrec (r,x); record.fields
+ | Event_helper.Task (r,x) -> let record = task_record rpc session_id r in record.setrefrec (r,x); record.fields
+ | Event_helper.VMPP (r,x) -> let record = vmpp_record rpc session_id r in record.setrefrec (r,x); record.fields
+ | Event_helper.Secret (r,x) -> let record = secret_record rpc session_id r in record.setrefrec (r,x); record.fields
+ | _ -> failwith ("Cli listening for class '"^classname^"' not currently implemented")
+ in
+ let record = List.map (fun r -> (r.name,fun () -> safe_get_field r)) tbl in
+ if record_matches record then raise Finished
+ in
+ List.iter doevent events
with Api_errors.Server_error(code, _) when code = Api_errors.events_lost ->
- debug "Got EVENTS_LOST; reregistering";
+ debug "Got EVENTS_LOST; reregistering";
Client.Event.unregister ~rpc ~session_id ~classes;
Client.Event.register ~rpc ~session_id ~classes;
if poll() then raise Finished
let event_wait printer rpc session_id params =
- let classname=List.assoc "class" params in
- let filter_params = List.filter (fun (p,_) -> not (List.mem p ("class"::stdparams))) params in
-
- (* Each filter_params is a key value pair:
- (key, value) if the user entered "key=value"
- (key, "/=" value) if the user entered "key=/=value"
- We now parse these into a slightly nicer form *)
-
- let filter_params = List.map
- (fun (key, value) ->
- if String.startswith "/=" value then begin
- let key' = key in
- let value' = String.sub value 2 (String.length value - 2) in
- `NotEquals, key', value'
- end else begin
- `Equals, key, value
- end) filter_params in
-
- (* This returns true if the record matches the cmd line constraints *)
- let record_matches record =
- let matches = List.map (fun (operator, p,v) ->
- if not(List.mem_assoc p record)
- then failwith (Printf.sprintf "key missing: %s" p);
- let v' = List.assoc p record () in match operator with
+ let classname=List.assoc "class" params in
+ let filter_params = List.filter (fun (p,_) -> not (List.mem p ("class"::stdparams))) params in
+
+ (* Each filter_params is a key value pair:
+ (key, value) if the user entered "key=value"
+ (key, "/=" value) if the user entered "key=/=value"
+ We now parse these into a slightly nicer form *)
+
+ let filter_params = List.map
+ (fun (key, value) ->
+ if String.startswith "/=" value then begin
+ let key' = key in
+ let value' = String.sub value 2 (String.length value - 2) in
+ `NotEquals, key', value'
+ end else begin
+ `Equals, key, value
+ end) filter_params in
+
+ (* This returns true if the record matches the cmd line constraints *)
+ let record_matches record =
+ let matches = List.map (fun (operator, p,v) ->
+ if not(List.mem_assoc p record)
+ then failwith (Printf.sprintf "key missing: %s" p);
+ let v' = List.assoc p record () in match operator with
| `NotEquals -> v <> v'
| `Equals -> v = v') filter_params in
- alltrue matches
- in
- event_wait_gen rpc session_id classname record_matches
+ alltrue matches
+ in
+ event_wait_gen rpc session_id classname record_matches
(* Convenience functions *)
let select_vms ?(include_control_vms = false) ?(include_template_vms = false) rpc session_id params ignore_params =
- (* Make sure we don't select a template or control domain by mistake *)
- let params = if not include_control_vms then ("is-control-domain", "false") :: params else params in
- let params = if not include_template_vms then ("is-a-template" , "false") :: params else params in
-
- let do_filter params =
- let vms = Client.VM.get_all_records_where rpc session_id "true" in
- let all_recs = List.map (fun (vm,vm_r) -> let r = vm_record rpc session_id vm in r.setrefrec (vm,vm_r); r) vms in
- (* Filter on everything on the cmd line except params=... *)
- let filter_params = List.filter (fun (p,_) -> not (List.mem p (stdparams @ ignore_params))) params in
- (* Filter all the records *)
- List.fold_left filter_records_on_fields all_recs filter_params
- in
+ (* Make sure we don't select a template or control domain by mistake *)
+ let params = if not include_control_vms then ("is-control-domain", "false") :: params else params in
+ let params = if not include_template_vms then ("is-a-template" , "false") :: params else params in
+
+ let do_filter params =
+ let vms = Client.VM.get_all_records_where rpc session_id "true" in
+ let all_recs = List.map (fun (vm,vm_r) -> let r = vm_record rpc session_id vm in r.setrefrec (vm,vm_r); r) vms in
+ (* Filter on everything on the cmd line except params=... *)
+ let filter_params = List.filter (fun (p,_) -> not (List.mem p (stdparams @ ignore_params))) params in
+ (* Filter all the records *)
+ List.fold_left filter_records_on_fields all_recs filter_params
+ in
- (* try matching vm=<name or uuid> first *)
- if List.mem_assoc "vm" params
- then
- try [vm_record rpc session_id (Client.VM.get_by_uuid rpc session_id (List.assoc "vm" params))]
- with _ -> do_filter (List.map (fun (k,v) -> if k="vm" then ("name-label",v) else (k,v)) params)
- else
- do_filter params
+ (* try matching vm=<name or uuid> first *)
+ if List.mem_assoc "vm" params
+ then
+ try [vm_record rpc session_id (Client.VM.get_by_uuid rpc session_id (List.assoc "vm" params))]
+ with _ -> do_filter (List.map (fun (k,v) -> if k="vm" then ("name-label",v) else (k,v)) params)
+ else
+ do_filter params
let select_hosts rpc session_id params ignore_params =
- (* try matching host=<name or uuid> first *)
- let do_filter params =
- let hosts = Client.Host.get_all_records_where rpc session_id "true" in
- let all_recs = List.map (fun (host,host_r) -> let r = host_record rpc session_id host in r.setrefrec (host,host_r); r) hosts in
-
- let filter_params = List.filter (fun (p,_) ->
- let stem=List.hd (String.split ':' p) in not (List.mem stem (stdparams @ ignore_params))) params in
- (* Filter all the records *)
- List.fold_left filter_records_on_fields all_recs filter_params
- in
+ (* try matching host=<name or uuid> first *)
+ let do_filter params =
+ let hosts = Client.Host.get_all_records_where rpc session_id "true" in
+ let all_recs = List.map (fun (host,host_r) -> let r = host_record rpc session_id host in r.setrefrec (host,host_r); r) hosts in
+
+ let filter_params = List.filter (fun (p,_) ->
+ let stem=List.hd (String.split ':' p) in not (List.mem stem (stdparams @ ignore_params))) params in
+ (* Filter all the records *)
+ List.fold_left filter_records_on_fields all_recs filter_params
+ in
- if List.mem_assoc "host" params
- then
- try [host_record rpc session_id (Client.Host.get_by_uuid rpc session_id (List.assoc "host" params))]
- with _ -> do_filter (List.map (fun (k,v) -> if k="host" then ("name-label",v) else (k,v)) params)
- else
- do_filter params
+ if List.mem_assoc "host" params
+ then
+ try [host_record rpc session_id (Client.Host.get_by_uuid rpc session_id (List.assoc "host" params))]
+ with _ -> do_filter (List.map (fun (k,v) -> if k="host" then ("name-label",v) else (k,v)) params)
+ else
+ do_filter params
let select_vm_geneva rpc session_id params =
- if List.mem_assoc "vm-name" params then
- begin
- let vmname = List.assoc "vm-name" params in
- let vms = Client.VM.get_all rpc session_id in
- let vm = List.filter (fun vm -> Client.VM.get_name_label rpc session_id vm = vmname) vms in
- if List.length vm = 0 then
- failwith ("VM with name '"^vmname^"' not found")
- else if List.length vm > 1 then
- failwith ("Multiple VMs with name '"^vmname^"' found")
- else
- vm_record rpc session_id (List.hd vm)
- end
- else if List.mem_assoc "vm-id" params then
- begin
- let vmid = List.assoc "vm-id" params in
- try
- vm_record rpc session_id (Client.VM.get_by_uuid rpc session_id vmid)
- with
- e -> failwith ("Failed to find VM with id '"^vmid^"'")
- end
- else
- (failwith ("Must select a VM using either vm-name or vm-id: params="
- ^(String.concat "," (List.map (fun (a,b) -> a^"="^b) params))))
+ if List.mem_assoc "vm-name" params then
+ begin
+ let vmname = List.assoc "vm-name" params in
+ let vms = Client.VM.get_all rpc session_id in
+ let vm = List.filter (fun vm -> Client.VM.get_name_label rpc session_id vm = vmname) vms in
+ if List.length vm = 0 then
+ failwith ("VM with name '"^vmname^"' not found")
+ else if List.length vm > 1 then
+ failwith ("Multiple VMs with name '"^vmname^"' found")
+ else
+ vm_record rpc session_id (List.hd vm)
+ end
+ else if List.mem_assoc "vm-id" params then
+ begin
+ let vmid = List.assoc "vm-id" params in
+ try
+ vm_record rpc session_id (Client.VM.get_by_uuid rpc session_id vmid)
+ with
+ e -> failwith ("Failed to find VM with id '"^vmid^"'")
+ end
+ else
+ (failwith ("Must select a VM using either vm-name or vm-id: params="
+ ^(String.concat "," (List.map (fun (a,b) -> a^"="^b) params))))
exception Multiple_failure of (string * string) list
let format_message msg =
- Printf.sprintf "Message: time=%s priority=%Ld name='%s'" (Date.to_string msg.API.message_timestamp)
- (msg.API.message_priority) (msg.API.message_name)
+ Printf.sprintf "Message: time=%s priority=%Ld name='%s'" (Date.to_string msg.API.message_timestamp)
+ (msg.API.message_priority) (msg.API.message_name)
let wrap_op printer pri rpc session_id op e =
- let now = (Unix.gettimeofday ()) in
- let result = op e in
- let msgs = Client.Message.get ~rpc ~session_id ~cls:`VM ~obj_uuid:(safe_get_field (field_lookup e.fields "uuid")) ~since:(Date.of_float now) in
- List.iter (fun (ref,msg) ->
- if msg.API.message_priority > pri
- then printer (Cli_printer.PStderr (format_message msg))) msgs;
- result
+ let now = (Unix.gettimeofday ()) in
+ let result = op e in
+ let msgs = Client.Message.get ~rpc ~session_id ~cls:`VM ~obj_uuid:(safe_get_field (field_lookup e.fields "uuid")) ~since:(Date.of_float now) in
+ List.iter (fun (ref,msg) ->
+ if msg.API.message_priority > pri
+ then printer (Cli_printer.PStderr (format_message msg))) msgs;
+ result
let do_multiple op set =
- let fails = ref [] in
- let append_fail e msg =
- let uuid = safe_get_field (field_lookup e.fields "uuid") in
- fails := (uuid, msg) :: !fails
- in
- (* do every operations and record every failure *)
- let ret = List.map (fun e ->
- try
- Some (op e);
- with
- | Api_errors.Server_error(code, params) as exn -> (
- match Cli_util.get_server_error code params with
- | None -> append_fail e (ExnHelper.string_of_exn exn)
- | Some (msg, ps) -> append_fail e (msg ^ "\n" ^ (String.concat "\n" ps))
- ); None
- | exn -> append_fail e (ExnHelper.string_of_exn exn); None
- ) set in
-
- let success = List.fold_left (fun acc e -> match e with None -> acc | Some x -> x :: acc) [] ret in
- if !fails <> [] then raise (Multiple_failure (!fails));
- success
+ let fails = ref [] in
+ let append_fail e msg =
+ let uuid = safe_get_field (field_lookup e.fields "uuid") in
+ fails := (uuid, msg) :: !fails
+ in
+ (* do every operations and record every failure *)
+ let ret = List.map (fun e ->
+ try
+ Some (op e);
+ with
+ | Api_errors.Server_error(code, params) as exn -> (
+ match Cli_util.get_server_error code params with
+ | None -> append_fail e (ExnHelper.string_of_exn exn)
+ | Some (msg, ps) -> append_fail e (msg ^ "\n" ^ (String.concat "\n" ps))
+ ); None
+ | exn -> append_fail e (ExnHelper.string_of_exn exn); None
+ ) set in
+
+ let success = List.fold_left (fun acc e -> match e with None -> acc | Some x -> x :: acc) [] ret in
+ if !fails <> [] then raise (Multiple_failure (!fails));
+ success
let do_vm_op ?(include_control_vms = false) ?(include_template_vms = false)
- printer rpc session_id op params ?(multiple=true) ignore_params =
- let msg_prio = try Int64.of_string (List.assoc "message-priority" params) with _ -> 1L in
- let op = wrap_op printer msg_prio rpc session_id op in
- if get_bool_param params "compat_mode"
- then
- (* Geneva compatability mode *)
- let vm = select_vm_geneva rpc session_id params in
- [op vm]
- else
- (* Rio standard mode *)
- try
- let vms = select_vms ~include_control_vms ~include_template_vms rpc session_id params ignore_params in
- match List.length vms with
- | 0 -> failwith "No matching VMs found"
- | 1 -> [ op (List.hd vms) ]
- | _ ->
- if multiple && get_bool_param params "multiple" then
- do_multiple op vms
+ printer rpc session_id op params ?(multiple=true) ignore_params =
+ let msg_prio = try Int64.of_string (List.assoc "message-priority" params) with _ -> 1L in
+ let op = wrap_op printer msg_prio rpc session_id op in
+ if get_bool_param params "compat_mode"
+ then
+ (* Geneva compatability mode *)
+ let vm = select_vm_geneva rpc session_id params in
+ [op vm]
else
- failwith
- (if not multiple
- then "Multiple matches VMs found. Operation can only be performed on one VM at a time"
- else "Multiple matches VMs found. --multiple required to complete the operation")
- with
- | Records.CLI_failed_to_find_param name ->
- failwith ("Parameter '"^name^"' is not a field of the VM class. Failed to select VM for operation.")
+ (* Rio standard mode *)
+ try
+ let vms = select_vms ~include_control_vms ~include_template_vms rpc session_id params ignore_params in
+ match List.length vms with
+ | 0 -> failwith "No matching VMs found"
+ | 1 -> [ op (List.hd vms) ]
+ | _ ->
+ if multiple && get_bool_param params "multiple" then
+ do_multiple op vms
+ else
+ failwith
+ (if not multiple
+ then "Multiple matches VMs found. Operation can only be performed on one VM at a time"
+ else "Multiple matches VMs found. --multiple required to complete the operation")
+ with
+ | Records.CLI_failed_to_find_param name ->
+ failwith ("Parameter '"^name^"' is not a field of the VM class. Failed to select VM for operation.")
let do_host_op rpc session_id op params ?(multiple=true) ignore_params =
- if get_bool_param params "compat_mode"
- then
- let host = host_record rpc session_id (get_host_from_session rpc session_id) in
- [op 1 host]
- else
- let hosts = select_hosts rpc session_id params ignore_params in
- match List.length hosts with
- | 0 -> failwith "No matching hosts found"
- | 1 -> [ op 1 (List.hd hosts) ]
- | _ ->
- if multiple && get_bool_param params "multiple" then
- do_multiple (op (List.length hosts)) hosts
- else
- failwith
- (if not multiple
- then "Multiple matching hosts found. Operation can only be performed on one host at a time"
- else "Multiple matching hosts found. --multiple required to complete the operation")
+ if get_bool_param params "compat_mode"
+ then
+ let host = host_record rpc session_id (get_host_from_session rpc session_id) in
+ [op 1 host]
+ else
+ let hosts = select_hosts rpc session_id params ignore_params in
+ match List.length hosts with
+ | 0 -> failwith "No matching hosts found"
+ | 1 -> [ op 1 (List.hd hosts) ]
+ | _ ->
+ if multiple && get_bool_param params "multiple" then
+ do_multiple (op (List.length hosts)) hosts
+ else
+ failwith
+ (if not multiple
+ then "Multiple matching hosts found. Operation can only be performed on one host at a time"
+ else "Multiple matching hosts found. --multiple required to complete the operation")
(* Execute f; if we get a no_hosts_available error then print a vm diagnostic table and reraise exception *)
let hook_no_hosts_available printer rpc session_id vm f =
- try
- f ()
- with
- (Api_errors.Server_error(code,params) as e) ->
- if code=Api_errors.no_hosts_available then
- begin
- printer (Cli_printer.PList ["There are no suitable hosts to start this VM on.";
- "The following table provides per-host reasons for why the VM could not be started:";""]);
- print_vm_host_report printer rpc session_id vm;
- end;
- raise e
+ try
+ f ()
+ with
+ (Api_errors.Server_error(code,params) as e) ->
+ if code=Api_errors.no_hosts_available then
+ begin
+ printer (Cli_printer.PList ["There are no suitable hosts to start this VM on.";
+ "The following table provides per-host reasons for why the VM could not be started:";""]);
+ print_vm_host_report printer rpc session_id vm;
+ end;
+ raise e
let vm_compute_memory_overhead printer rpc session_id params =
ignore
let target = Record_util.bytes_of_string "target"
(List.assoc "target" params) in
ignore (do_vm_op ~include_control_vms:true printer rpc session_id
- (fun vm ->
- Client.VM.set_memory_dynamic_range rpc session_id
- (vm.getref ()) target target) params ["target"]
+ (fun vm ->
+ Client.VM.set_memory_dynamic_range rpc session_id
+ (vm.getref ()) target target) params ["target"]
)
let vm_memory_target_wait printer rpc session_id params =
Client.VM.wait_memory_target_live rpc session_id vm) params [])
let data_source_to_kvs ds =
- ["name_label",ds.API.data_source_name_label;
- "name_description",ds.API.data_source_name_description;
- "enabled",string_of_bool ds.API.data_source_enabled;
- "standard",string_of_bool ds.API.data_source_standard;
- "min",string_of_float ds.API.data_source_min;
- "max",string_of_float ds.API.data_source_max;
- "units",ds.API.data_source_units;
- ]
+ ["name_label",ds.API.data_source_name_label;
+ "name_description",ds.API.data_source_name_description;
+ "enabled",string_of_bool ds.API.data_source_enabled;
+ "standard",string_of_bool ds.API.data_source_standard;
+ "min",string_of_float ds.API.data_source_min;
+ "max",string_of_float ds.API.data_source_max;
+ "units",ds.API.data_source_units;
+ ]
let vm_data_source_list printer rpc session_id params =
- ignore(do_vm_op printer rpc session_id ~multiple:false
- (fun vm ->
- let vm=vm.getref () in
- let dss =Client.VM.get_data_sources rpc session_id vm in
- let output = List.map data_source_to_kvs dss in
- printer (Cli_printer.PTable output)) params [])
+ ignore(do_vm_op printer rpc session_id ~multiple:false
+ (fun vm ->
+ let vm=vm.getref () in
+ let dss =Client.VM.get_data_sources rpc session_id vm in
+ let output = List.map data_source_to_kvs dss in
+ printer (Cli_printer.PTable output)) params [])
let vm_data_source_record printer rpc session_id params =
- ignore(do_vm_op printer rpc session_id ~multiple:false
- (fun vm ->
- let vm=vm.getref () in
- let ds=List.assoc "data-source" params in
- Client.VM.record_data_source rpc session_id vm ds) params ["data-source"])
+ ignore(do_vm_op printer rpc session_id ~multiple:false
+ (fun vm ->
+ let vm=vm.getref () in
+ let ds=List.assoc "data-source" params in
+ Client.VM.record_data_source rpc session_id vm ds) params ["data-source"])
let vm_data_source_query printer rpc session_id params =
- ignore(do_vm_op printer rpc session_id ~multiple:false
- (fun vm ->
- let vm=vm.getref () in
- let ds=List.assoc "data-source" params in
- let value = Client.VM.query_data_source rpc session_id vm ds in
- printer (Cli_printer.PList [Printf.sprintf "%f" value])) params ["data-source"])
+ ignore(do_vm_op printer rpc session_id ~multiple:false
+ (fun vm ->
+ let vm=vm.getref () in
+ let ds=List.assoc "data-source" params in
+ let value = Client.VM.query_data_source rpc session_id vm ds in
+ printer (Cli_printer.PList [Printf.sprintf "%f" value])) params ["data-source"])
let vm_data_source_forget printer rpc session_id params =
- ignore(do_vm_op printer rpc session_id ~multiple:false
- (fun vm ->
- let vm=vm.getref () in
- let ds=List.assoc "data-source" params in
- Client.VM.forget_data_source_archives rpc session_id vm ds) params ["data-source"])
+ ignore(do_vm_op printer rpc session_id ~multiple:false
+ (fun vm ->
+ let vm=vm.getref () in
+ let ds=List.assoc "data-source" params in
+ Client.VM.forget_data_source_archives rpc session_id vm ds) params ["data-source"])
let host_data_source_list printer rpc session_id params =
- ignore(do_host_op rpc session_id ~multiple:false
- (fun _ host ->
- let host=host.getref () in
- let dss =Client.Host.get_data_sources rpc session_id host in
- let output = List.map data_source_to_kvs dss in
- printer (Cli_printer.PTable output)) params [])
+ ignore(do_host_op rpc session_id ~multiple:false
+ (fun _ host ->
+ let host=host.getref () in
+ let dss =Client.Host.get_data_sources rpc session_id host in
+ let output = List.map data_source_to_kvs dss in
+ printer (Cli_printer.PTable output)) params [])
let host_data_source_record printer rpc session_id params =
- ignore(do_host_op rpc session_id ~multiple:false
- (fun _ host ->
- let host=host.getref () in
- let ds=List.assoc "data-source" params in
- Client.Host.record_data_source rpc session_id host ds) params ["data-source"])
+ ignore(do_host_op rpc session_id ~multiple:false
+ (fun _ host ->
+ let host=host.getref () in
+ let ds=List.assoc "data-source" params in
+ Client.Host.record_data_source rpc session_id host ds) params ["data-source"])
let host_data_source_query printer rpc session_id params =
- ignore(do_host_op rpc session_id ~multiple:false
- (fun _ host ->
- let host=host.getref () in
- let ds=List.assoc "data-source" params in
- let value = Client.Host.query_data_source rpc session_id host ds in
- printer (Cli_printer.PList [Printf.sprintf "%f" value])) params ["data-source"])
+ ignore(do_host_op rpc session_id ~multiple:false
+ (fun _ host ->
+ let host=host.getref () in
+ let ds=List.assoc "data-source" params in
+ let value = Client.Host.query_data_source rpc session_id host ds in
+ printer (Cli_printer.PList [Printf.sprintf "%f" value])) params ["data-source"])
let host_data_source_forget printer rpc session_id params =
- ignore(do_host_op rpc session_id ~multiple:false
- (fun _ host ->
- let host=host.getref () in
- let ds=List.assoc "data-source" params in
- Client.Host.forget_data_source_archives rpc session_id host ds) params ["data-source"])
+ ignore(do_host_op rpc session_id ~multiple:false
+ (fun _ host ->
+ let host=host.getref () in
+ let ds=List.assoc "data-source" params in
+ Client.Host.forget_data_source_archives rpc session_id host ds) params ["data-source"])
let host_compute_free_memory printer rpc session_id params =
let host = host.getref () in
let free_memory = Client.Host.compute_free_memory rpc session_id host in
printer (Cli_printer.PMsg (Int64.to_string free_memory))
- ) params [])
+ ) params [])
let host_compute_memory_overhead printer rpc session_id params =
ignore
)
let host_get_server_certificate printer rpc session_id params =
- ignore (do_host_op rpc session_id ~multiple:false
- (fun _ host ->
- let host = host.getref () in
- printer
- (Cli_printer.PMsg
- (Client.Host.get_server_certificate rpc session_id host)))
- params [])
+ ignore (do_host_op rpc session_id ~multiple:false
+ (fun _ host ->
+ let host = host.getref () in
+ printer
+ (Cli_printer.PMsg
+ (Client.Host.get_server_certificate rpc session_id host)))
+ params [])
let vm_memory_shadow_multiplier_set printer rpc session_id params =
- let multiplier = (try float_of_string (List.assoc "multiplier" params) with _ -> failwith "Failed to parse parameter 'multiplier': expecting a float") in
- let (_: unit list) = do_vm_op printer rpc session_id
- (fun vm ->
- let vm = vm.getref () in
- Client.VM.set_shadow_multiplier_live rpc session_id vm multiplier) params ["multiplier"] in
- ()
+ let multiplier = (try float_of_string (List.assoc "multiplier" params) with _ -> failwith "Failed to parse parameter 'multiplier': expecting a float") in
+ let (_: unit list) = do_vm_op printer rpc session_id
+ (fun vm ->
+ let vm = vm.getref () in
+ Client.VM.set_shadow_multiplier_live rpc session_id vm multiplier) params ["multiplier"] in
+ ()
let vm_start printer rpc session_id params =
- let force = get_bool_param params "force" in
- let paused = get_bool_param params "paused" in
- ignore(do_vm_op printer rpc session_id
- (fun vm ->
- let vm=vm.getref () in
- if List.mem_assoc "on" params
- then let host = get_host_by_name_or_id rpc session_id (List.assoc "on" params) in
- Client.VM.start_on rpc session_id vm (host.getref()) paused force
- else
- hook_no_hosts_available printer rpc session_id vm
- (fun ()->Client.VM.start rpc session_id vm paused force)
- ) params ["on"; "paused"])
+ let force = get_bool_param params "force" in
+ let paused = get_bool_param params "paused" in
+ ignore(do_vm_op printer rpc session_id
+ (fun vm ->
+ let vm=vm.getref () in
+ if List.mem_assoc "on" params
+ then let host = get_host_by_name_or_id rpc session_id (List.assoc "on" params) in
+ Client.VM.start_on rpc session_id vm (host.getref()) paused force
+ else
+ hook_no_hosts_available printer rpc session_id vm
+ (fun ()->Client.VM.start rpc session_id vm paused force)
+ ) params ["on"; "paused"])
let vm_suspend printer rpc session_id params =
- ignore(do_vm_op printer rpc session_id (fun vm -> Client.VM.suspend rpc session_id (vm.getref ())) params [])
+ ignore(do_vm_op printer rpc session_id (fun vm -> Client.VM.suspend rpc session_id (vm.getref ())) params [])
let vm_resume printer rpc session_id params =
- let force = get_bool_param params "force" in
- ignore(do_vm_op printer rpc session_id
- (fun vm ->
- if List.mem_assoc "on" params then
- let host = get_host_by_name_or_id rpc session_id (List.assoc "on" params) in
- Client.VM.resume_on rpc session_id (vm.getref()) (host.getref()) false force
- else
- let vm=vm.getref() in
- hook_no_hosts_available printer rpc session_id vm
- (fun ()->Client.VM.resume rpc session_id vm false force)) params ["on"])
+ let force = get_bool_param params "force" in
+ ignore(do_vm_op printer rpc session_id
+ (fun vm ->
+ if List.mem_assoc "on" params then
+ let host = get_host_by_name_or_id rpc session_id (List.assoc "on" params) in
+ Client.VM.resume_on rpc session_id (vm.getref()) (host.getref()) false force
+ else
+ let vm=vm.getref() in
+ hook_no_hosts_available printer rpc session_id vm
+ (fun ()->Client.VM.resume rpc session_id vm false force)) params ["on"])
let vm_pause printer rpc session_id params =
- ignore(do_vm_op printer rpc session_id (fun vm -> Client.VM.pause rpc session_id (vm.getref ())) params [])
+ ignore(do_vm_op printer rpc session_id (fun vm -> Client.VM.pause rpc session_id (vm.getref ())) params [])
let vm_unpause printer rpc session_id params =
- ignore(do_vm_op printer rpc session_id (fun vm -> Client.VM.unpause rpc session_id (vm.getref ())) params [])
+ ignore(do_vm_op printer rpc session_id (fun vm -> Client.VM.unpause rpc session_id (vm.getref ())) params [])
let vm_install_real printer rpc session_id template name description params =
- (* Rewrite the provisioning XML to refer to the sr-name-label, sr-uuid or the pool default_SR *)
- let sr_name_label =
- if List.mem_assoc "sr-name-label" params
- then match Client.SR.get_by_name_label rpc session_id (List.assoc "sr-name-label" params) with
- | [ sr ] -> Some (Client.SR.get_uuid rpc session_id sr)
- | [] -> failwith "No SR with that name-label found"
- | _ -> failwith "Multiple SRs with that name-label found"
- else None in
- let sr_uuid =
- if List.mem_assoc "sr-uuid" params
- then (let uuid = List.assoc "sr-uuid" params in
- ignore (Client.SR.get_by_uuid rpc session_id uuid); (* throws an exception if not found *)
- Some uuid)
- else None in
- let pool_default = get_default_sr_uuid rpc session_id in
-
- let sr_uuid = match sr_name_label, sr_uuid, pool_default with
- | Some x, _, _ -> x
- | _, Some x, _ -> x
- | _, _, Some x -> x
- | None, None, None ->
- let vbds = Client.VM.get_VBDs rpc session_id template in
- let disks = List.filter (fun vbd -> not (Client.VBD.get_type rpc session_id vbd = `CD && Client.VBD.get_empty rpc session_id vbd)) vbds in
- let has_provisioned_disks =
- let other_config = Client.VM.get_other_config rpc session_id template in
- if List.mem_assoc "disks" other_config && List.assoc "disks" other_config <> ""
- then match Xml.parse_string (List.assoc "disks" other_config) with
- | Xml.Element("provision",[],[]) -> false
- | _ -> true
- else false
- in
- if disks = [] && not has_provisioned_disks
- then Ref.string_of Ref.null
- else failwith "Failed to find a valid default SR for the Pool. Please provide an sr-name-label or sr-uuid parameter."
- in
+ (* Rewrite the provisioning XML to refer to the sr-name-label, sr-uuid or the pool default_SR *)
+ let sr_name_label =
+ if List.mem_assoc "sr-name-label" params
+ then match Client.SR.get_by_name_label rpc session_id (List.assoc "sr-name-label" params) with
+ | [ sr ] -> Some (Client.SR.get_uuid rpc session_id sr)
+ | [] -> failwith "No SR with that name-label found"
+ | _ -> failwith "Multiple SRs with that name-label found"
+ else None in
+ let sr_uuid =
+ if List.mem_assoc "sr-uuid" params
+ then (let uuid = List.assoc "sr-uuid" params in
+ ignore (Client.SR.get_by_uuid rpc session_id uuid); (* throws an exception if not found *)
+ Some uuid)
+ else None in
+ let pool_default = get_default_sr_uuid rpc session_id in
+
+ let sr_uuid = match sr_name_label, sr_uuid, pool_default with
+ | Some x, _, _ -> x
+ | _, Some x, _ -> x
+ | _, _, Some x -> x
+ | None, None, None ->
+ let vbds = Client.VM.get_VBDs rpc session_id template in
+ let disks = List.filter (fun vbd -> not (Client.VBD.get_type rpc session_id vbd = `CD && Client.VBD.get_empty rpc session_id vbd)) vbds in
+ let has_provisioned_disks =
+ let other_config = Client.VM.get_other_config rpc session_id template in
+ if List.mem_assoc "disks" other_config && List.assoc "disks" other_config <> ""
+ then match Xml.parse_string (List.assoc "disks" other_config) with
+ | Xml.Element("provision",[],[]) -> false
+ | _ -> true
+ else false
+ in
+ if disks = [] && not has_provisioned_disks
+ then Ref.string_of Ref.null
+ else failwith "Failed to find a valid default SR for the Pool. Please provide an sr-name-label or sr-uuid parameter."
+ in
if Client.VM.get_is_a_snapshot rpc session_id template && (List.mem_assoc "sr-name-label" params || List.mem_assoc "sr-uuid" params) then
failwith "Do not use the sr-name-label or sr-uuid argument when installing from a snapshot. By default, it will install each new disk on the same SR as the corresponding snapshot disks.";
- (* We should now have an sr-uuid *)
- let new_vm =
- if List.mem_assoc "sr-name-label" params || List.mem_assoc "sr-uuid" params
- then Client.VM.copy rpc session_id template name (Client.SR.get_by_uuid rpc session_id sr_uuid)
- else Client.VM.clone rpc session_id template name
- in
- try
- Client.VM.set_name_description rpc session_id new_vm description;
- rewrite_provisioning_xml rpc session_id new_vm sr_uuid;
- Client.VM.provision rpc session_id new_vm;
- (* Client.VM.start rpc session_id new_vm false true; *) (* stop install starting VMs *)
-
- (* copy BIOS strings if needed *)
- if List.mem_assoc "copy-bios-strings-from" params then begin
- let host = Client.Host.get_by_uuid rpc session_id (List.assoc "copy-bios-strings-from" params) in
- Client.VM.copy_bios_strings rpc session_id new_vm host
- end;
- debug "hello";
- let vm_uuid = Client.VM.get_uuid rpc session_id new_vm in
- printer (Cli_printer.PList [vm_uuid])
- with
- e ->
- begin
- (try Client.VM.destroy rpc session_id new_vm with _ -> ());
- raise e
- end
+ (* We should now have an sr-uuid *)
+ let new_vm =
+ if List.mem_assoc "sr-name-label" params || List.mem_assoc "sr-uuid" params
+ then Client.VM.copy rpc session_id template name (Client.SR.get_by_uuid rpc session_id sr_uuid)
+ else Client.VM.clone rpc session_id template name
+ in
+ try
+ Client.VM.set_name_description rpc session_id new_vm description;
+ rewrite_provisioning_xml rpc session_id new_vm sr_uuid;
+ Client.VM.provision rpc session_id new_vm;
+ (* Client.VM.start rpc session_id new_vm false true; *) (* stop install starting VMs *)
+
+ (* copy BIOS strings if needed *)
+ if List.mem_assoc "copy-bios-strings-from" params then begin
+ let host = Client.Host.get_by_uuid rpc session_id (List.assoc "copy-bios-strings-from" params) in
+ Client.VM.copy_bios_strings rpc session_id new_vm host
+ end;
+ debug "hello";
+ let vm_uuid = Client.VM.get_uuid rpc session_id new_vm in
+ printer (Cli_printer.PList [vm_uuid])
+ with
+ e ->
+ begin
+ (try Client.VM.destroy rpc session_id new_vm with _ -> ());
+ raise e
+ end
(* The process of finding the VM in this case is special-cased since we want to call the
* params 'template-name', like a foreign key, sort of *)
let vm_install printer rpc session_id params =
- (* Filter on everything on the cmd line except params=... *)
- let template =
- if List.mem_assoc "template-uuid" params
- then
- try
- Client.VM.get_by_uuid rpc session_id (List.assoc "template-uuid" params)
- with _ -> failwith "Cannot find template"
- else
- begin
- let filter_params = [("is-a-template", "true"); ("is-control-domain", "false")] in
- let vms = Client.VM.get_all_records_where rpc session_id "true" in
- let all_recs = List.map (fun (vm,vm_r) -> let r = vm_record rpc session_id vm in r.setrefrec (vm,vm_r); r) vms in
- let find_by_name name =
- let templates = List.fold_left filter_records_on_fields all_recs (("name-label",name)::filter_params) in
- match List.length templates with
- 0 -> failwith "No templates matched"
- | 1 -> (List.hd templates).getref ()
- | _ -> failwith "More than one matching template found"
- in
-
- if (List.mem_assoc "template-name-label" params) || (List.mem_assoc "template-name" params)
- then
- let template_name =
- if List.mem_assoc "template-name-label" params
- then (List.assoc "template-name-label" params)
- else (List.assoc "template-name" params) in
- find_by_name template_name
- else if List.mem_assoc "template" params
- then
- try
- Client.VM.get_by_uuid rpc session_id (List.assoc "template" params)
- with _ ->
- find_by_name (List.assoc "template" params)
- else
- failwith "Template must be specified by parameter 'template-uuid', 'template-name', 'template-name-label' or 'template'"
- end
- in
+ (* Filter on everything on the cmd line except params=... *)
+ let template =
+ if List.mem_assoc "template-uuid" params
+ then
+ try
+ Client.VM.get_by_uuid rpc session_id (List.assoc "template-uuid" params)
+ with _ -> failwith "Cannot find template"
+ else
+ begin
+ let filter_params = [("is-a-template", "true"); ("is-control-domain", "false")] in
+ let vms = Client.VM.get_all_records_where rpc session_id "true" in
+ let all_recs = List.map (fun (vm,vm_r) -> let r = vm_record rpc session_id vm in r.setrefrec (vm,vm_r); r) vms in
+ let find_by_name name =
+ let templates = List.fold_left filter_records_on_fields all_recs (("name-label",name)::filter_params) in
+ match List.length templates with
+ 0 -> failwith "No templates matched"
+ | 1 -> (List.hd templates).getref ()
+ | _ -> failwith "More than one matching template found"
+ in
+
+ if (List.mem_assoc "template-name-label" params) || (List.mem_assoc "template-name" params)
+ then
+ let template_name =
+ if List.mem_assoc "template-name-label" params
+ then (List.assoc "template-name-label" params)
+ else (List.assoc "template-name" params) in
+ find_by_name template_name
+ else if List.mem_assoc "template" params
+ then
+ try
+ Client.VM.get_by_uuid rpc session_id (List.assoc "template" params)
+ with _ ->
+ find_by_name (List.assoc "template" params)
+ else
+ failwith "Template must be specified by parameter 'template-uuid', 'template-name', 'template-name-label' or 'template'"
+ end
+ in
- if not (Client.VM.get_is_a_template rpc session_id template) then failwith "Can only install from templates";
- let new_name = List.assoc "new-name-label" params in
- let new_description = "Installed via xe CLI" in (* Client.VM.get_name_description rpc session_id template in *)
- vm_install_real printer rpc session_id template new_name new_description params
+ if not (Client.VM.get_is_a_template rpc session_id template) then failwith "Can only install from templates";
+ let new_name = List.assoc "new-name-label" params in
+ let new_description = "Installed via xe CLI" in (* Client.VM.get_name_description rpc session_id template in *)
+ vm_install_real printer rpc session_id template new_name new_description params
let vm_uninstall_common fd printer rpc session_id params vms =
- let toremove = ref [] in
- let toprint = ref [] in
- let compat = get_bool_param params "compat_mode" in
- (* Destroy the disks too *)
- let choose_objects_to_delete vm =
- let vbds=Client.VM.get_VBDs rpc session_id vm in
-
- let string_of_vdi vdi =
- (* add extra text if the VDI is being shared *)
- let r = Client.VDI.get_record rpc session_id vdi in
- Printf.sprintf "VDI: %s (%s) %s" r.API.vDI_uuid r.API.vDI_name_label
- (if List.length r.API.vDI_VBDs <= 1 then "" else " ** WARNING: disk is shared by other VMs") in
- let string_of_vm vm =
- let r = Client.VM.get_record rpc session_id vm in
- Printf.sprintf "VM : %s (%s)" r.API.vM_uuid r.API.vM_name_label in
-
- (* NB If a VDI is deleted then the VBD may be GCed at any time. *)
- let vdis = List.concat (List.map
- (fun vbd ->
- try
- (* We only destroy VDIs where VBD.other_config contains 'owner' *)
- let other_config = Client.VBD.get_other_config rpc session_id vbd in
- let vdi = Client.VBD.get_VDI rpc session_id vbd in
- (* Double-check the VDI actually exists *)
- ignore(Client.VDI.get_uuid rpc session_id vdi);
- if List.mem_assoc Xapi_globs.owner_key other_config
- then [ vdi ] else [ ]
- with _ -> []) vbds) in
- let suspend_VDI =
- try
- let vdi = Client.VM.get_suspend_VDI rpc session_id vm in
- ignore (Client.VDI.get_uuid rpc session_id vdi);
- vdi
- with _ -> Ref.null in
- let output = string_of_vm vm :: (List.map string_of_vdi vdis) @ (if suspend_VDI = Ref.null then [] else [string_of_vdi suspend_VDI]) in
- toprint := !toprint @ output;
- let destroy () =
- if Client.VM.get_power_state rpc session_id vm <> `Halted then Client.VM.hard_shutdown rpc session_id vm;
- Client.VM.destroy rpc session_id vm;
- List.iter (fun vdi -> Client.VDI.destroy rpc session_id vdi) vdis;
- if suspend_VDI <> Ref.null then try Client.VDI.destroy rpc session_id suspend_VDI with _ -> ()
- in
- toremove := !toremove @ [destroy];
- in
- List.iter choose_objects_to_delete vms;
- marshal fd (Command (Print "The following items are about to be destroyed"));
- List.iter (fun s -> marshal fd (Command (Print s))) !toprint;
- let force = compat || (get_bool_param params "force") in
- if force then
- (List.iter (fun f -> f ()) !toremove; marshal fd (Command (Print "All objects destroyed")))
- else
- begin
- if user_says_yes fd
- then (List.iter (fun f -> f ()) !toremove; marshal fd (Command (Print "All objects destroyed")))
- end
+ let toremove = ref [] in
+ let toprint = ref [] in
+ let compat = get_bool_param params "compat_mode" in
+ (* Destroy the disks too *)
+ let choose_objects_to_delete vm =
+ let vbds=Client.VM.get_VBDs rpc session_id vm in
+
+ let string_of_vdi vdi =
+ (* add extra text if the VDI is being shared *)
+ let r = Client.VDI.get_record rpc session_id vdi in
+ Printf.sprintf "VDI: %s (%s) %s" r.API.vDI_uuid r.API.vDI_name_label
+ (if List.length r.API.vDI_VBDs <= 1 then "" else " ** WARNING: disk is shared by other VMs") in
+ let string_of_vm vm =
+ let r = Client.VM.get_record rpc session_id vm in
+ Printf.sprintf "VM : %s (%s)" r.API.vM_uuid r.API.vM_name_label in
+
+ (* NB If a VDI is deleted then the VBD may be GCed at any time. *)
+ let vdis = List.concat (List.map
+ (fun vbd ->
+ try
+ (* We only destroy VDIs where VBD.other_config contains 'owner' *)
+ let other_config = Client.VBD.get_other_config rpc session_id vbd in
+ let vdi = Client.VBD.get_VDI rpc session_id vbd in
+ (* Double-check the VDI actually exists *)
+ ignore(Client.VDI.get_uuid rpc session_id vdi);
+ if List.mem_assoc Xapi_globs.owner_key other_config
+ then [ vdi ] else [ ]
+ with _ -> []) vbds) in
+ let suspend_VDI =
+ try
+ let vdi = Client.VM.get_suspend_VDI rpc session_id vm in
+ ignore (Client.VDI.get_uuid rpc session_id vdi);
+ vdi
+ with _ -> Ref.null in
+ let output = string_of_vm vm :: (List.map string_of_vdi vdis) @ (if suspend_VDI = Ref.null then [] else [string_of_vdi suspend_VDI]) in
+ toprint := !toprint @ output;
+ let destroy () =
+ if Client.VM.get_power_state rpc session_id vm <> `Halted then Client.VM.hard_shutdown rpc session_id vm;
+ Client.VM.destroy rpc session_id vm;
+ List.iter (fun vdi -> Client.VDI.destroy rpc session_id vdi) vdis;
+ if suspend_VDI <> Ref.null then try Client.VDI.destroy rpc session_id suspend_VDI with _ -> ()
+ in
+ toremove := !toremove @ [destroy];
+ in
+ List.iter choose_objects_to_delete vms;
+ marshal fd (Command (Print "The following items are about to be destroyed"));
+ List.iter (fun s -> marshal fd (Command (Print s))) !toprint;
+ let force = compat || (get_bool_param params "force") in
+ if force then
+ (List.iter (fun f -> f ()) !toremove; marshal fd (Command (Print "All objects destroyed")))
+ else
+ begin
+ if user_says_yes fd
+ then (List.iter (fun f -> f ()) !toremove; marshal fd (Command (Print "All objects destroyed")))
+ end
let vm_uninstall fd printer rpc session_id params =
- let vms = do_vm_op printer rpc session_id (fun vm -> vm.getref()) params [] in
- let snapshots = List.flatten (List.map (fun vm -> Client.VM.get_snapshots rpc session_id vm) vms) in
- vm_uninstall_common fd printer rpc session_id params (vms @ snapshots)
+ let vms = do_vm_op printer rpc session_id (fun vm -> vm.getref()) params [] in
+ let snapshots = List.flatten (List.map (fun vm -> Client.VM.get_snapshots rpc session_id vm) vms) in
+ vm_uninstall_common fd printer rpc session_id params (vms @ snapshots)
let template_uninstall fd printer rpc session_id params =
- let uuid = List.assoc "template-uuid" params in
- let vm = Client.VM.get_by_uuid rpc session_id uuid in
- vm_uninstall_common fd printer rpc session_id params [ vm ]
+ let uuid = List.assoc "template-uuid" params in
+ let vm = Client.VM.get_by_uuid rpc session_id uuid in
+ vm_uninstall_common fd printer rpc session_id params [ vm ]
let vm_clone_aux clone_op cloned_string printer include_template_vms rpc session_id params =
- let compat = get_bool_param params "compat_mode" in
- let new_name =
- if compat then
- List.assoc "new-name" params
- else
- List.assoc "new-name-label" params in
- let desc = try Some (List.assoc "new-name-description" params) with _ -> None in
- let new_vms = do_vm_op printer ~multiple:false ~include_template_vms rpc session_id (fun vm -> clone_op ~rpc ~session_id ~vm: (vm.getref()) ~new_name) params ["new-name-label"; "new-name-description"] in
- ignore (may (fun desc -> Client.VM.set_name_description rpc session_id (List.hd new_vms) desc) desc);
- if compat then
- printer (Cli_printer.PList (List.map (fun vm -> cloned_string^" VM uuid : "^Client.VM.get_uuid rpc session_id vm) new_vms))
- else
- printer (Cli_printer.PList (List.map (fun vm -> Client.VM.get_uuid rpc session_id vm) new_vms))
+ let compat = get_bool_param params "compat_mode" in
+ let new_name =
+ if compat then
+ List.assoc "new-name" params
+ else
+ List.assoc "new-name-label" params in
+ let desc = try Some (List.assoc "new-name-description" params) with _ -> None in
+ let new_vms = do_vm_op printer ~multiple:false ~include_template_vms rpc session_id (fun vm -> clone_op ~rpc ~session_id ~vm: (vm.getref()) ~new_name) params ["new-name-label"; "new-name-description"] in
+ ignore (may (fun desc -> Client.VM.set_name_description rpc session_id (List.hd new_vms) desc) desc);
+ if compat then
+ printer (Cli_printer.PList (List.map (fun vm -> cloned_string^" VM uuid : "^Client.VM.get_uuid rpc session_id vm) new_vms))
+ else
+ printer (Cli_printer.PList (List.map (fun vm -> Client.VM.get_uuid rpc session_id vm) new_vms))
let vm_clone printer = vm_clone_aux Client.VM.clone "Cloned " printer true
let vm_snapshot printer = vm_clone_aux Client.VM.snapshot "Snapshotted " printer false
let vm_checkpoint printer = vm_clone_aux Client.VM.checkpoint "Checkpointed " printer false
let get_snapshot_uuid params =
- if List.mem_assoc "snapshot-uuid" params
- then List.assoc "snapshot-uuid" params
- else List.assoc "uuid" params
+ if List.mem_assoc "snapshot-uuid" params
+ then List.assoc "snapshot-uuid" params
+ else List.assoc "uuid" params
let snapshot_revert printer rpc session_id params =
- let snap_uuid = get_snapshot_uuid params in
+ let snap_uuid = get_snapshot_uuid params in
let snap_ref = Client.VM.get_by_uuid rpc session_id snap_uuid in
Client.VM.revert ~rpc ~session_id ~snapshot:snap_ref
vm_uninstall_common fd printer rpc session_id params [snap_ref]
let vm_copy printer rpc session_id params =
- let new_name = List.assoc "new-name-label" params in
- let desc = try Some (List.assoc "new-name-description" params) with _ -> None in
- let sr = if List.mem_assoc "sr-uuid" params then Client.SR.get_by_uuid rpc session_id (List.assoc "sr-uuid" params) else Ref.null in
- let new_vms = do_vm_op printer ~multiple:false ~include_template_vms:true rpc session_id (fun vm -> Client.VM.copy rpc session_id (vm.getref()) new_name sr) params ["new-name-label"; "sr-uuid"; "new-name-description"] in
- ignore (may (fun desc -> Client.VM.set_name_description rpc session_id (List.hd new_vms) desc) desc);
- printer (Cli_printer.PList (List.map (fun vm -> Client.VM.get_uuid rpc session_id vm) new_vms))
+ let new_name = List.assoc "new-name-label" params in
+ let desc = try Some (List.assoc "new-name-description" params) with _ -> None in
+ let sr = if List.mem_assoc "sr-uuid" params then Client.SR.get_by_uuid rpc session_id (List.assoc "sr-uuid" params) else Ref.null in
+ let new_vms = do_vm_op printer ~multiple:false ~include_template_vms:true rpc session_id (fun vm -> Client.VM.copy rpc session_id (vm.getref()) new_name sr) params ["new-name-label"; "sr-uuid"; "new-name-description"] in
+ ignore (may (fun desc -> Client.VM.set_name_description rpc session_id (List.hd new_vms) desc) desc);
+ printer (Cli_printer.PList (List.map (fun vm -> Client.VM.get_uuid rpc session_id vm) new_vms))
let vm_reset_powerstate printer rpc session_id params =
- if not (List.mem_assoc "force" params) then
- failwith "This operation is extremely dangerous and may cause data loss. This operation must be forced (use --force).";
- ignore (do_vm_op printer rpc session_id (fun vm -> Client.VM.power_state_reset rpc session_id (vm.getref())) params [])
+ if not (List.mem_assoc "force" params) then
+ failwith "This operation is extremely dangerous and may cause data loss. This operation must be forced (use --force).";
+ ignore (do_vm_op printer rpc session_id (fun vm -> Client.VM.power_state_reset rpc session_id (vm.getref())) params [])
let snapshot_reset_powerstate printer rpc session_id params =
if not (List.mem_assoc "force" params) then
Client.VM.power_state_reset rpc session_id snapshot
let vm_shutdown printer rpc session_id params =
- let force = get_bool_param params "force" in
- ignore(if force
- then do_vm_op printer rpc session_id (fun vm -> Client.VM.hard_shutdown rpc session_id (vm.getref())) params []
- else do_vm_op printer rpc session_id (fun vm -> Client.VM.clean_shutdown rpc session_id (vm.getref())) params [])
+ let force = get_bool_param params "force" in
+ ignore(if force
+ then do_vm_op printer rpc session_id (fun vm -> Client.VM.hard_shutdown rpc session_id (vm.getref())) params []
+ else do_vm_op printer rpc session_id (fun vm -> Client.VM.clean_shutdown rpc session_id (vm.getref())) params [])
let vm_reboot printer rpc session_id params =
- let force = get_bool_param params "force" in
- ignore(if force
- then do_vm_op printer rpc session_id (fun vm -> Client.VM.hard_reboot rpc session_id (vm.getref())) params []
- else do_vm_op printer rpc session_id (fun vm -> Client.VM.clean_reboot rpc session_id (vm.getref())) params [])
+ let force = get_bool_param params "force" in
+ ignore(if force
+ then do_vm_op printer rpc session_id (fun vm -> Client.VM.hard_reboot rpc session_id (vm.getref())) params []
+ else do_vm_op printer rpc session_id (fun vm -> Client.VM.clean_reboot rpc session_id (vm.getref())) params [])
let vm_compute_maximum_memory printer rpc session_id params =
- let total = Record_util.bytes_of_string "total" (List.assoc "total" params) in
- let approximate = get_bool_param params "approximate" in
- ignore(do_vm_op printer rpc session_id
- (fun vm ->
- let max = Client.VM.maximise_memory rpc session_id (vm.getref()) total approximate in
- printer (Cli_printer.PList [Printf.sprintf "%Ld" max]))
- params [ "total"; "approximate" ])
+ let total = Record_util.bytes_of_string "total" (List.assoc "total" params) in
+ let approximate = get_bool_param params "approximate" in
+ ignore(do_vm_op printer rpc session_id
+ (fun vm ->
+ let max = Client.VM.maximise_memory rpc session_id (vm.getref()) total approximate in
+ printer (Cli_printer.PList [Printf.sprintf "%Ld" max]))
+ params [ "total"; "approximate" ])
let vm_retrieve_wlb_recommendations printer rpc session_id params =
- let table vm =
- List.map (fun (host,recom) -> (Client.Host.get_name_label rpc session_id host, String.concat " " recom))
- (Client.VM.retrieve_wlb_recommendations rpc session_id (vm.getref()))
- in
- try
- let vms = select_vms rpc session_id params [] in
- match List.length vms with
- | 0 -> failwith "No matching VMs found"
- | 1 -> printer (Cli_printer.PTable [("Host", "Stars, RecID, ZeroScoreReason") :: table (List.hd vms)])
- | _ -> failwith "Multiple VMs found. Operation can only be performed on one VM at a time"
- with
- | Records.CLI_failed_to_find_param name ->
- failwith ("Parameter '"^name^"' is not a field of the VM class. Failed to select VM for operation.")
+ let table vm =
+ List.map (fun (host,recom) -> (Client.Host.get_name_label rpc session_id host, String.concat " " recom))
+ (Client.VM.retrieve_wlb_recommendations rpc session_id (vm.getref()))
+ in
+ try
+ let vms = select_vms rpc session_id params [] in
+ match List.length vms with
+ | 0 -> failwith "No matching VMs found"
+ | 1 -> printer (Cli_printer.PTable [("Host", "Stars, RecID, ZeroScoreReason") :: table (List.hd vms)])
+ | _ -> failwith "Multiple VMs found. Operation can only be performed on one VM at a time"
+ with
+ | Records.CLI_failed_to_find_param name ->
+ failwith ("Parameter '"^name^"' is not a field of the VM class. Failed to select VM for operation.")
let vm_migrate printer rpc session_id params =
(* Hack to match host-uuid and host-name for backwards compatibility *)
let host = (get_host_by_name_or_id rpc session_id (List.assoc "host" params)).getref () in
let options = List.map_assoc_with_key (string_of_bool +++ bool_of_string) (List.restrict_with_default "false" ["live"; "encrypt"] params) in
ignore(do_vm_op printer rpc session_id (fun vm -> Client.VM.pool_migrate rpc session_id (vm.getref ()) host options)
- params ["host"; "host-uuid"; "host-name"; "live"; "encrypt"])
+ params ["host"; "host-uuid"; "host-name"; "live"; "encrypt"])
let vm_disk_list_aux vm is_cd_list printer rpc session_id params =
- let vbds = List.filter (fun vbd -> Client.VBD.get_type rpc session_id vbd = (if is_cd_list then `CD else `Disk)) (vm.record()).API.vM_VBDs in
- let vbdrecords = List.map (fun vbd-> (vbd_record rpc session_id vbd)) vbds in
- let vdirecords = List.map (fun vbd ->
- if not (Client.VBD.get_empty rpc session_id vbd) then Some (vdi_record rpc session_id (Client.VBD.get_VDI rpc session_id vbd)) else None) vbds in
- (* Hack - convert 'vbd-params' to 'params' *)
- let params' = List.map (fun (a,b) -> if a="vbd-params" then ("params",b) else (a,b)) params in
- let selectedvbd = select_fields params' vbdrecords
- (if is_cd_list
- then ["uuid"; "vm-name-label"; "userdevice"; "empty"]
- else ["uuid"; "vm-name-label"; "userdevice"])
- in
- let params' = List.map (fun (a,b) -> if a="vdi-params" then ("params",b) else (a,b)) params in
- let rec doit vbds vdis n =
- match (vbds,vdis) with
- | ([],[]) -> ()
- | (vbd::vbds,vdi::vdis) ->
- let disk = (if is_cd_list then "CD " else "Disk ")^string_of_int n in
- printer (Cli_printer.PMsg (disk ^ " VBD:"));
- printer (Cli_printer.PTable [(List.map print_field vbd)]);
- (* Only print out the VDI if there is one - empty cds don't have one *)
- begin
- match vdi with
- Some vdi ->
- let selectedvdi = List.hd (select_fields params' [vdi] ["uuid"; "name-label"; "virtual-size"; "sr-name-label"]) in
- printer (Cli_printer.PMsg (disk ^ " VDI:"));
- printer (Cli_printer.PTable [(List.map print_field selectedvdi)]);
- | None -> ()
- end;
- doit vbds vdis (n+1)
- | _ -> (failwith "Unexpected mismatch in list length in vm_disk_list")
- in doit selectedvbd vdirecords 0
+ let vbds = List.filter (fun vbd -> Client.VBD.get_type rpc session_id vbd = (if is_cd_list then `CD else `Disk)) (vm.record()).API.vM_VBDs in
+ let vbdrecords = List.map (fun vbd-> (vbd_record rpc session_id vbd)) vbds in
+ let vdirecords = List.map (fun vbd ->
+ if not (Client.VBD.get_empty rpc session_id vbd) then Some (vdi_record rpc session_id (Client.VBD.get_VDI rpc session_id vbd)) else None) vbds in
+ (* Hack - convert 'vbd-params' to 'params' *)
+ let params' = List.map (fun (a,b) -> if a="vbd-params" then ("params",b) else (a,b)) params in
+ let selectedvbd = select_fields params' vbdrecords
+ (if is_cd_list
+ then ["uuid"; "vm-name-label"; "userdevice"; "empty"]
+ else ["uuid"; "vm-name-label"; "userdevice"])
+ in
+ let params' = List.map (fun (a,b) -> if a="vdi-params" then ("params",b) else (a,b)) params in
+ let rec doit vbds vdis n =
+ match (vbds,vdis) with
+ | ([],[]) -> ()
+ | (vbd::vbds,vdi::vdis) ->
+ let disk = (if is_cd_list then "CD " else "Disk ")^string_of_int n in
+ printer (Cli_printer.PMsg (disk ^ " VBD:"));
+ printer (Cli_printer.PTable [(List.map print_field vbd)]);
+ (* Only print out the VDI if there is one - empty cds don't have one *)
+ begin
+ match vdi with
+ Some vdi ->
+ let selectedvdi = List.hd (select_fields params' [vdi] ["uuid"; "name-label"; "virtual-size"; "sr-name-label"]) in
+ printer (Cli_printer.PMsg (disk ^ " VDI:"));
+ printer (Cli_printer.PTable [(List.map print_field selectedvdi)]);
+ | None -> ()
+ end;
+ doit vbds vdis (n+1)
+ | _ -> (failwith "Unexpected mismatch in list length in vm_disk_list")
+ in doit selectedvbd vdirecords 0
let vm_disk_list is_cd_list printer rpc session_id params =
let op vm = vm_disk_list_aux vm is_cd_list printer rpc session_id params in
vm_disk_list_aux snapshot is_cd_list printer rpc session_id params
let vm_crashdump_list printer rpc session_id params =
- let op vm =
- let records = List.map (fun crashdump -> (crashdump_record rpc session_id crashdump).fields) (vm.record()).API.vM_crash_dumps in
- printer (Cli_printer.PTable (List.map (List.map print_field) records))
- in
- ignore(do_vm_op printer rpc session_id op params [])
+ let op vm =
+ let records = List.map (fun crashdump -> (crashdump_record rpc session_id crashdump).fields) (vm.record()).API.vM_crash_dumps in
+ printer (Cli_printer.PTable (List.map (List.map print_field) records))
+ in
+ ignore(do_vm_op printer rpc session_id op params [])
(* Disk add creates a VDI with the size, sr specified. The name and sector size
* can be optionally specified. A VBD is then creased with the device name as specified *)
let vm_disk_add printer rpc session_id params =
-(* Required params *)
- let compat = get_bool_param params "compat_mode" in
- let vdi_size =
- if not compat then
- Record_util.bytes_of_string "disk-size" (List.assoc "disk-size" params)
- else
- try Int64.shift_left (Int64.of_string (List.assoc "disk-size" params)) 20
- with _ -> (failwith "Failed to parse parameter 'disk-size': expecting an integer") in
- let vbd_device =
- if not compat then
- List.assoc "device" params
- else
- List.assoc "disk-name" params in
- let sr =
- if List.mem_assoc "sr-uuid" params then
- let sr_uuid = List.assoc "sr-uuid" params in
- Client.SR.get_by_uuid rpc session_id sr_uuid
- else
- match get_default_sr_uuid rpc session_id with
- | Some x -> Client.SR.get_by_uuid rpc session_id x
- | None -> failwith "No default Pool SR set; you must specify an SR on the commandline"
- in
- (* Optional params *)
- let vdi_name = "Created by xe" in
- let op vm =
- let vm=vm.getref() in
- let vmuuid = Client.VM.get_uuid ~rpc ~session_id ~self:vm in
- let sm_config = [ Xapi_globs._sm_vm_hint, vmuuid ] in
- let vdi = Client.VDI.create ~rpc ~session_id ~name_label:vdi_name ~name_description:vdi_name ~sR:sr ~virtual_size:vdi_size ~_type:`user ~sharable:false ~read_only:false ~other_config:[] ~xenstore_data:[] ~sm_config ~tags:[] in
- try
- let _ =
- create_owner_vbd_and_plug rpc session_id vm vdi
- vbd_device false `RW `Disk true "" [] in
- ()
- with
- e ->
- Client.VDI.destroy rpc session_id vdi;
- raise e
- in
- ignore(do_vm_op printer rpc session_id op params ["sr-uuid";"device";"disk-size"])
+ (* Required params *)
+ let compat = get_bool_param params "compat_mode" in
+ let vdi_size =
+ if not compat then
+ Record_util.bytes_of_string "disk-size" (List.assoc "disk-size" params)
+ else
+ try Int64.shift_left (Int64.of_string (List.assoc "disk-size" params)) 20
+ with _ -> (failwith "Failed to parse parameter 'disk-size': expecting an integer") in
+ let vbd_device =
+ if not compat then
+ List.assoc "device" params
+ else
+ List.assoc "disk-name" params in
+ let sr =
+ if List.mem_assoc "sr-uuid" params then
+ let sr_uuid = List.assoc "sr-uuid" params in
+ Client.SR.get_by_uuid rpc session_id sr_uuid
+ else
+ match get_default_sr_uuid rpc session_id with
+ | Some x -> Client.SR.get_by_uuid rpc session_id x
+ | None -> failwith "No default Pool SR set; you must specify an SR on the commandline"
+ in
+ (* Optional params *)
+ let vdi_name = "Created by xe" in
+ let op vm =
+ let vm=vm.getref() in
+ let vmuuid = Client.VM.get_uuid ~rpc ~session_id ~self:vm in
+ let sm_config = [ Xapi_globs._sm_vm_hint, vmuuid ] in
+ let vdi = Client.VDI.create ~rpc ~session_id ~name_label:vdi_name ~name_description:vdi_name ~sR:sr ~virtual_size:vdi_size ~_type:`user ~sharable:false ~read_only:false ~other_config:[] ~xenstore_data:[] ~sm_config ~tags:[] in
+ try
+ let _ =
+ create_owner_vbd_and_plug rpc session_id vm vdi
+ vbd_device false `RW `Disk true "" [] in
+ ()
+ with
+ e ->
+ Client.VDI.destroy rpc session_id vdi;
+ raise e
+ in
+ ignore(do_vm_op printer rpc session_id op params ["sr-uuid";"device";"disk-size"])
let vm_disk_remove printer rpc session_id params =
- let compat = get_bool_param params "compat_mode" in
- let device =
- if not compat then
- List.assoc "device" params
- else
- List.assoc "disk-name" params
- in
- let op vm =
- let vm=vm.getref() in
- let vm_record = Client.VM.get_record rpc session_id vm in
- let vbd_to_remove = List.filter (fun x -> device = Client.VBD.get_userdevice rpc session_id x) vm_record.API.vM_VBDs in
- if List.length vbd_to_remove < 1 then (failwith "Disk not found") else
- let vbd = List.nth vbd_to_remove 0 in
- let vdi = Client.VBD.get_VDI rpc session_id vbd in
- Client.VBD.destroy rpc session_id vbd;
- Client.VDI.destroy rpc session_id vdi
- in
- ignore(do_vm_op printer rpc session_id op params ["device"])
+ let compat = get_bool_param params "compat_mode" in
+ let device =
+ if not compat then
+ List.assoc "device" params
+ else
+ List.assoc "disk-name" params
+ in
+ let op vm =
+ let vm=vm.getref() in
+ let vm_record = Client.VM.get_record rpc session_id vm in
+ let vbd_to_remove = List.filter (fun x -> device = Client.VBD.get_userdevice rpc session_id x) vm_record.API.vM_VBDs in
+ if List.length vbd_to_remove < 1 then (failwith "Disk not found") else
+ let vbd = List.nth vbd_to_remove 0 in
+ let vdi = Client.VBD.get_VDI rpc session_id vbd in
+ Client.VBD.destroy rpc session_id vbd;
+ Client.VDI.destroy rpc session_id vdi
+ in
+ ignore(do_vm_op printer rpc session_id op params ["device"])
let vm_disk_detach printer rpc session_id params =
- let device = List.assoc "device" params in
- let op vm =
- let vm_record = vm.record () in
- let vbd_to_remove = List.filter (fun x -> device = Client.VBD.get_userdevice rpc session_id x) vm_record.API.vM_VBDs in
- if List.length vbd_to_remove < 1 then (failwith "Disk not found") else
- let vbd = List.nth vbd_to_remove 0 in
- Client.VBD.destroy rpc session_id vbd
- in
- ignore(do_vm_op printer rpc session_id op params ["device"])
+ let device = List.assoc "device" params in
+ let op vm =
+ let vm_record = vm.record () in
+ let vbd_to_remove = List.filter (fun x -> device = Client.VBD.get_userdevice rpc session_id x) vm_record.API.vM_VBDs in
+ if List.length vbd_to_remove < 1 then (failwith "Disk not found") else
+ let vbd = List.nth vbd_to_remove 0 in
+ Client.VBD.destroy rpc session_id vbd
+ in
+ ignore(do_vm_op printer rpc session_id op params ["device"])
let vm_disk_resize printer rpc session_id params =
- let compat = get_bool_param params "compat_mode" in
- let device =
- if not compat then
- List.assoc "device" params
- else
- List.assoc "disk-name" params
- in
- let new_size =
- if not compat then
- Record_util.bytes_of_string "disk-size" (List.assoc "disk-size" params)
- else
- try Int64.shift_left (Int64.of_string (List.assoc "disk-size" params)) 20
- with _ -> (failwith "Failed to parse parameter 'disk-size': expecting an integer") in
- let op vm =
- let vm_record = vm.record () in
- let vbd_to_resize = List.filter (fun x -> device = Client.VBD.get_userdevice rpc session_id x) vm_record.API.vM_VBDs in
- if List.length vbd_to_resize < 1 then (failwith "Disk not found") else
- let vbd = List.nth vbd_to_resize 0 in
- let vdi = Client.VBD.get_VDI rpc session_id vbd in
- Client.VDI.resize rpc session_id vdi new_size
- in
- ignore(do_vm_op printer rpc session_id op params ["device";"disk-size"])
+ let compat = get_bool_param params "compat_mode" in
+ let device =
+ if not compat then
+ List.assoc "device" params
+ else
+ List.assoc "disk-name" params
+ in
+ let new_size =
+ if not compat then
+ Record_util.bytes_of_string "disk-size" (List.assoc "disk-size" params)
+ else
+ try Int64.shift_left (Int64.of_string (List.assoc "disk-size" params)) 20
+ with _ -> (failwith "Failed to parse parameter 'disk-size': expecting an integer") in
+ let op vm =
+ let vm_record = vm.record () in
+ let vbd_to_resize = List.filter (fun x -> device = Client.VBD.get_userdevice rpc session_id x) vm_record.API.vM_VBDs in
+ if List.length vbd_to_resize < 1 then (failwith "Disk not found") else
+ let vbd = List.nth vbd_to_resize 0 in
+ let vdi = Client.VBD.get_VDI rpc session_id vbd in
+ Client.VDI.resize rpc session_id vdi new_size
+ in
+ ignore(do_vm_op printer rpc session_id op params ["device";"disk-size"])
let vm_cd_remove printer rpc session_id params =
- let disk_name = List.assoc "cd-name" params in
- let op vm =
- let vm_record = vm.record () in
- let vbd_to_remove = List.filter
- (fun x ->
- try
- let vdi = (Client.VBD.get_VDI rpc session_id x) in
- let sr = (Client.VDI.get_SR rpc session_id vdi) in
- ("iso"=Client.SR.get_content_type rpc session_id sr) &&
- (disk_name = Client.VDI.get_name_label rpc session_id vdi)
- with _ (* VDI handle invalid *) -> disk_name="<EMPTY>") vm_record.API.vM_VBDs in
- if List.length vbd_to_remove < 1 then raise (failwith "Disk not found") else
- let vbd = List.nth vbd_to_remove 0 in
- Client.VBD.destroy rpc session_id vbd
- in
- ignore(do_vm_op printer rpc session_id op params ["cd-name"])
+ let disk_name = List.assoc "cd-name" params in
+ let op vm =
+ let vm_record = vm.record () in
+ let vbd_to_remove = List.filter
+ (fun x ->
+ try
+ let vdi = (Client.VBD.get_VDI rpc session_id x) in
+ let sr = (Client.VDI.get_SR rpc session_id vdi) in
+ ("iso"=Client.SR.get_content_type rpc session_id sr) &&
+ (disk_name = Client.VDI.get_name_label rpc session_id vdi)
+ with _ (* VDI handle invalid *) -> disk_name="<EMPTY>") vm_record.API.vM_VBDs in
+ if List.length vbd_to_remove < 1 then raise (failwith "Disk not found") else
+ let vbd = List.nth vbd_to_remove 0 in
+ Client.VBD.destroy rpc session_id vbd
+ in
+ ignore(do_vm_op printer rpc session_id op params ["cd-name"])
let vm_cd_add printer rpc session_id params =
- let compat = get_bool_param params "compat_mode" in
- let cd_name = List.assoc "cd-name" params in
- let vdis = Client.VDI.get_by_name_label rpc session_id cd_name in
- let vdis = List.filter (fun vdi -> let sr = Client.VDI.get_SR rpc session_id vdi in "iso"=Client.SR.get_content_type rpc session_id sr) vdis in
- (if List.length vdis = 0 then (failwith ("CD "^cd_name^" not found!")));
- let vdi = List.nth vdis 0 in
- let op vm =
- let vm_record = vm.record () in
- let device_name =
- if compat then
- (* Geneva always adds cd drives to hdd if HVM and sdd if not *)
- (if vm_record.API.vM_HVM_boot_policy = "BIOS order" then "hdd" else "sdd")
- else
- List.assoc "device" params in
- create_vbd_and_plug rpc session_id (vm.getref()) vdi device_name false `RO `CD true "" []
- in
- ignore(do_vm_op printer rpc session_id op params ["cd-name";"device";"cd-location"]) (* cd-location was a geneva-style param *)
+ let compat = get_bool_param params "compat_mode" in
+ let cd_name = List.assoc "cd-name" params in
+ let vdis = Client.VDI.get_by_name_label rpc session_id cd_name in
+ let vdis = List.filter (fun vdi -> let sr = Client.VDI.get_SR rpc session_id vdi in "iso"=Client.SR.get_content_type rpc session_id sr) vdis in
+ (if List.length vdis = 0 then (failwith ("CD "^cd_name^" not found!")));
+ let vdi = List.nth vdis 0 in
+ let op vm =
+ let vm_record = vm.record () in
+ let device_name =
+ if compat then
+ (* Geneva always adds cd drives to hdd if HVM and sdd if not *)
+ (if vm_record.API.vM_HVM_boot_policy = "BIOS order" then "hdd" else "sdd")
+ else
+ List.assoc "device" params in
+ create_vbd_and_plug rpc session_id (vm.getref()) vdi device_name false `RO `CD true "" []
+ in
+ ignore(do_vm_op printer rpc session_id op params ["cd-name";"device";"cd-location"]) (* cd-location was a geneva-style param *)
let vm_cd_eject printer rpc session_id params =
- let op vm =
- let vm_record = vm.record () in
- let vbds = vm_record.API.vM_VBDs in
- let cdvbds = List.filter (fun vbd -> Client.VBD.get_type rpc session_id vbd = `CD) vbds in
- if List.length cdvbds = 0 then (failwith "No CDs found");
- if List.length cdvbds > 1 then (failwith "Two or more CDs found. Please use vbd-eject");
- let cd = List.hd cdvbds in
- Client.VBD.eject rpc session_id cd
- in
- ignore(do_vm_op printer rpc session_id op params [])
+ let op vm =
+ let vm_record = vm.record () in
+ let vbds = vm_record.API.vM_VBDs in
+ let cdvbds = List.filter (fun vbd -> Client.VBD.get_type rpc session_id vbd = `CD) vbds in
+ if List.length cdvbds = 0 then (failwith "No CDs found");
+ if List.length cdvbds > 1 then (failwith "Two or more CDs found. Please use vbd-eject");
+ let cd = List.hd cdvbds in
+ Client.VBD.eject rpc session_id cd
+ in
+ ignore(do_vm_op printer rpc session_id op params [])
let vm_cd_insert printer rpc session_id params =
- let cd_name = List.assoc "cd-name" params in
- let vdis =
- Client.VDI.get_by_name_label rpc session_id cd_name in
- let vdis = List.filter (fun vdi -> let sr = Client.VDI.get_SR rpc session_id vdi in "iso"=Client.SR.get_content_type rpc session_id sr) vdis in
- (if List.length vdis = 0 then (failwith ("CD "^cd_name^" not found")));
- (if List.length vdis > 1 then (failwith ("Multiple CDs named "^cd_name^" found. Please use vbd-insert and specify uuids")));
- let op vm =
- let vm_record = vm.record () in
- let vbds = vm_record.API.vM_VBDs in
- let cdvbds = List.filter (fun vbd -> (Client.VBD.get_type rpc session_id vbd = `CD) && (Client.VBD.get_empty rpc session_id vbd)) vbds in
- if List.length cdvbds = 0 then (failwith "No empty CD devices found");
- if List.length cdvbds > 1 then (failwith "Two or more empty CD devices found. Please use vbd-insert");
- let cd = List.hd cdvbds in
- Client.VBD.insert rpc session_id cd (List.hd vdis)
- in
- ignore(do_vm_op printer rpc session_id op params ["cd-name"])
+ let cd_name = List.assoc "cd-name" params in
+ let vdis =
+ Client.VDI.get_by_name_label rpc session_id cd_name in
+ let vdis = List.filter (fun vdi -> let sr = Client.VDI.get_SR rpc session_id vdi in "iso"=Client.SR.get_content_type rpc session_id sr) vdis in
+ (if List.length vdis = 0 then (failwith ("CD "^cd_name^" not found")));
+ (if List.length vdis > 1 then (failwith ("Multiple CDs named "^cd_name^" found. Please use vbd-insert and specify uuids")));
+ let op vm =
+ let vm_record = vm.record () in
+ let vbds = vm_record.API.vM_VBDs in
+ let cdvbds = List.filter (fun vbd -> (Client.VBD.get_type rpc session_id vbd = `CD) && (Client.VBD.get_empty rpc session_id vbd)) vbds in
+ if List.length cdvbds = 0 then (failwith "No empty CD devices found");
+ if List.length cdvbds > 1 then (failwith "Two or more empty CD devices found. Please use vbd-insert");
+ let cd = List.hd cdvbds in
+ Client.VBD.insert rpc session_id cd (List.hd vdis)
+ in
+ ignore(do_vm_op printer rpc session_id op params ["cd-name"])
let host_forget fd printer rpc session_id params =
- let uuid = List.assoc "uuid" params in
- let host = Client.Host.get_by_uuid rpc session_id uuid in
- let pool = List.hd (Client.Pool.get_all rpc session_id) in
- let _ (* unused variable 'pool_master' *) = Client.Pool.get_master rpc session_id pool in
- (* if pool_master = host then failwith "Cannot forget pool master"; *)
-
- let force = get_bool_param params "force" in
-
- let go () = ignore (Client.Host.destroy rpc session_id host) in
-
- if force
- then go ()
- else begin
- (* Best-effort attempt to warn the user *)
- marshal fd (Command (Print "WARNING: A host should only be forgotten if it is physically unrecoverable;"));
- marshal fd (Command (Print "WARNING: if possible, Hosts should be 'ejected' from the Pool instead."));
- marshal fd (Command (Print "WARNING: Once a host has been forgotten it will have to be re-installed."));
- marshal fd (Command (Print "WARNING: This operation is irreversible."));
- if user_says_yes fd
- then go ()
- end
+ let uuid = List.assoc "uuid" params in
+ let host = Client.Host.get_by_uuid rpc session_id uuid in
+ let pool = List.hd (Client.Pool.get_all rpc session_id) in
+ let _ (* unused variable 'pool_master' *) = Client.Pool.get_master rpc session_id pool in
+ (* if pool_master = host then failwith "Cannot forget pool master"; *)
+
+ let force = get_bool_param params "force" in
+
+ let go () = ignore (Client.Host.destroy rpc session_id host) in
+
+ if force
+ then go ()
+ else begin
+ (* Best-effort attempt to warn the user *)
+ marshal fd (Command (Print "WARNING: A host should only be forgotten if it is physically unrecoverable;"));
+ marshal fd (Command (Print "WARNING: if possible, Hosts should be 'ejected' from the Pool instead."));
+ marshal fd (Command (Print "WARNING: Once a host has been forgotten it will have to be re-installed."));
+ marshal fd (Command (Print "WARNING: This operation is irreversible."));
+ if user_says_yes fd
+ then go ()
+ end
let host_license_add fd printer rpc session_id params =
- let host =
- if List.mem_assoc "host-uuid" params then
- Client.Host.get_by_uuid rpc session_id (List.assoc "host-uuid" params)
- else
- get_host_from_session rpc session_id in
- let license_file = List.assoc "license-file" params in
- match get_client_file fd license_file with
- | Some license ->
- debug "Checking license [%s]" license;
- Client.Host.license_apply rpc session_id host (Base64.encode license);
- marshal fd (Command (Print "License applied."))
- | None ->
- marshal fd (Command (PrintStderr "Failed to read license file"));
- raise (ExitWithError 1)
+ let host =
+ if List.mem_assoc "host-uuid" params then
+ Client.Host.get_by_uuid rpc session_id (List.assoc "host-uuid" params)
+ else
+ get_host_from_session rpc session_id in
+ let license_file = List.assoc "license-file" params in
+ match get_client_file fd license_file with
+ | Some license ->
+ debug "Checking license [%s]" license;
+ Client.Host.license_apply rpc session_id host (Base64.encode license);
+ marshal fd (Command (Print "License applied."))
+ | None ->
+ marshal fd (Command (PrintStderr "Failed to read license file"));
+ raise (ExitWithError 1)
let host_license_view printer rpc session_id params =
- let host =
- if List.mem_assoc "host-uuid" params then
- Client.Host.get_by_uuid rpc session_id (List.assoc "host-uuid" params)
- else
- get_host_from_session rpc session_id in
- let params = Client.Host.get_license_params rpc session_id host in
- (* CA-26992 hide 'sockets' and 'sku_type' *)
- let tohide = [ "sockets"; "sku_type" ] in
- let params = List.filter (fun (x, _) -> not (List.mem x tohide)) params in
- printer (Cli_printer.PTable [params])
+ let host =
+ if List.mem_assoc "host-uuid" params then
+ Client.Host.get_by_uuid rpc session_id (List.assoc "host-uuid" params)
+ else
+ get_host_from_session rpc session_id in
+ let params = Client.Host.get_license_params rpc session_id host in
+ (* CA-26992 hide 'sockets' and 'sku_type' *)
+ let tohide = [ "sockets"; "sku_type" ] in
+ let params = List.filter (fun (x, _) -> not (List.mem x tohide)) params in
+ printer (Cli_printer.PTable [params])
let host_apply_edition printer rpc session_id params =
- let host =
- if List.mem_assoc "host-uuid" params then
- Client.Host.get_by_uuid rpc session_id (List.assoc "host-uuid" params)
- else
- get_host_from_session rpc session_id in
- let edition = List.assoc "edition" params in
- if List.mem_assoc "license-server-address" params then begin
- let address = List.assoc "license-server-address" params in
- Client.Host.remove_from_license_server rpc session_id host "address";
- Client.Host.add_to_license_server rpc session_id host "address" address
- end;
- if List.mem_assoc "license-server-port" params then begin
- let port = List.assoc "license-server-port" params in
- let port_int = try int_of_string port with _ -> -1 in
- if port_int < 0 || port_int > 65535 then
- printer (Cli_printer.PStderr "NOTE: The given port number is invalid; reverting to the current value.")
- else begin
- Client.Host.remove_from_license_server rpc session_id host "port";
- Client.Host.add_to_license_server rpc session_id host "port" port
- end
- end;
- let now = (Unix.gettimeofday ()) in
- try
- Client.Host.apply_edition rpc session_id host edition
- with
- | Api_errors.Server_error (name, args) when name = Api_errors.license_checkout_error ->
- let alerts = Client.Message.get_since rpc session_id (Date.of_float now) in
- let print_if_checkout_error (ref, msg) =
- if msg.API.message_name = "LICENSE_NOT_AVAILABLE" || msg.API.message_name = "LICENSE_SERVER_UNREACHABLE" then
- (* the body of the alert message is specified in the v6 daemon *)
- printer (Cli_printer.PStderr msg.API.message_body)
- in
- if alerts = [] then
- printer (Cli_printer.PStderr "Internal error: the licensing daemon was not found.")
- else
- List.iter print_if_checkout_error alerts;
- raise (ExitWithError 1)
- | e -> raise e
+ let host =
+ if List.mem_assoc "host-uuid" params then
+ Client.Host.get_by_uuid rpc session_id (List.assoc "host-uuid" params)
+ else
+ get_host_from_session rpc session_id in
+ let edition = List.assoc "edition" params in
+ if List.mem_assoc "license-server-address" params then begin
+ let address = List.assoc "license-server-address" params in
+ Client.Host.remove_from_license_server rpc session_id host "address";
+ Client.Host.add_to_license_server rpc session_id host "address" address
+ end;
+ if List.mem_assoc "license-server-port" params then begin
+ let port = List.assoc "license-server-port" params in
+ let port_int = try int_of_string port with _ -> -1 in
+ if port_int < 0 || port_int > 65535 then
+ printer (Cli_printer.PStderr "NOTE: The given port number is invalid; reverting to the current value.")
+ else begin
+ Client.Host.remove_from_license_server rpc session_id host "port";
+ Client.Host.add_to_license_server rpc session_id host "port" port
+ end
+ end;
+ let now = (Unix.gettimeofday ()) in
+ try
+ Client.Host.apply_edition rpc session_id host edition
+ with
+ | Api_errors.Server_error (name, args) when name = Api_errors.license_checkout_error ->
+ let alerts = Client.Message.get_since rpc session_id (Date.of_float now) in
+ let print_if_checkout_error (ref, msg) =
+ if msg.API.message_name = "LICENSE_NOT_AVAILABLE" || msg.API.message_name = "LICENSE_SERVER_UNREACHABLE" then
+ (* the body of the alert message is specified in the v6 daemon *)
+ printer (Cli_printer.PStderr msg.API.message_body)
+ in
+ if alerts = [] then
+ printer (Cli_printer.PStderr "Internal error: the licensing daemon was not found.")
+ else
+ List.iter print_if_checkout_error alerts;
+ raise (ExitWithError 1)
+ | e -> raise e
let host_evacuate printer rpc session_id params =
- let uuid = List.assoc "uuid" params in
- let host = Client.Host.get_by_uuid rpc session_id uuid in
- ignore (Client.Host.evacuate rpc session_id host)
+ let uuid = List.assoc "uuid" params in
+ let host = Client.Host.get_by_uuid rpc session_id uuid in
+ ignore (Client.Host.evacuate rpc session_id host)
let host_get_vms_which_prevent_evacuation printer rpc session_id params =
- let uuid = List.assoc "uuid" params in
- let host = Client.Host.get_by_uuid rpc session_id uuid in
- let vms = Client.Host.get_vms_which_prevent_evacuation rpc session_id host in
-
- let op (vm, error) =
- let error = String.concat "," error in
- let record = vm_record rpc session_id vm in
- let extra_field = make_field ~name:"reason" ~get:(fun () -> error) () in
- let record = { record with fields = record.fields @ [ extra_field ] } in
- let selected = List.hd (select_fields params [record] [ "uuid"; "name-label"; "reason"]) in
- let table = List.map print_field selected in
- printer (Cli_printer.PTable [table])
- in
- ignore(List.iter op vms)
+ let uuid = List.assoc "uuid" params in
+ let host = Client.Host.get_by_uuid rpc session_id uuid in
+ let vms = Client.Host.get_vms_which_prevent_evacuation rpc session_id host in
+
+ let op (vm, error) =
+ let error = String.concat "," error in
+ let record = vm_record rpc session_id vm in
+ let extra_field = make_field ~name:"reason" ~get:(fun () -> error) () in
+ let record = { record with fields = record.fields @ [ extra_field ] } in
+ let selected = List.hd (select_fields params [record] [ "uuid"; "name-label"; "reason"]) in
+ let table = List.map print_field selected in
+ printer (Cli_printer.PTable [table])
+ in
+ ignore(List.iter op vms)
let host_get_uncooperative_vms printer rpc session_id params =
- let uuid = List.assoc "uuid" params in
- let host = Client.Host.get_by_uuid rpc session_id uuid in
- let vms = Client.Host.get_uncooperative_resident_VMs rpc session_id host in
- let table = List.map (fun vm ->
- Client.VM.get_uuid rpc session_id vm, Client.VM.get_name_label rpc session_id vm
- ) vms in
- printer (Cli_printer.PTable [ table ])
+ let uuid = List.assoc "uuid" params in
+ let host = Client.Host.get_by_uuid rpc session_id uuid in
+ let vms = Client.Host.get_uncooperative_resident_VMs rpc session_id host in
+ let table = List.map (fun vm ->
+ Client.VM.get_uuid rpc session_id vm, Client.VM.get_name_label rpc session_id vm
+ ) vms in
+ printer (Cli_printer.PTable [ table ])
let host_retrieve_wlb_evacuate_recommendations printer rpc session_id params =
- let uuid = List.assoc "uuid" params in
- let host = Client.Host.get_by_uuid rpc session_id uuid in
- let vms = Client.Host.retrieve_wlb_evacuate_recommendations rpc session_id host in
- let table = List.map (fun (vm, result) ->
- Printf.sprintf "%s (%s)" (Client.VM.get_uuid rpc session_id vm) (Client.VM.get_name_label rpc session_id vm),
- String.concat " " result) vms in
- printer (Cli_printer.PTable [ ("VM", "[Host, RecID] / Error") :: table ])
+ let uuid = List.assoc "uuid" params in
+ let host = Client.Host.get_by_uuid rpc session_id uuid in
+ let vms = Client.Host.retrieve_wlb_evacuate_recommendations rpc session_id host in
+ let table = List.map (fun (vm, result) ->
+ Printf.sprintf "%s (%s)" (Client.VM.get_uuid rpc session_id vm) (Client.VM.get_name_label rpc session_id vm),
+ String.concat " " result) vms in
+ printer (Cli_printer.PTable [ ("VM", "[Host, RecID] / Error") :: table ])
let host_shutdown_agent printer rpc session_id params =
- ignore(Client.Host.shutdown_agent rpc session_id)
+ ignore(Client.Host.shutdown_agent rpc session_id)
let vdi_import fd printer rpc session_id params =
- let filename = List.assoc "filename" params in
- let vdi = Client.VDI.get_by_uuid rpc session_id (List.assoc "uuid" params) in
- let make_command task_id =
- let uri = Printf.sprintf "%s?session_id=%s&task_id=%s&vdi=%s"
- Constants.import_raw_vdi_uri (Ref.string_of session_id)
- (Ref.string_of task_id) (Ref.string_of vdi) in
- debug "requesting HttpPut('%s','%s')" filename uri;
- HttpPut (filename, uri) in
- ignore(track_http_operation fd rpc session_id make_command "VDI import")
+ let filename = List.assoc "filename" params in
+ let vdi = Client.VDI.get_by_uuid rpc session_id (List.assoc "uuid" params) in
+ let make_command task_id =
+ let uri = Printf.sprintf "%s?session_id=%s&task_id=%s&vdi=%s"
+ Constants.import_raw_vdi_uri (Ref.string_of session_id)
+ (Ref.string_of task_id) (Ref.string_of vdi) in
+ debug "requesting HttpPut('%s','%s')" filename uri;
+ HttpPut (filename, uri) in
+ ignore(track_http_operation fd rpc session_id make_command "VDI import")
let wait_for_task_complete rpc session_id task_id =
- let finished () =
- match (Client.Task.get_status rpc session_id task_id) with
- `success | `failure | `cancelled -> true
- | _ -> false in
- (* All successes and failures are communicated via the task object *)
- while not (finished ()) do
- Thread.delay 1.0
- done
+ let finished () =
+ match (Client.Task.get_status rpc session_id task_id) with
+ `success | `failure | `cancelled -> true
+ | _ -> false in
+ (* All successes and failures are communicated via the task object *)
+ while not (finished ()) do
+ Thread.delay 1.0
+ done
let download_file ~__context rpc session_id task fd filename uri label =
- marshal fd (Command (HttpGet (filename, uri)));
- let ok =
- match unmarshal fd with
- | Response OK -> true
- | Response Failed ->
- (* Need to check whether the thin cli managed to contact the server
- or not. If not, we need to mark the task as failed *)
- if Client.Task.get_progress rpc session_id task < 0.0
- then Db_actions.DB_Action.Task.set_status ~__context ~self:task ~value:`failure;
- false
- | _ -> false
- in
- wait_for_task_complete rpc session_id task;
-
- (* Check the server status -- even if the client thinks it's ok, we need
- to check that the server does too. *)
- match Client.Task.get_status rpc session_id task with
- | `success ->
- if ok
- then
- (if filename <> "" then
- marshal fd (Command (Print (Printf.sprintf "%s succeeded" label))))
- else
- (marshal fd (Command (PrintStderr (Printf.sprintf "%s failed, unknown error." label)));
- raise (ExitWithError 1))
- | `failure ->
- let result = Client.Task.get_error_info rpc session_id task in
- if result = []
- then
- marshal fd (Command (PrintStderr (Printf.sprintf "%s failed, unknown error" label)))
- else
- raise (Api_errors.Server_error ((List.hd result),(List.tl result)))
- | `cancelled ->
- marshal fd (Command (PrintStderr (Printf.sprintf "%s cancelled" label)));
- raise (ExitWithError 1)
- | _ ->
- marshal fd (Command (PrintStderr "Internal error")); (* should never happen *)
- raise (ExitWithError 1)
+ marshal fd (Command (HttpGet (filename, uri)));
+ let ok =
+ match unmarshal fd with
+ | Response OK -> true
+ | Response Failed ->
+ (* Need to check whether the thin cli managed to contact the server
+ or not. If not, we need to mark the task as failed *)
+ if Client.Task.get_progress rpc session_id task < 0.0
+ then Db_actions.DB_Action.Task.set_status ~__context ~self:task ~value:`failure;
+ false
+ | _ -> false
+ in
+ wait_for_task_complete rpc session_id task;
+
+ (* Check the server status -- even if the client thinks it's ok, we need
+ to check that the server does too. *)
+ match Client.Task.get_status rpc session_id task with
+ | `success ->
+ if ok
+ then
+ (if filename <> "" then
+ marshal fd (Command (Print (Printf.sprintf "%s succeeded" label))))
+ else
+ (marshal fd (Command (PrintStderr (Printf.sprintf "%s failed, unknown error." label)));
+ raise (ExitWithError 1))
+ | `failure ->
+ let result = Client.Task.get_error_info rpc session_id task in
+ if result = []
+ then
+ marshal fd (Command (PrintStderr (Printf.sprintf "%s failed, unknown error" label)))
+ else
+ raise (Api_errors.Server_error ((List.hd result),(List.tl result)))
+ | `cancelled ->
+ marshal fd (Command (PrintStderr (Printf.sprintf "%s cancelled" label)));
+ raise (ExitWithError 1)
+ | _ ->
+ marshal fd (Command (PrintStderr "Internal error")); (* should never happen *)
+ raise (ExitWithError 1)
let download_file_with_task fd rpc session_id filename uri query label
- task_name =
- let task = Client.Task.create rpc session_id task_name "" in
-
- (* Initially mark the task progress as -1.0. The first thing the HTTP handler does it to mark it as zero *)
- (* This is used as a flag to show that the 'ownership' of the task has been passed to the handler, and it's *)
- (* not our responsibility any more to mark the task as completed/failed/etc. *)
- let __context = Context.make task_name in
- Db_actions.DB_Action.Task.set_progress ~__context ~self:task ~value:(-1.0);
- finally
- (fun () ->
- download_file ~__context rpc session_id task fd filename
- (Printf.sprintf "%s?session_id=%s&task_id=%s%s%s" uri
- (Ref.string_of session_id)
- (Ref.string_of task)
- (if query = "" then "" else "&")
- query)
- label)
- (fun () -> Client.Task.destroy rpc session_id task)
+ task_name =
+ let task = Client.Task.create rpc session_id task_name "" in
+
+ (* Initially mark the task progress as -1.0. The first thing the HTTP handler does it to mark it as zero *)
+ (* This is used as a flag to show that the 'ownership' of the task has been passed to the handler, and it's *)
+ (* not our responsibility any more to mark the task as completed/failed/etc. *)
+ let __context = Context.make task_name in
+ Db_actions.DB_Action.Task.set_progress ~__context ~self:task ~value:(-1.0);
+ finally
+ (fun () ->
+ download_file ~__context rpc session_id task fd filename
+ (Printf.sprintf "%s?session_id=%s&task_id=%s%s%s" uri
+ (Ref.string_of session_id)
+ (Ref.string_of task)
+ (if query = "" then "" else "&")
+ query)
+ label)
+ (fun () -> Client.Task.destroy rpc session_id task)
let pool_retrieve_wlb_report fd printer rpc session_id params =
- let report = List.assoc "report" params in
- let filename = List.assoc_default "filename" params "" in
- let other_params =
- List.filter
- (fun (k, _) -> not (List.mem k (["report"; "filename"] @ stdparams)))
- params
- in
- download_file_with_task fd rpc session_id filename
- Constants.wlb_report_uri
- (Printf.sprintf
- "report=%s%s%s"
- (Http.urlencode report)
- (if List.length other_params = 0 then "" else "&")
- (String.concat "&"
- (List.map (fun (k, v) ->
- (Printf.sprintf "%s=%s"
- (Http.urlencode k)
- (Http.urlencode v))) other_params)))
- "Report generation"
- (Printf.sprintf "WLB report: %s" report)
+ let report = List.assoc "report" params in
+ let filename = List.assoc_default "filename" params "" in
+ let other_params =
+ List.filter
+ (fun (k, _) -> not (List.mem k (["report"; "filename"] @ stdparams)))
+ params
+ in
+ download_file_with_task fd rpc session_id filename
+ Constants.wlb_report_uri
+ (Printf.sprintf
+ "report=%s%s%s"
+ (Http.urlencode report)
+ (if List.length other_params = 0 then "" else "&")
+ (String.concat "&"
+ (List.map (fun (k, v) ->
+ (Printf.sprintf "%s=%s"
+ (Http.urlencode k)
+ (Http.urlencode v))) other_params)))
+ "Report generation"
+ (Printf.sprintf "WLB report: %s" report)
let pool_retrieve_wlb_diagnostics fd printer rpc session_id params =
- let filename = List.assoc_default "filename" params "" in
- download_file_with_task fd rpc session_id filename
- Constants.wlb_diagnostics_uri ""
- "WLB diagnostics download"
- "WLB diagnostics download"
+ let filename = List.assoc_default "filename" params "" in
+ download_file_with_task fd rpc session_id filename
+ Constants.wlb_diagnostics_uri ""
+ "WLB diagnostics download"
+ "WLB diagnostics download"
let vm_import fd printer rpc session_id params =
- let filename = List.assoc "filename" params in
- let full_restore = get_bool_param params "preserve" in
- let vm_metadata_only = get_bool_param params "metadata" in
- let force = get_bool_param params "force" in
- let sr =
- if List.mem_assoc "sr-uuid" params
- then Client.SR.get_by_uuid rpc session_id (List.assoc "sr-uuid" params)
- else
- match Cli_util.get_default_sr_uuid rpc session_id with
- | Some uuid -> Client.SR.get_by_uuid rpc session_id uuid
- | None -> raise (Cli_util.Cli_failure "No SR specified and Pool default SR is null")
- in
- (* Special-case where the user accidentally sets filename=<path to ova.xml file> *)
- let filename =
- if String.endswith "ova.xml" (String.lowercase filename)
- then String.sub filename 0 (String.length filename - (String.length "ova.xml"))
- else filename in
-
- marshal fd (Command (Load (filename ^ "/ova.xml")));
- match unmarshal fd with
- | Response OK ->
- debug "Looking like a Zurich/Geneva XVA";
- (* Zurich/Geneva style XVA import *)
- (* If a task was passed in, use that - else create a new one. UI uses "task_id" to pass reference [UI uses ThinCLI for Geneva import];
- xe now allows task-uuid on cmd-line *)
- let using_existing_task = (List.mem_assoc "task_id" params) || (List.mem_assoc "task-uuid" params) in
- let importtask =
- if List.mem_assoc "task_id" params
- then (Ref.of_string (List.assoc "task_id" params))
- else if List.mem_assoc "task-uuid" params then Client.Task.get_by_uuid rpc session_id (List.assoc "task-uuid" params)
- else Client.Task.create rpc session_id "Import of Zurich/Geneva style XVA" ""
- in
-
- (* Initially mark the task progress as -1.0. The first thing the import handler does it to mark it as zero *)
- (* This is used as a flag to show that the 'ownership' of the task has been passed to the handler, and it's *)
- (* not our responsibility any more to mark the task as completed/failed/etc. *)
- let __context = Context.make "import" in
- Db_actions.DB_Action.Task.set_progress ~__context ~self:importtask ~value:(-1.0);
-
- Pervasiveext.finally (fun () ->
- begin
- let buffer = get_chunks fd in
- begin
- try
- let vm, vdis = Xva.of_xml (Xml.parse_string buffer) in
- (* Only import the first VM *)
- let vm = List.hd vm in
- let disks = List.sort compare (List.map (fun x -> x.Xva.device) vm.Xva.vbds) in
- let host =
- if sr<>Ref.null
- then Importexport.find_host_for_sr ~__context sr
- else Helpers.get_localhost ()
- in
- let address = Client.Host.get_address rpc session_id host in
- (* Although it's inefficient use a loopback HTTP connection *)
- debug "address is: %s" address;
- let headers = Xapi_http.http_request
- ~cookie:(["session_id", Ref.string_of session_id;
- "task_id", Ref.string_of importtask] @
- (if sr <> Ref.null then [ "sr_id", Ref.string_of sr ] else []))
- Http.Put address Constants.import_uri in
- (* Stream the disk data from the client *)
- let writer _ task_id sock =
- try
- (* First add the metadata file *)
- let hdr = Tar.Header.make Xva.xml_filename (Int64.of_int (String.length buffer)) in
- Tar.write_block hdr (fun ofd -> Tar.write_string ofd buffer) sock;
- List.iter
- (fun vdi ->
- let counter = ref 0 in
- let finished = ref false in
- while not(!finished) do
-(* Nb.
- * The check for task cancelling is done here in the cli server. This is due to the fact that we've got
- * 3 parties talking to one another here: the thin cli, the cli server and the import handler. If the
- * import handler was checking, it would close its socket on task cancelling. This only happens after
- * each chunk is sent. Unfortunately the cli server wouldn't notice until it had already requested the
- * data from the thin cli, and would have to wait for it to finish sending its chunk before it could
- * alert it to the failure. *)
-
- (let l=Client.Task.get_current_operations rpc session_id importtask in
- if List.exists (fun (_,x) -> x=`cancel) l then raise (Api_errors.Server_error(Api_errors.task_cancelled,[])));
-
-(* Cancelling will close the connection, which will be interpreted by the import handler as failure *)
-
- let chunk = Printf.sprintf "%s/chunk-%09d.gz" vdi !counter in
- marshal fd (Command (Load (filename ^ "/" ^ chunk)));
- match unmarshal fd with
- | Response OK ->
- (* A single chunk always follows the OK *)
- let length = match unmarshal fd with
- | Blob (Chunk x) -> x
- | _ -> failwith "Thin CLI protocol error"
- in
- let hdr = Tar.Header.make chunk (Int64.of_int32 length) in
- Tar.write_block hdr
- (fun ofd ->
- let limit = Int64.of_int32 length in
- let total_bytes = Unixext.copy_file ~limit fd ofd in
- debug "File %s has size %Ld; we received %Ld%s" chunk limit total_bytes
- (if limit = total_bytes then "" else " ** truncated **")
- )
- sock;
- (match unmarshal fd with | Blob End -> () | _ -> (failwith "Thin CLI protocol error"));
- incr counter
- | Response Failed ->
- finished := true
- | m ->
- debug "Protocol failure: unexpected: %s" (string_of_message m)
- done) disks;
- Tar.write_end sock;
- true
- with e ->
- debug "vm_import caught %s while writing data" (Printexc.to_string e);
- false
- in
-
- let stream_ok = Xmlrpcclient.do_secure_http_rpc ~use_stunnel_cache:true
- ~task_id:(Ref.string_of (Context.get_task_id __context))
- ~host:address ~port:Xapi_globs.default_ssl_port ~headers ~body:"" writer in
- debug "VM import in final stage; have to wait for the task to complete";
-
- if not stream_ok
- then
- begin
- (* If the progress is negative, we never got to talk to the import handler, and must complete *)
- (* the task ourselves *)
- if Client.Task.get_progress rpc session_id importtask < 0.0
- then Db_actions.DB_Action.Task.set_status ~__context ~self:importtask ~value:`failure;
- end;
-
- wait_for_task_complete rpc session_id importtask;
- (match Client.Task.get_status rpc session_id importtask with
- | `success ->
- if stream_ok then
- let result = Client.Task.get_result rpc session_id importtask in
- let vmrefs = API.From.ref_VM_set "" (Xml.parse_string result) in
- let uuids = List.map (fun vm -> Client.VM.get_uuid rpc session_id vm) vmrefs in
- marshal fd (Command (Print (String.concat "," uuids)))
- else
- begin
- marshal fd (Command (PrintStderr "Warning: Streaming failed, but task succeeded. Manual check required."));
- raise (ExitWithError 1)
- end
- | `failure ->
- let result = Client.Task.get_error_info rpc session_id importtask in
- if result = []
- then
- begin
- marshal fd (Command (PrintStderr "Import failed, unknown error"));
- raise (ExitWithError 1)
- end
- else Cli_util.server_error (List.hd result) (List.tl result) fd
- | `cancelled ->
- marshal fd (Command (PrintStderr "Import cancelled"));
- raise (ExitWithError 1)
- | _ ->
- marshal fd (Command (PrintStderr "Internal error")); (* should never happen *)
- raise (ExitWithError 1))
- with e ->
- marshal fd (Command (Debug ("Caught exception: " ^ (Printexc.to_string e))));
- marshal fd (Command (PrintStderr "Failed to import directory-format XVA"));
- debug "Import failed with exception: %s" (Printexc.to_string e);
- (if (Db_actions.DB_Action.Task.get_progress ~__context ~self:importtask = (-1.0))
- then TaskHelper.failed ~__context:(Context.from_forwarded_task importtask) (Api_errors.import_error_generic,[(Printexc.to_string e)])
- );
- raise (ExitWithError 2)
- end
- end)
- (fun () ->
- if using_existing_task then () else Client.Task.destroy rpc session_id importtask)
- | Response Failed ->
- (* possibly a Rio import *)
- let make_command task_id =
- let uri = Printf.sprintf "%s?session_id=%s&task_id=%s&restore=%s&force=%s%s"
- (if vm_metadata_only then Constants.import_metadata_uri else Constants.import_uri)
- (Ref.string_of session_id) (Ref.string_of task_id)
- (if full_restore then "true" else "false")
- (if force then "true" else "false")
- (if sr <> Ref.null then "&sr_id=" ^ (Ref.string_of sr) else "") in
- debug "requesting HttpPut('%s','%s')" filename uri;
- HttpPut (filename, uri) in
- let importtask =
- if List.mem_assoc "task-uuid" params then
- Some (Client.Task.get_by_uuid rpc session_id (List.assoc "task-uuid" params))
- else None (* track_http_operation will create one for us *) in
- let result = track_http_operation ?use_existing_task:importtask fd rpc session_id make_command "VM import" in
- let vmrefs = API.From.ref_VM_set "" (Xml.parse_string result) in
- let uuids = List.map (fun vm -> Client.VM.get_uuid rpc session_id vm) vmrefs in
- marshal fd (Command (Print (String.concat "," uuids)))
- | _ -> failwith "Thin CLI protocol error"
+ let filename = List.assoc "filename" params in
+ let full_restore = get_bool_param params "preserve" in
+ let vm_metadata_only = get_bool_param params "metadata" in
+ let force = get_bool_param params "force" in
+ let sr =
+ if List.mem_assoc "sr-uuid" params
+ then Client.SR.get_by_uuid rpc session_id (List.assoc "sr-uuid" params)
+ else
+ match Cli_util.get_default_sr_uuid rpc session_id with
+ | Some uuid -> Client.SR.get_by_uuid rpc session_id uuid
+ | None -> raise (Cli_util.Cli_failure "No SR specified and Pool default SR is null")
+ in
+
(* Special-case where the user accidentally sets filename=<path to ova.xml file> *)
+ let filename =
+ if String.endswith "ova.xml" (String.lowercase filename)
+ then String.sub filename 0 (String.length filename - (String.length "ova.xml"))
+ else filename in
+
+ marshal fd (Command (Load (filename ^ "/ova.xml")));
+ match unmarshal fd with
+ | Response OK ->
+ debug "Looking like a Zurich/Geneva XVA";
+ (* Zurich/Geneva style XVA import *)
+ (* If a task was passed in, use that - else create a new one. UI uses "task_id" to pass reference [UI uses ThinCLI for Geneva import];
+ xe now allows task-uuid on cmd-line *)
+ let using_existing_task = (List.mem_assoc "task_id" params) || (List.mem_assoc "task-uuid" params) in
+ let importtask =
+ if List.mem_assoc "task_id" params
+ then (Ref.of_string (List.assoc "task_id" params))
+ else if List.mem_assoc "task-uuid" params then Client.Task.get_by_uuid rpc session_id (List.assoc "task-uuid" params)
+ else Client.Task.create rpc session_id "Import of Zurich/Geneva style XVA" ""
+ in
+
+ (* Initially mark the task progress as -1.0. The first thing the import handler does it to mark it as zero *)
+ (* This is used as a flag to show that the 'ownership' of the task has been passed to the handler, and it's *)
+ (* not our responsibility any more to mark the task as completed/failed/etc. *)
+ let __context = Context.make "import" in
+ Db_actions.DB_Action.Task.set_progress ~__context ~self:importtask ~value:(-1.0);
+
+ Pervasiveext.finally (fun () ->
+ begin
+ let buffer = get_chunks fd in
+ begin
+ try
+ let vm, vdis = Xva.of_xml (Xml.parse_string buffer) in
+ (* Only import the first VM *)
+ let vm = List.hd vm in
+ let disks = List.sort compare (List.map (fun x -> x.Xva.device) vm.Xva.vbds) in
+ let host =
+ if sr<>Ref.null
+ then Importexport.find_host_for_sr ~__context sr
+ else Helpers.get_localhost ()
+ in
+ let address = Client.Host.get_address rpc session_id host in
+ (* Although it's inefficient use a loopback HTTP connection *)
+ debug "address is: %s" address;
+ let headers = Xapi_http.http_request
+ ~cookie:(["session_id", Ref.string_of session_id;
+ "task_id", Ref.string_of importtask] @
+ (if sr <> Ref.null then [ "sr_id", Ref.string_of sr ] else []))
+ Http.Put address Constants.import_uri in
+ (* Stream the disk data from the client *)
+ let writer _ task_id sock =
+ try
+ (* First add the metadata file *)
+ let hdr = Tar.Header.make Xva.xml_filename (Int64.of_int (String.length buffer)) in
+ Tar.write_block hdr (fun ofd -> Tar.write_string ofd buffer) sock;
+ List.iter
+ (fun vdi ->
+ let counter = ref 0 in
+ let finished = ref false in
+ while not(!finished) do
+ (* Nb.
+ * The check for task cancelling is done here in the cli server. This is due to the fact that we've got
+ * 3 parties talking to one another here: the thin cli, the cli server and the import handler. If the
+ * import handler was checking, it would close its socket on task cancelling. This only happens after
+ * each chunk is sent. Unfortunately the cli server wouldn't notice until it had already requested the
+ * data from the thin cli, and would have to wait for it to finish sending its chunk before it could
+ * alert it to the failure. *)
+
+ (let l=Client.Task.get_current_operations rpc session_id importtask in
+ if List.exists (fun (_,x) -> x=`cancel) l then raise (Api_errors.Server_error(Api_errors.task_cancelled,[])));
+
+ (* Cancelling will close the connection, which will be interpreted by the import handler as failure *)
+
+ let chunk = Printf.sprintf "%s/chunk-%09d.gz" vdi !counter in
+ marshal fd (Command (Load (filename ^ "/" ^ chunk)));
+ match unmarshal fd with
+ | Response OK ->
+ (* A single chunk always follows the OK *)
+ let length = match unmarshal fd with
+ | Blob (Chunk x) -> x
+ | _ -> failwith "Thin CLI protocol error"
+ in
+ let hdr = Tar.Header.make chunk (Int64.of_int32 length) in
+ Tar.write_block hdr
+ (fun ofd ->
+ let limit = Int64.of_int32 length in
+ let total_bytes = Unixext.copy_file ~limit fd ofd in
+ debug "File %s has size %Ld; we received %Ld%s" chunk limit total_bytes
+ (if limit = total_bytes then "" else " ** truncated **")
+ )
+ sock;
+ (match unmarshal fd with | Blob End -> () | _ -> (failwith "Thin CLI protocol error"));
+ incr counter
+ | Response Failed ->
+ finished := true
+ | m ->
+ debug "Protocol failure: unexpected: %s" (string_of_message m)
+ done) disks;
+ Tar.write_end sock;
+ true
+ with e ->
+ debug "vm_import caught %s while writing data" (Printexc.to_string e);
+ false
+ in
+
+ let stream_ok = Xmlrpcclient.do_secure_http_rpc ~use_stunnel_cache:true
+ ~task_id:(Ref.string_of (Context.get_task_id __context))
+ ~host:address ~port:Xapi_globs.default_ssl_port ~headers ~body:"" writer in
+ debug "VM import in final stage; have to wait for the task to complete";
+
+ if not stream_ok
+ then
+ begin
+ (* If the progress is negative, we never got to talk to the import handler, and must complete *)
+ (* the task ourselves *)
+ if Client.Task.get_progress rpc session_id importtask < 0.0
+ then Db_actions.DB_Action.Task.set_status ~__context ~self:importtask ~value:`failure;
+ end;
+
+ wait_for_task_complete rpc session_id importtask;
+ (match Client.Task.get_status rpc session_id importtask with
+ | `success ->
+ if stream_ok then
+ let result = Client.Task.get_result rpc session_id importtask in
+ let vmrefs = API.From.ref_VM_set "" (Xml.parse_string result) in
+ let uuids = List.map (fun vm -> Client.VM.get_uuid rpc session_id vm) vmrefs in
+ marshal fd (Command (Print (String.concat "," uuids)))
+ else
+ begin
+ marshal fd (Command (PrintStderr "Warning: Streaming failed, but task succeeded. Manual check required."));
+ raise (ExitWithError 1)
+ end
+ | `failure ->
+ let result = Client.Task.get_error_info rpc session_id importtask in
+ if result = []
+ then
+ begin
+ marshal fd (Command (PrintStderr "Import failed, unknown error"));
+ raise (ExitWithError 1)
+ end
+ else Cli_util.server_error (List.hd result) (List.tl result) fd
+ | `cancelled ->
+ marshal fd (Command (PrintStderr "Import cancelled"));
+ raise (ExitWithError 1)
+ | _ ->
+ marshal fd (Command (PrintStderr "Internal error")); (* should never happen *)
+ raise (ExitWithError 1))
+ with e ->
+ marshal fd (Command (Debug ("Caught exception: " ^ (Printexc.to_string e))));
+ marshal fd (Command (PrintStderr "Failed to import directory-format XVA"));
+ debug "Import failed with exception: %s" (Printexc.to_string e);
+ (if (Db_actions.DB_Action.Task.get_progress ~__context ~self:importtask = (-1.0))
+ then TaskHelper.failed ~__context:(Context.from_forwarded_task importtask) (Api_errors.import_error_generic,[(Printexc.to_string e)])
+ );
+ raise (ExitWithError 2)
+ end
+ end)
+ (fun () ->
+ if using_existing_task then () else Client.Task.destroy rpc session_id importtask)
+ | Response Failed ->
+ (* possibly a Rio import *)
+ let make_command task_id =
+ let uri = Printf.sprintf "%s?session_id=%s&task_id=%s&restore=%s&force=%s%s"
+ (if vm_metadata_only then Constants.import_metadata_uri else Constants.import_uri)
+ (Ref.string_of session_id) (Ref.string_of task_id)
+ (if full_restore then "true" else "false")
+ (if force then "true" else "false")
+ (if sr <> Ref.null then "&sr_id=" ^ (Ref.string_of sr) else "") in
+ debug "requesting HttpPut('%s','%s')" filename uri;
+ HttpPut (filename, uri) in
+ let importtask =
+ if List.mem_assoc "task-uuid" params then
+ Some (Client.Task.get_by_uuid rpc session_id (List.assoc "task-uuid" params))
+ else None (* track_http_operation will create one for us *) in
+ let result = track_http_operation ?use_existing_task:importtask fd rpc session_id make_command "VM import" in
+ let vmrefs = API.From.ref_VM_set "" (Xml.parse_string result) in
+ let uuids = List.map (fun vm -> Client.VM.get_uuid rpc session_id vm) vmrefs in
+ marshal fd (Command (Print (String.concat "," uuids)))
+ | _ -> failwith "Thin CLI protocol error"
let blob_get fd printer rpc session_id params =
- let blob_uuid = List.assoc "uuid" params in
- let blob_ref = Client.Blob.get_by_uuid rpc session_id blob_uuid in
- let filename = List.assoc "filename" params in
- let __context = Context.make "import" in
- let blobtask = Client.Task.create rpc session_id (Printf.sprintf "Obtaining blob, ref=%s" (Ref.string_of blob_ref)) "" in
- Db_actions.DB_Action.Task.set_progress ~__context ~self:blobtask ~value:(-1.0);
-
- let bloburi = Printf.sprintf "%s?session_id=%s&task_id=%s&ref=%s"
- (Constants.blob_uri) (Ref.string_of session_id) (Ref.string_of blobtask) (Ref.string_of blob_ref)
- in
- finally
- (fun () ->
- marshal fd (Command (HttpGet (filename, bloburi)));
- let ok = match unmarshal fd with
- | Response OK -> true
- | Response Failed ->
- if Client.Task.get_progress rpc session_id blobtask < 0.0
- then Db_actions.DB_Action.Task.set_status ~__context ~self:blobtask ~value:`failure;
- false
- | _ -> false
- in
-
- wait_for_task_complete rpc session_id blobtask;
-
- (* if the client thinks it's ok, check that the server does too *)
- (match Client.Task.get_status rpc session_id blobtask with
- | `success ->
- if ok
- then (marshal fd (Command (Print "Blob get succeeded")))
- else (marshal fd (Command (PrintStderr "Blob get failed, unknown error."));
- raise (ExitWithError 1))
- | `failure ->
- let result = Client.Task.get_error_info rpc session_id blobtask in
- if result = []
- then marshal fd (Command (PrintStderr "Blob get failed, unknown error"))
- else raise (Api_errors.Server_error ((List.hd result),(List.tl result)))
- | `cancelled ->
- marshal fd (Command (PrintStderr "Blob get cancelled"));
- raise (ExitWithError 1)
- | _ ->
- marshal fd (Command (PrintStderr "Internal error")); (* should never happen *)
- raise (ExitWithError 1)
- ))
- (fun () -> Client.Task.destroy rpc session_id blobtask)
+ let blob_uuid = List.assoc "uuid" params in
+ let blob_ref = Client.Blob.get_by_uuid rpc session_id blob_uuid in
+ let filename = List.assoc "filename" params in
+ let __context = Context.make "import" in
+ let blobtask = Client.Task.create rpc session_id (Printf.sprintf "Obtaining blob, ref=%s" (Ref.string_of blob_ref)) "" in
+ Db_actions.DB_Action.Task.set_progress ~__context ~self:blobtask ~value:(-1.0);
+
+ let bloburi = Printf.sprintf "%s?session_id=%s&task_id=%s&ref=%s"
+ (Constants.blob_uri) (Ref.string_of session_id) (Ref.string_of blobtask) (Ref.string_of blob_ref)
+ in
+ finally
+ (fun () ->
+ marshal fd (Command (HttpGet (filename, bloburi)));
+ let ok = match unmarshal fd with
+ | Response OK -> true
+ | Response Failed ->
+ if Client.Task.get_progress rpc session_id blobtask < 0.0
+ then Db_actions.DB_Action.Task.set_status ~__context ~self:blobtask ~value:`failure;
+ false
+ | _ -> false
+ in
+
+ wait_for_task_complete rpc session_id blobtask;
+
+ (* if the client thinks it's ok, check that the server does too *)
+ (match Client.Task.get_status rpc session_id blobtask with
+ | `success ->
+ if ok
+ then (marshal fd (Command (Print "Blob get succeeded")))
+ else (marshal fd (Command (PrintStderr "Blob get failed, unknown error."));
+ raise (ExitWithError 1))
+ | `failure ->
+ let result = Client.Task.get_error_info rpc session_id blobtask in
+ if result = []
+ then marshal fd (Command (PrintStderr "Blob get failed, unknown error"))
+ else raise (Api_errors.Server_error ((List.hd result),(List.tl result)))
+ | `cancelled ->
+ marshal fd (Command (PrintStderr "Blob get cancelled"));
+ raise (ExitWithError 1)
+ | _ ->
+ marshal fd (Command (PrintStderr "Internal error")); (* should never happen *)
+ raise (ExitWithError 1)
+ ))
+ (fun () -> Client.Task.destroy rpc session_id blobtask)
let blob_put fd printer rpc session_id params =
- let blob_uuid = List.assoc "uuid" params in
- let blob_ref = Client.Blob.get_by_uuid rpc session_id blob_uuid in
- let filename = List.assoc "filename" params in
- let __context = Context.make "import" in
- let blobtask = Client.Task.create rpc session_id (Printf.sprintf "Blob PUT, ref=%s" (Ref.string_of blob_ref)) "" in
- Db_actions.DB_Action.Task.set_progress ~__context ~self:blobtask ~value:(-1.0);
-
- let bloburi = Printf.sprintf "%s?session_id=%s&task_id=%s&ref=%s"
- (Constants.blob_uri) (Ref.string_of session_id) (Ref.string_of blobtask) (Ref.string_of blob_ref)
- in
- finally
- (fun () ->
- marshal fd (Command (HttpPut (filename, bloburi)));
- let ok = match unmarshal fd with
- | Response OK -> true
- | Response Failed ->
- if Client.Task.get_progress rpc session_id blobtask < 0.0
- then Db_actions.DB_Action.Task.set_status ~__context ~self:blobtask ~value:`failure;
- false
- | _ -> false
- in
-
- wait_for_task_complete rpc session_id blobtask;
-
- (* if the client thinks it's ok, check that the server does too *)
- (match Client.Task.get_status rpc session_id blobtask with
- | `success ->
- if ok
- then (marshal fd (Command (Print "Blob put succeeded")))
- else (marshal fd (Command (PrintStderr "Blob put failed, unknown error."));
- raise (ExitWithError 1))
- | `failure ->
- let result = Client.Task.get_error_info rpc session_id blobtask in
- if result = []
- then marshal fd (Command (PrintStderr "Blob put failed, unknown error"))
- else raise (Api_errors.Server_error ((List.hd result),(List.tl result)))
- | `cancelled ->
- marshal fd (Command (PrintStderr "Blob put cancelled"));
- raise (ExitWithError 1)
- | _ ->
- marshal fd (Command (PrintStderr "Internal error")); (* should never happen *)
- raise (ExitWithError 1)
- ))
- (fun () -> Client.Task.destroy rpc session_id blobtask)
+ let blob_uuid = List.assoc "uuid" params in
+ let blob_ref = Client.Blob.get_by_uuid rpc session_id blob_uuid in
+ let filename = List.assoc "filename" params in
+ let __context = Context.make "import" in
+ let blobtask = Client.Task.create rpc session_id (Printf.sprintf "Blob PUT, ref=%s" (Ref.string_of blob_ref)) "" in
+ Db_actions.DB_Action.Task.set_progress ~__context ~self:blobtask ~value:(-1.0);
+
+ let bloburi = Printf.sprintf "%s?session_id=%s&task_id=%s&ref=%s"
+ (Constants.blob_uri) (Ref.string_of session_id) (Ref.string_of blobtask) (Ref.string_of blob_ref)
+ in
+ finally
+ (fun () ->
+ marshal fd (Command (HttpPut (filename, bloburi)));
+ let ok = match unmarshal fd with
+ | Response OK -> true
+ | Response Failed ->
+ if Client.Task.get_progress rpc session_id blobtask < 0.0
+ then Db_actions.DB_Action.Task.set_status ~__context ~self:blobtask ~value:`failure;
+ false
+ | _ -> false
+ in
+
+ wait_for_task_complete rpc session_id blobtask;
+
+ (* if the client thinks it's ok, check that the server does too *)
+ (match Client.Task.get_status rpc session_id blobtask with
+ | `success ->
+ if ok
+ then (marshal fd (Command (Print "Blob put succeeded")))
+ else (marshal fd (Command (PrintStderr "Blob put failed, unknown error."));
+ raise (ExitWithError 1))
+ | `failure ->
+ let result = Client.Task.get_error_info rpc session_id blobtask in
+ if result = []
+ then marshal fd (Command (PrintStderr "Blob put failed, unknown error"))
+ else raise (Api_errors.Server_error ((List.hd result),(List.tl result)))
+ | `cancelled ->
+ marshal fd (Command (PrintStderr "Blob put cancelled"));
+ raise (ExitWithError 1)
+ | _ ->
+ marshal fd (Command (PrintStderr "Internal error")); (* should never happen *)
+ raise (ExitWithError 1)
+ ))
+ (fun () -> Client.Task.destroy rpc session_id blobtask)
let blob_create printer rpc session_id params =
- let name = List.assoc "name" params in
- let mime_type = List.assoc_default "mime-type" params "" in
- if (List.mem_assoc "vm-uuid" params) then
- begin
- let uuid = List.assoc "vm-uuid" params in
- let vm = Client.VM.get_by_uuid rpc session_id uuid in
- let blob = Client.VM.create_new_blob rpc session_id vm name mime_type in
- let blob_uuid = Client.Blob.get_uuid rpc session_id blob in
- printer (Cli_printer.PList [blob_uuid])
- end
- else if (List.mem_assoc "pool-uuid" params) then
- begin
- let uuid = List.assoc "pool-uuid" params in
- let pool = Client.Pool.get_by_uuid rpc session_id uuid in
- let blob = Client.Pool.create_new_blob rpc session_id pool name mime_type in
- let blob_uuid = Client.Blob.get_uuid rpc session_id blob in
- printer (Cli_printer.PList [blob_uuid])
- end
- else if (List.mem_assoc "sr-uuid" params) then
- begin
- let uuid = List.assoc "sr-uuid" params in
- let sr = Client.SR.get_by_uuid rpc session_id uuid in
- let blob = Client.SR.create_new_blob rpc session_id sr name mime_type in
- let blob_uuid = Client.Blob.get_uuid rpc session_id blob in
- printer (Cli_printer.PList [blob_uuid])
- end
- else if (List.mem_assoc "host-uuid" params) then
- begin
- let uuid = List.assoc "host-uuid" params in
- let host = Client.Host.get_by_uuid rpc session_id uuid in
- let blob = Client.Host.create_new_blob rpc session_id host name mime_type in
- let blob_uuid = Client.Blob.get_uuid rpc session_id blob in
- printer (Cli_printer.PList [blob_uuid])
- end
- else if (List.mem_assoc "network-uuid" params) then
- begin
- let uuid = List.assoc "network-uuid" params in
- let network = Client.Network.get_by_uuid rpc session_id uuid in
- let blob = Client.Network.create_new_blob rpc session_id network name mime_type in
- let blob_uuid = Client.Blob.get_uuid rpc session_id blob in
- printer (Cli_printer.PList [blob_uuid])
- end
- else
- raise (Cli_util.Cli_failure "Need one of: vm-uuid, host-uuid, network-uuid, sr-uuid or pool-uuid")
+ let name = List.assoc "name" params in
+ let mime_type = List.assoc_default "mime-type" params "" in
+ if (List.mem_assoc "vm-uuid" params) then
+ begin
+ let uuid = List.assoc "vm-uuid" params in
+ let vm = Client.VM.get_by_uuid rpc session_id uuid in
+ let blob = Client.VM.create_new_blob rpc session_id vm name mime_type in
+ let blob_uuid = Client.Blob.get_uuid rpc session_id blob in
+ printer (Cli_printer.PList [blob_uuid])
+ end
+ else if (List.mem_assoc "pool-uuid" params) then
+ begin
+ let uuid = List.assoc "pool-uuid" params in
+ let pool = Client.Pool.get_by_uuid rpc session_id uuid in
+ let blob = Client.Pool.create_new_blob rpc session_id pool name mime_type in
+ let blob_uuid = Client.Blob.get_uuid rpc session_id blob in
+ printer (Cli_printer.PList [blob_uuid])
+ end
+ else if (List.mem_assoc "sr-uuid" params) then
+ begin
+ let uuid = List.assoc "sr-uuid" params in
+ let sr = Client.SR.get_by_uuid rpc session_id uuid in
+ let blob = Client.SR.create_new_blob rpc session_id sr name mime_type in
+ let blob_uuid = Client.Blob.get_uuid rpc session_id blob in
+ printer (Cli_printer.PList [blob_uuid])
+ end
+ else if (List.mem_assoc "host-uuid" params) then
+ begin
+ let uuid = List.assoc "host-uuid" params in
+ let host = Client.Host.get_by_uuid rpc session_id uuid in
+ let blob = Client.Host.create_new_blob rpc session_id host name mime_type in
+ let blob_uuid = Client.Blob.get_uuid rpc session_id blob in
+ printer (Cli_printer.PList [blob_uuid])
+ end
+ else if (List.mem_assoc "network-uuid" params) then
+ begin
+ let uuid = List.assoc "network-uuid" params in
+ let network = Client.Network.get_by_uuid rpc session_id uuid in
+ let blob = Client.Network.create_new_blob rpc session_id network name mime_type in
+ let blob_uuid = Client.Blob.get_uuid rpc session_id blob in
+ printer (Cli_printer.PList [blob_uuid])
+ end
+ else
+ raise (Cli_util.Cli_failure "Need one of: vm-uuid, host-uuid, network-uuid, sr-uuid or pool-uuid")
let export_common fd printer rpc session_id params filename num ?task_uuid use_compression preserve_power_state vm =
- let vm_metadata_only = get_bool_param params "metadata" in
- let vm_record = vm.record () in
- let exporttask, task_destroy_fn =
- match task_uuid with
- | None -> (* manage task internally *)
- let exporttask = Client.Task.create rpc session_id (Printf.sprintf "Export of VM: %s" (vm_record.API.vM_uuid)) "" in
- (exporttask,(fun ()->Client.Task.destroy rpc session_id exporttask))
- | Some task_uuid -> (* do not destroy the task that has been received *)
- ((Client.Task.get_by_uuid rpc session_id task_uuid),(fun ()->()))
- in
+ let vm_metadata_only = get_bool_param params "metadata" in
+ let vm_record = vm.record () in
+ let exporttask, task_destroy_fn =
+ match task_uuid with
+ | None -> (* manage task internally *)
+ let exporttask = Client.Task.create rpc session_id (Printf.sprintf "Export of VM: %s" (vm_record.API.vM_uuid)) "" in
+ (exporttask,(fun ()->Client.Task.destroy rpc session_id exporttask))
+ | Some task_uuid -> (* do not destroy the task that has been received *)
+ ((Client.Task.get_by_uuid rpc session_id task_uuid),(fun ()->()))
+ in
+
+ (* Initially mark the task progress as -1.0. The first thing the export handler does it to mark it as zero *)
+ (* This is used as a flag to show that the 'ownership' of the task has been passed to the handler, and it's *)
+ (* not our responsibility any more to mark the task as completed/failed/etc. *)
+ let __context = Context.make "export" in
+ Db_actions.DB_Action.Task.set_progress ~__context ~self:exporttask ~value:(-1.0);
- (* Initially mark the task progress as -1.0. The first thing the export handler does it to mark it as zero *)
- (* This is used as a flag to show that the 'ownership' of the task has been passed to the handler, and it's *)
- (* not our responsibility any more to mark the task as completed/failed/etc. *)
- let __context = Context.make "export" in
- Db_actions.DB_Action.Task.set_progress ~__context ~self:exporttask ~value:(-1.0);
-
- finally
- (fun () ->
- let f = if !num > 1 then filename ^ (string_of_int !num) else filename in
- download_file ~__context rpc session_id exporttask fd f
- (Printf.sprintf
- "%s?session_id=%s&task_id=%s&ref=%s&%s=%s&preserve_power_state=%b"
- (if vm_metadata_only then Constants.export_metadata_uri else Constants.export_uri)
- (Ref.string_of session_id)
- (Ref.string_of exporttask)
- (Ref.string_of (vm.getref ()))
- Constants.use_compression
- (if use_compression then "true" else "false")
- preserve_power_state)
- "Export";
- num := !num + 1)
- (fun () -> task_destroy_fn ())
+ finally
+ (fun () ->
+ let f = if !num > 1 then filename ^ (string_of_int !num) else filename in
+ download_file ~__context rpc session_id exporttask fd f
+ (Printf.sprintf
+ "%s?session_id=%s&task_id=%s&ref=%s&%s=%s&preserve_power_state=%b"
+ (if vm_metadata_only then Constants.export_metadata_uri else Constants.export_uri)
+ (Ref.string_of session_id)
+ (Ref.string_of exporttask)
+ (Ref.string_of (vm.getref ()))
+ Constants.use_compression
+ (if use_compression then "true" else "false")
+ preserve_power_state)
+ "Export";
+ num := !num + 1)
+ (fun () -> task_destroy_fn ())
let vm_export fd printer rpc session_id params =
- let filename = List.assoc "filename" params in
- let use_compression = get_bool_param params "compress" in
- let preserve_power_state = get_bool_param params "preserve-power-state" in
- let task_uuid = if (List.mem_assoc "task-uuid" params) then Some (List.assoc "task-uuid" params) else None in
- let num = ref 1 in
- let op vm =
- export_common fd printer rpc session_id params filename num ?task_uuid use_compression preserve_power_state vm
- in
- ignore(do_vm_op printer rpc session_id op params ["filename"; "metadata"; "compress"; "preserve-power-state"])
+ let filename = List.assoc "filename" params in
+ let use_compression = get_bool_param params "compress" in
+ let preserve_power_state = get_bool_param params "preserve-power-state" in
+ let task_uuid = if (List.mem_assoc "task-uuid" params) then Some (List.assoc "task-uuid" params) else None in
+ let num = ref 1 in
+ let op vm =
+ export_common fd printer rpc session_id params filename num ?task_uuid use_compression preserve_power_state vm
+ in
+ ignore(do_vm_op printer rpc session_id op params ["filename"; "metadata"; "compress"; "preserve-power-state"])
let vm_export_aux obj_type fd printer rpc session_id params =
- let filename = List.assoc "filename" params in
- let use_compression = get_bool_param params "compress" in
- let preserve_power_state = get_bool_param params "preserve-power-state" in
- let num = ref 1 in
- let uuid = List.assoc (obj_type ^ "-uuid") params in
- let ref = Client.VM.get_by_uuid rpc session_id uuid in
- export_common fd printer rpc session_id params filename num use_compression preserve_power_state (vm_record rpc session_id ref)
+ let filename = List.assoc "filename" params in
+ let use_compression = get_bool_param params "compress" in
+ let preserve_power_state = get_bool_param params "preserve-power-state" in
+ let num = ref 1 in
+ let uuid = List.assoc (obj_type ^ "-uuid") params in
+ let ref = Client.VM.get_by_uuid rpc session_id uuid in
+ export_common fd printer rpc session_id params filename num use_compression preserve_power_state (vm_record rpc session_id ref)
let vm_copy_bios_strings printer rpc session_id params =
- let host = Client.Host.get_by_uuid rpc session_id (List.assoc "host-uuid" params) in
- let op vm =
- Client.VM.copy_bios_strings rpc session_id (vm.getref ()) host in
- ignore(do_vm_op printer rpc session_id op params ["host-uuid"])
+ let host = Client.Host.get_by_uuid rpc session_id (List.assoc "host-uuid" params) in
+ let op vm =
+ Client.VM.copy_bios_strings rpc session_id (vm.getref ()) host in
+ ignore(do_vm_op printer rpc session_id op params ["host-uuid"])
let vm_is_bios_customized printer rpc session_id params =
- let op vm =
- let bios_strings = Client.VM.get_bios_strings rpc session_id (vm.getref ()) in
- if List.length bios_strings = 0 then
- printer (Cli_printer.PMsg "The BIOS strings of this VM have not yet been set.")
- else if bios_strings = Xapi_globs.generic_bios_strings then
- printer (Cli_printer.PMsg "This VM is BIOS-generic.")
- else
- printer (Cli_printer.PMsg "This VM is BIOS-customized.")
- in
- ignore(do_vm_op printer rpc session_id op params [])
+ let op vm =
+ let bios_strings = Client.VM.get_bios_strings rpc session_id (vm.getref ()) in
+ if List.length bios_strings = 0 then
+ printer (Cli_printer.PMsg "The BIOS strings of this VM have not yet been set.")
+ else if bios_strings = Xapi_globs.generic_bios_strings then
+ printer (Cli_printer.PMsg "This VM is BIOS-generic.")
+ else
+ printer (Cli_printer.PMsg "This VM is BIOS-customized.")
+ in
+ ignore(do_vm_op printer rpc session_id op params [])
let template_export fd printer = vm_export_aux "template" fd printer
let snapshot_export fd printer = vm_export_aux "snapshot" fd printer
let vm_vcpu_hotplug printer rpc session_id params =
- let vcpus=List.assoc "new-vcpus" params in
- let nvcpu =
- try
- Int64.of_string vcpus
- with
- _ -> failwith "Failed to parse parameter 'new-vcpus': expecting an integer"
- in
- let op vm =
- Client.VM.set_VCPUs_number_live ~rpc ~session_id ~self:(vm.getref ()) ~nvcpu
- in
- ignore(do_vm_op printer rpc session_id op params ["new-vcpus"])
+ let vcpus=List.assoc "new-vcpus" params in
+ let nvcpu =
+ try
+ Int64.of_string vcpus
+ with
+ _ -> failwith "Failed to parse parameter 'new-vcpus': expecting an integer"
+ in
+ let op vm =
+ Client.VM.set_VCPUs_number_live ~rpc ~session_id ~self:(vm.getref ()) ~nvcpu
+ in
+ ignore(do_vm_op printer rpc session_id op params ["new-vcpus"])
let vm_vif_list printer rpc session_id params =
- let op vm =
- let vm_record = vm.record () in
- let vifs = vm_record.API.vM_VIFs in
- let table vif =
- let record = vif_record rpc session_id vif in
- let selected = List.hd (select_fields params [record] [ "uuid"; "device"; "MAC"; "network-uuid"; "network-name-label"; "vm-name-label"]) in
- List.map print_field selected in
- printer (Cli_printer.PTable (List.map table vifs))
- in
- ignore(do_vm_op printer rpc session_id op (("multiple","true")::params) ["params"]) (* always list multiple vms *)
+ let op vm =
+ let vm_record = vm.record () in
+ let vifs = vm_record.API.vM_VIFs in
+ let table vif =
+ let record = vif_record rpc session_id vif in
+ let selected = List.hd (select_fields params [record] [ "uuid"; "device"; "MAC"; "network-uuid"; "network-name-label"; "vm-name-label"]) in
+ List.map print_field selected in
+ printer (Cli_printer.PTable (List.map table vifs))
+ in
+ ignore(do_vm_op printer rpc session_id op (("multiple","true")::params) ["params"]) (* always list multiple vms *)
let cd_list printer rpc session_id params =
- let srs = Client.SR.get_all_records_where rpc session_id "true" in
- let cd_srs = List.filter (fun (sr,sr_record) -> sr_record.API.sR_content_type = "iso") srs in
- let cd_vdis = List.flatten (List.map (fun (sr,sr_record) -> Client.SR.get_VDIs rpc session_id sr) cd_srs) in
- let table cd =
- let record = vdi_record rpc session_id cd in
- let selected = List.hd (select_fields params [record] ["name-label"; "uuid"]) in
- List.map print_field selected in
- printer (Cli_printer.PTable (List.map table cd_vdis))
+ let srs = Client.SR.get_all_records_where rpc session_id "true" in
+ let cd_srs = List.filter (fun (sr,sr_record) -> sr_record.API.sR_content_type = "iso") srs in
+ let cd_vdis = List.flatten (List.map (fun (sr,sr_record) -> Client.SR.get_VDIs rpc session_id sr) cd_srs) in
+ let table cd =
+ let record = vdi_record rpc session_id cd in
+ let selected = List.hd (select_fields params [record] ["name-label"; "uuid"]) in
+ List.map print_field selected in
+ printer (Cli_printer.PTable (List.map table cd_vdis))
let validate_and_get_vlan params =
- try Int64.of_string (List.assoc "vlan" params)
- with _ -> failwith "Failed to parse parameter 'vlan': expecting an integer"
+ try Int64.of_string (List.assoc "vlan" params)
+ with _ -> failwith "Failed to parse parameter 'vlan': expecting an integer"
let vlan_create printer rpc session_id params =
- let network = Client.Network.get_by_uuid rpc session_id (List.assoc "network-uuid" params) in
- let pif = Client.PIF.get_by_uuid rpc session_id (List.assoc "pif-uuid" params) in
- let vLAN = validate_and_get_vlan params in
- let vlan = Client.VLAN.create rpc session_id pif vLAN network in
- let pif' = Client.VLAN.get_untagged_PIF rpc session_id vlan in
- let uuid = Client.PIF.get_uuid rpc session_id pif' in
- (* XXX: technically Rio displayed the PIF UUID here *)
- printer (Cli_printer.PList [uuid])
+ let network = Client.Network.get_by_uuid rpc session_id (List.assoc "network-uuid" params) in
+ let pif = Client.PIF.get_by_uuid rpc session_id (List.assoc "pif-uuid" params) in
+ let vLAN = validate_and_get_vlan params in
+ let vlan = Client.VLAN.create rpc session_id pif vLAN network in
+ let pif' = Client.VLAN.get_untagged_PIF rpc session_id vlan in
+ let uuid = Client.PIF.get_uuid rpc session_id pif' in
+ (* XXX: technically Rio displayed the PIF UUID here *)
+ printer (Cli_printer.PList [uuid])
let pool_vlan_create printer rpc session_id params =
- let network = Client.Network.get_by_uuid rpc session_id (List.assoc "network-uuid" params) in
- let pif = Client.PIF.get_by_uuid rpc session_id (List.assoc "pif-uuid" params) in
- let vLAN = validate_and_get_vlan params in
- let vlan_pifs = Client.Pool.create_VLAN_from_PIF rpc session_id pif network vLAN in
- let vlan_pif_uuids = List.map (fun pif -> Client.PIF.get_uuid rpc session_id pif) vlan_pifs in
- (* XXX: technically Rio displayed the PIF UUID here *)
- printer (Cli_printer.PList vlan_pif_uuids)
+ let network = Client.Network.get_by_uuid rpc session_id (List.assoc "network-uuid" params) in
+ let pif = Client.PIF.get_by_uuid rpc session_id (List.assoc "pif-uuid" params) in
+ let vLAN = validate_and_get_vlan params in
+ let vlan_pifs = Client.Pool.create_VLAN_from_PIF rpc session_id pif network vLAN in
+ let vlan_pif_uuids = List.map (fun pif -> Client.PIF.get_uuid rpc session_id pif) vlan_pifs in
+ (* XXX: technically Rio displayed the PIF UUID here *)
+ printer (Cli_printer.PList vlan_pif_uuids)
let vlan_destroy printer rpc session_id params =
- (* Rio allowed a PIF UUID to be provided; support this mechanism *)
- let uuid = List.assoc "uuid" params in
- try
- let vlan = Client.VLAN.get_by_uuid rpc session_id uuid in
- Client.VLAN.destroy rpc session_id vlan
- with
- | Api_errors.Server_error(s,_) as e when s=Api_errors.handle_invalid ->
- raise e
- | _ ->
- let pif = Client.PIF.get_by_uuid rpc session_id uuid in
- Client.PIF.destroy rpc session_id pif
+ (* Rio allowed a PIF UUID to be provided; support this mechanism *)
+ let uuid = List.assoc "uuid" params in
+ try
+ let vlan = Client.VLAN.get_by_uuid rpc session_id uuid in
+ Client.VLAN.destroy rpc session_id vlan
+ with
+ | Api_errors.Server_error(s,_) as e when s=Api_errors.handle_invalid ->
+ raise e
+ | _ ->
+ let pif = Client.PIF.get_by_uuid rpc session_id uuid in
+ Client.PIF.destroy rpc session_id pif
let tunnel_create printer rpc session_id params =
let network = Client.Network.get_by_uuid rpc session_id (List.assoc "network-uuid" params) in
Client.Tunnel.destroy rpc session_id tunnel
let pif_reconfigure_ip printer rpc session_id params =
- let read_optional_case_insensitive key =
- let lower_case_params = List.map (fun (k,v)->(String.lowercase k,v)) params in
- let lower_case_key = String.lowercase key in
- List.assoc_default lower_case_key lower_case_params "" in
-
- let pif = Client.PIF.get_by_uuid rpc session_id (List.assoc "uuid" params) in
- let mode = Record_util.ip_configuration_mode_of_string (List.assoc "mode" params) in
- let ip = read_optional_case_insensitive "IP" in
- let netmask = List.assoc_default "netmask" params "" in
- let gateway = List.assoc_default "gateway" params "" in
- let dns = read_optional_case_insensitive "DNS" in
- let () = Client.PIF.reconfigure_ip rpc session_id pif mode ip netmask gateway dns in ()
+ let read_optional_case_insensitive key =
+ let lower_case_params = List.map (fun (k,v)->(String.lowercase k,v)) params in
+ let lower_case_key = String.lowercase key in
+ List.assoc_default lower_case_key lower_case_params "" in
+
+ let pif = Client.PIF.get_by_uuid rpc session_id (List.assoc "uuid" params) in
+ let mode = Record_util.ip_configuration_mode_of_string (List.assoc "mode" params) in
+ let ip = read_optional_case_insensitive "IP" in
+ let netmask = List.assoc_default "netmask" params "" in
+ let gateway = List.assoc_default "gateway" params "" in
+ let dns = read_optional_case_insensitive "DNS" in
+ let () = Client.PIF.reconfigure_ip rpc session_id pif mode ip netmask gateway dns in ()
let pif_unplug printer rpc session_id params =
- let pif = Client.PIF.get_by_uuid rpc session_id (List.assoc "uuid" params) in
- let () = Client.PIF.unplug rpc session_id pif in ()
+ let pif = Client.PIF.get_by_uuid rpc session_id (List.assoc "uuid" params) in
+ let () = Client.PIF.unplug rpc session_id pif in ()
let pif_plug printer rpc session_id params =
- let pif = Client.PIF.get_by_uuid rpc session_id (List.assoc "uuid" params) in
- let () = Client.PIF.plug rpc session_id pif in ()
+ let pif = Client.PIF.get_by_uuid rpc session_id (List.assoc "uuid" params) in
+ let () = Client.PIF.plug rpc session_id pif in ()
let pif_scan printer rpc session_id params =
- let host_uuid = List.assoc "host-uuid" params in
- let host = Client.Host.get_by_uuid rpc session_id host_uuid in
- let () = Client.PIF.scan rpc session_id host in
- ()
+ let host_uuid = List.assoc "host-uuid" params in
+ let host = Client.Host.get_by_uuid rpc session_id host_uuid in
+ let () = Client.PIF.scan rpc session_id host in
+ ()
let pif_introduce printer rpc session_id params =
- let host_uuid = List.assoc "host-uuid" params in
- let host = Client.Host.get_by_uuid rpc session_id host_uuid in
- let mac = List.assoc "mac" params in
- let device = List.assoc "device" params in
- let pif = Client.PIF.introduce rpc session_id host mac device in
- let uuid = Client.PIF.get_uuid rpc session_id pif in
- printer (Cli_printer.PList [uuid])
+ let host_uuid = List.assoc "host-uuid" params in
+ let host = Client.Host.get_by_uuid rpc session_id host_uuid in
+ let mac = List.assoc "mac" params in
+ let device = List.assoc "device" params in
+ let pif = Client.PIF.introduce rpc session_id host mac device in
+ let uuid = Client.PIF.get_uuid rpc session_id pif in
+ printer (Cli_printer.PList [uuid])
let pif_forget printer rpc session_id params =
- let pif_uuid = List.assoc "uuid" params in
- let pif = Client.PIF.get_by_uuid rpc session_id pif_uuid in
- let () = Client.PIF.forget rpc session_id pif in
- ()
+ let pif_uuid = List.assoc "uuid" params in
+ let pif = Client.PIF.get_by_uuid rpc session_id pif_uuid in
+ let () = Client.PIF.forget rpc session_id pif in
+ ()
let pif_db_forget printer rpc session_id params =
- let pif_uuid = List.assoc "uuid" params in
- let pif = Client.PIF.get_by_uuid rpc session_id pif_uuid in
- let () = Client.PIF.db_forget rpc session_id pif in
- ()
+ let pif_uuid = List.assoc "uuid" params in
+ let pif = Client.PIF.get_by_uuid rpc session_id pif_uuid in
+ let () = Client.PIF.db_forget rpc session_id pif in
+ ()
let bond_create printer rpc session_id params =
- let network = List.assoc "network-uuid" params in
- let mac = List.assoc_default "mac" params "" in
- let network = Client.Network.get_by_uuid rpc session_id network in
- let pifs = List.assoc "pif-uuids" params in
- let uuids = String.split ',' pifs in
- let pifs = List.map (fun uuid -> Client.PIF.get_by_uuid rpc session_id uuid) uuids in
- let bond = Client.Bond.create rpc session_id network pifs mac in
- let uuid = Client.Bond.get_uuid rpc session_id bond in
- printer (Cli_printer.PList [ uuid])
+ let network = List.assoc "network-uuid" params in
+ let mac = List.assoc_default "mac" params "" in
+ let network = Client.Network.get_by_uuid rpc session_id network in
+ let pifs = List.assoc "pif-uuids" params in
+ let uuids = String.split ',' pifs in
+ let pifs = List.map (fun uuid -> Client.PIF.get_by_uuid rpc session_id uuid) uuids in
+ let bond = Client.Bond.create rpc session_id network pifs mac in
+ let uuid = Client.Bond.get_uuid rpc session_id bond in
+ printer (Cli_printer.PList [ uuid])
let bond_destroy printer rpc session_id params =
- let uuid = List.assoc "uuid" params in
- let bond = Client.Bond.get_by_uuid rpc session_id uuid in
- Client.Bond.destroy rpc session_id bond
+ let uuid = List.assoc "uuid" params in
+ let bond = Client.Bond.get_by_uuid rpc session_id uuid in
+ Client.Bond.destroy rpc session_id bond
let host_disable printer rpc session_id params =
- ignore(do_host_op rpc session_id (fun _ host -> Client.Host.disable rpc session_id (host.getref ())) params [])
+ ignore(do_host_op rpc session_id (fun _ host -> Client.Host.disable rpc session_id (host.getref ())) params [])
let host_sync_data printer rpc session_id params =
- ignore(do_host_op rpc session_id (fun _ host -> Client.Host.sync_data rpc session_id (host.getref ())) params [])
+ ignore(do_host_op rpc session_id (fun _ host -> Client.Host.sync_data rpc session_id (host.getref ())) params [])
(*
- BAD BAD MAN
- We remove the GUI-specific maintenance mode key in other config here
- to stop the gui from re-disabling the host
+ BAD BAD MAN
+ We remove the GUI-specific maintenance mode key in other config here
+ to stop the gui from re-disabling the host
- http://scale.ad.xensource.com/browse/CA-12656
- Host doesn't exit from maintenance mode through CLI.
+ http://scale.ad.xensource.com/browse/CA-12656
+ Host doesn't exit from maintenance mode through CLI.
- This should be cleaned up at some point.
-*)
+ This should be cleaned up at some point.
+ *)
let host_enable printer rpc session_id params =
- ignore(do_host_op rpc session_id (fun _ host ->
- Client.Host.remove_from_other_config rpc session_id (host.getref ()) "MAINTENANCE_MODE";
- Client.Host.enable rpc session_id (host.getref ())) params [])
+ ignore(do_host_op rpc session_id (fun _ host ->
+ Client.Host.remove_from_other_config rpc session_id (host.getref ()) "MAINTENANCE_MODE";
+ Client.Host.enable rpc session_id (host.getref ())) params [])
let host_shutdown printer rpc session_id params =
- ignore(do_host_op rpc session_id (fun _ host -> Client.Host.shutdown rpc session_id (host.getref ())) params [])
+ ignore(do_host_op rpc session_id (fun _ host -> Client.Host.shutdown rpc session_id (host.getref ())) params [])
let host_reboot printer rpc session_id params =
- ignore(do_host_op rpc session_id (fun _ host -> Client.Host.reboot rpc session_id (host.getref ())) params [])
+ ignore(do_host_op rpc session_id (fun _ host -> Client.Host.reboot rpc session_id (host.getref ())) params [])
let host_power_on printer rpc session_id params =
- ignore(do_host_op rpc session_id (fun _ host -> Client.Host.power_on rpc session_id (host.getref ())) params [])
+ ignore(do_host_op rpc session_id (fun _ host -> Client.Host.power_on rpc session_id (host.getref ())) params [])
let host_dmesg printer rpc session_id params =
- let op _ host =
- let dmesg = Client.Host.dmesg rpc session_id (host.getref ()) in
- printer (Cli_printer.PList [ dmesg ])
- in
- ignore(do_host_op rpc session_id op params [])
+ let op _ host =
+ let dmesg = Client.Host.dmesg rpc session_id (host.getref ()) in
+ printer (Cli_printer.PList [ dmesg ])
+ in
+ ignore(do_host_op rpc session_id op params [])
let host_enable_local_storage_caching printer rpc session_id params =
ignore(do_host_op rpc session_id (fun _ host ->
Client.Pool.disable_local_storage_caching rpc session_id pool
let host_set_power_on_mode printer rpc session_id params =
- let power_on_mode = List.assoc "power-on-mode" params in
- let power_on_config = read_map_params "power-on-config" params in
- ignore(
- do_host_op rpc session_id (fun _ host -> Client.Host.set_power_on_mode ~rpc ~session_id ~self:(host.getref ()) ~power_on_mode ~power_on_config )
- params ["power-on-mode";"power-on-config"]
- )
+ let power_on_mode = List.assoc "power-on-mode" params in
+ let power_on_config = read_map_params "power-on-config" params in
+ ignore(
+ do_host_op rpc session_id (fun _ host -> Client.Host.set_power_on_mode ~rpc ~session_id ~self:(host.getref ()) ~power_on_mode ~power_on_config )
+ params ["power-on-mode";"power-on-config"]
+ )
let host_crash_upload printer rpc session_id params =
- let crash = Client.Host_crashdump.get_by_uuid rpc session_id (List.assoc "uuid" params) in
- let url = List.assoc_default "url" params "" in
- (* pass everything else in as an option *)
- let options = List.filter (fun (k, _) -> k <> "uuid" && k <> "url") params in
- Client.Host_crashdump.upload rpc session_id crash url options
+ let crash = Client.Host_crashdump.get_by_uuid rpc session_id (List.assoc "uuid" params) in
+ let url = List.assoc_default "url" params "" in
+ (* pass everything else in as an option *)
+ let options = List.filter (fun (k, _) -> k <> "uuid" && k <> "url") params in
+ Client.Host_crashdump.upload rpc session_id crash url options
let host_crash_destroy printer rpc session_id params =
- let crash = Client.Host_crashdump.get_by_uuid rpc session_id (List.assoc "uuid" params) in
- Client.Host_crashdump.destroy rpc session_id crash
+ let crash = Client.Host_crashdump.get_by_uuid rpc session_id (List.assoc "uuid" params) in
+ Client.Host_crashdump.destroy rpc session_id crash
let host_bugreport_upload printer rpc session_id params =
- let op _ host =
- let url = List.assoc_default "url" params "" in
- (* pass everything else in as an option *)
- let options = List.filter (fun (k, _) -> k <> "host" && k <> "url") params in
- Client.Host.bugreport_upload rpc session_id (host.getref ()) url options
- in
- ignore(do_host_op rpc session_id op params ["url"; "http_proxy"])
+ let op _ host =
+ let url = List.assoc_default "url" params "" in
+ (* pass everything else in as an option *)
+ let options = List.filter (fun (k, _) -> k <> "host" && k <> "url") params in
+ Client.Host.bugreport_upload rpc session_id (host.getref ()) url options
+ in
+ ignore(do_host_op rpc session_id op params ["url"; "http_proxy"])
let host_backup fd printer rpc session_id params =
- let op _ host =
- let filename = List.assoc "file-name" params in
- let prefix =
- let localhost_uuid = Helpers.get_localhost_uuid () in
- if (safe_get_field (field_lookup host.fields "uuid")) = localhost_uuid
- then ""
- else "https://"^(safe_get_field (field_lookup host.fields "address"))
- in
- let make_command task_id =
- let uri = Printf.sprintf "%s%s?session_id=%s&task_id=%s" prefix
- Constants.host_backup_uri (Ref.string_of session_id) (Ref.string_of task_id) in
- HttpGet (filename, uri) in
- ignore(track_http_operation fd rpc session_id make_command "host backup download")
- in
- ignore(do_host_op rpc session_id op params ["file-name"] ~multiple:false)
+ let op _ host =
+ let filename = List.assoc "file-name" params in
+ let prefix =
+ let localhost_uuid = Helpers.get_localhost_uuid () in
+ if (safe_get_field (field_lookup host.fields "uuid")) = localhost_uuid
+ then ""
+ else "https://"^(safe_get_field (field_lookup host.fields "address"))
+ in
+ let make_command task_id =
+ let uri = Printf.sprintf "%s%s?session_id=%s&task_id=%s" prefix
+ Constants.host_backup_uri (Ref.string_of session_id) (Ref.string_of task_id) in
+ HttpGet (filename, uri) in
+ ignore(track_http_operation fd rpc session_id make_command "host backup download")
+ in
+ ignore(do_host_op rpc session_id op params ["file-name"] ~multiple:false)
let pool_dump_db fd printer rpc session_id params =
- let filename = List.assoc "file-name" params in
- let pool = List.hd (Client.Pool.get_all rpc session_id) in
- let pool_master = Client.Pool.get_master rpc session_id pool in
- let url_prefix = Client.Host.get_address rpc session_id pool_master in
- let make_command task_id =
- let uri = Printf.sprintf "https://%s%s?session_id=%s&task_id=%s"
- url_prefix
- Constants.pool_xml_db_sync (Ref.string_of session_id) (Ref.string_of task_id) in
- debug "%s" uri;
- HttpGet (filename, uri) in
- ignore(track_http_operation fd rpc session_id make_command "dump database")
+ let filename = List.assoc "file-name" params in
+ let pool = List.hd (Client.Pool.get_all rpc session_id) in
+ let pool_master = Client.Pool.get_master rpc session_id pool in
+ let url_prefix = Client.Host.get_address rpc session_id pool_master in
+ let make_command task_id =
+ let uri = Printf.sprintf "https://%s%s?session_id=%s&task_id=%s"
+ url_prefix
+ Constants.pool_xml_db_sync (Ref.string_of session_id) (Ref.string_of task_id) in
+ debug "%s" uri;
+ HttpGet (filename, uri) in
+ ignore(track_http_operation fd rpc session_id make_command "dump database")
let pool_restore_db fd printer rpc session_id params =
- let dry_run = List.mem_assoc "dry-run" params in
- if not(List.mem_assoc "force" params) && not(dry_run)
- then failwith "This operation will restore the database backup to this host, making it the master. All slave hosts are assumed dead and they will be forgotten. This operation must be forced (use --force).";
- let filename = List.assoc "file-name" params in
- let pool = List.hd (Client.Pool.get_all rpc session_id) in
- let pool_master = Client.Pool.get_master rpc session_id pool in
- let url_prefix = Client.Host.get_address rpc session_id pool_master in
- let make_command task_id =
- let uri = Printf.sprintf "https://%s%s?session_id=%s&task_id=%s&dry_run=%b"
- url_prefix
- Constants.pool_xml_db_sync (Ref.string_of session_id) (Ref.string_of task_id)
- dry_run in
- debug "%s" uri;
- HttpPut (filename, uri) in
- ignore(track_http_operation fd rpc session_id make_command "restore database");
- if dry_run
- then printer (Cli_printer.PList [ "Dry-run backup restore successful" ])
- else printer (Cli_printer.PList ["Host will reboot with restored database in "^(string_of_int Xapi_globs.db_restore_fuse_time)^" seconds..."])
+ let dry_run = List.mem_assoc "dry-run" params in
+ if not(List.mem_assoc "force" params) && not(dry_run)
+ then failwith "This operation will restore the database backup to this host, making it the master. All slave hosts are assumed dead and they will be forgotten. This operation must be forced (use --force).";
+ let filename = List.assoc "file-name" params in
+ let pool = List.hd (Client.Pool.get_all rpc session_id) in
+ let pool_master = Client.Pool.get_master rpc session_id pool in
+ let url_prefix = Client.Host.get_address rpc session_id pool_master in
+ let make_command task_id =
+ let uri = Printf.sprintf "https://%s%s?session_id=%s&task_id=%s&dry_run=%b"
+ url_prefix
+ Constants.pool_xml_db_sync (Ref.string_of session_id) (Ref.string_of task_id)
+ dry_run in
+ debug "%s" uri;
+ HttpPut (filename, uri) in
+ ignore(track_http_operation fd rpc session_id make_command "restore database");
+ if dry_run
+ then printer (Cli_printer.PList [ "Dry-run backup restore successful" ])
+ else printer (Cli_printer.PList ["Host will reboot with restored database in "^(string_of_int Xapi_globs.db_restore_fuse_time)^" seconds..."])
let pool_enable_external_auth printer rpc session_id params =
- let pool =
- if (List.mem_assoc "uuid" params) then (*user provided a pool uuid*)
- let pool_uuid = List.assoc "uuid" params in
- Client.Pool.get_by_uuid rpc session_id pool_uuid
- else (*user didn't provide a pool uuid: let's fetch the default pool*)
- List.hd (Client.Pool.get_all rpc session_id)
- in
- let auth_type = List.assoc "auth-type" params in
- let service_name = List.assoc "service-name" params in
- let config = read_map_params "config" params in
- Client.Pool.enable_external_auth rpc session_id pool config service_name auth_type
+ let pool =
+ if (List.mem_assoc "uuid" params) then (*user provided a pool uuid*)
+ let pool_uuid = List.assoc "uuid" params in
+ Client.Pool.get_by_uuid rpc session_id pool_uuid
+ else (*user didn't provide a pool uuid: let's fetch the default pool*)
+ List.hd (Client.Pool.get_all rpc session_id)
+ in
+ let auth_type = List.assoc "auth-type" params in
+ let service_name = List.assoc "service-name" params in
+ let config = read_map_params "config" params in
+ Client.Pool.enable_external_auth rpc session_id pool config service_name auth_type
let pool_disable_external_auth printer rpc session_id params =
- let pool =
- if (List.mem_assoc "uuid" params) then (*user provided a pool uuid*)
- let pool_uuid = List.assoc "uuid" params in
- Client.Pool.get_by_uuid rpc session_id pool_uuid
- else (*user didn't provide a pool uuid: let's fetch the default pool*)
- List.hd (Client.Pool.get_all rpc session_id)
- in
- let config = read_map_params "config" params in
- Client.Pool.disable_external_auth rpc session_id pool config
+ let pool =
+ if (List.mem_assoc "uuid" params) then (*user provided a pool uuid*)
+ let pool_uuid = List.assoc "uuid" params in
+ Client.Pool.get_by_uuid rpc session_id pool_uuid
+ else (*user didn't provide a pool uuid: let's fetch the default pool*)
+ List.hd (Client.Pool.get_all rpc session_id)
+ in
+ let config = read_map_params "config" params in
+ Client.Pool.disable_external_auth rpc session_id pool config
let host_restore fd printer rpc session_id params =
- let filename = List.assoc "file-name" params in
- let op _ host =
- let prefix =
- let localhost_uuid = Helpers.get_localhost_uuid () in
- if (safe_get_field (field_lookup host.fields "uuid")) = localhost_uuid
- then ""
- else "https://"^(safe_get_field (field_lookup host.fields "address"))
- in
- let make_command task_id =
- let uri = Printf.sprintf "%s%s?session_id=%s&task_id=%s" prefix
- Constants.host_restore_uri (Ref.string_of session_id) (Ref.string_of task_id) in
- HttpPut (filename, uri) in
- ignore(track_http_operation fd rpc session_id make_command "host backup upload")
- in
- ignore(do_host_op rpc session_id op params ["file-name"] ~multiple:false)
+ let filename = List.assoc "file-name" params in
+ let op _ host =
+ let prefix =
+ let localhost_uuid = Helpers.get_localhost_uuid () in
+ if (safe_get_field (field_lookup host.fields "uuid")) = localhost_uuid
+ then ""
+ else "https://"^(safe_get_field (field_lookup host.fields "address"))
+ in
+ let make_command task_id =
+ let uri = Printf.sprintf "%s%s?session_id=%s&task_id=%s" prefix
+ Constants.host_restore_uri (Ref.string_of session_id) (Ref.string_of task_id) in
+ HttpPut (filename, uri) in
+ ignore(track_http_operation fd rpc session_id make_command "host backup upload")
+ in
+ ignore(do_host_op rpc session_id op params ["file-name"] ~multiple:false)
let host_get_system_status_capabilities printer rpc session_id params =
- printer (Cli_printer.PList
- (do_host_op rpc session_id
- (fun _ host ->
- Client.Host.get_system_status_capabilities ~rpc ~session_id
- ~host:(host.getref ())) params []))
+ printer (Cli_printer.PList
+ (do_host_op rpc session_id
+ (fun _ host ->
+ Client.Host.get_system_status_capabilities ~rpc ~session_id
+ ~host:(host.getref ())) params []))
let wait_for_task rpc session_id task __context fd op_str =
- let ok = match unmarshal fd with
- | Response OK -> true
- | Response Failed ->
- (* Need to check whether the thin cli managed to contact the server or
- not. If not, we need to mark the task as failed *)
- if Client.Task.get_progress rpc session_id task < 0.0
- then Db_actions.DB_Action.Task.set_status ~__context
- ~self:task ~value:`failure;
- false
- | _ -> false in
- wait_for_task_complete rpc session_id task;
-
- (* if the client thinks it's ok, check that the server does too *)
- (match Client.Task.get_status rpc session_id task with
- | `success ->
- if ok
- then (marshal fd (Command (Print (op_str ^ " succeeded"))))
- else (marshal fd (Command (PrintStderr (op_str ^ " failed, unknown error.")));
- raise (ExitWithError 1))
- | `failure ->
- let result = Client.Task.get_error_info rpc session_id task in
- if result = []
- then marshal fd (Command (PrintStderr (op_str ^ " failed, unknown error")))
- else raise (Api_errors.Server_error ((List.hd result),(List.tl result)))
- | `cancelled ->
- marshal fd (Command (PrintStderr (op_str ^ " cancelled")));
- raise (ExitWithError 1)
- | _ ->
- marshal fd (Command (PrintStderr "Internal error")); (* should never happen *)
- raise (ExitWithError 1)
- )
+ let ok = match unmarshal fd with
+ | Response OK -> true
+ | Response Failed ->
+ (* Need to check whether the thin cli managed to contact the server or
+ not. If not, we need to mark the task as failed *)
+ if Client.Task.get_progress rpc session_id task < 0.0
+ then Db_actions.DB_Action.Task.set_status ~__context
+ ~self:task ~value:`failure;
+ false
+ | _ -> false in
+ wait_for_task_complete rpc session_id task;
+
+ (* if the client thinks it's ok, check that the server does too *)
+ (match Client.Task.get_status rpc session_id task with
+ | `success ->
+ if ok
+ then (marshal fd (Command (Print (op_str ^ " succeeded"))))
+ else (marshal fd (Command (PrintStderr (op_str ^ " failed, unknown error.")));
+ raise (ExitWithError 1))
+ | `failure ->
+ let result = Client.Task.get_error_info rpc session_id task in
+ if result = []
+ then marshal fd (Command (PrintStderr (op_str ^ " failed, unknown error")))
+ else raise (Api_errors.Server_error ((List.hd result),(List.tl result)))
+ | `cancelled ->
+ marshal fd (Command (PrintStderr (op_str ^ " cancelled")));
+ raise (ExitWithError 1)
+ | _ ->
+ marshal fd (Command (PrintStderr "Internal error")); (* should never happen *)
+ raise (ExitWithError 1)
+ )
let host_get_system_status fd printer rpc session_id params =
- let filename = List.assoc "filename" params in
- let entries = List.assoc_default "entries" params "" in
- let output = try List.assoc "output" params with _ -> "tar.bz2" in
- begin match output with "tar.bz2" | "tar" | "zip" -> () | _ ->
- failwith "Invalid output format. Must be 'tar', 'zip' or 'tar.bz2'" end;
- let url =
- Printf.sprintf "%s?session_id=%s&entries=%s&output=%s"
- Constants.system_status_uri
- (Ref.string_of session_id)
- entries
- output
- in
- let op n host =
- let _ (* unused variable 'fname' *) =
- if n > 1
- then
- Printf.sprintf "%s-%s%s%s"
- filename
- (safe_get_field (field_lookup host.fields "name-label"))
- (if output = "" then "" else ".")
- output
- else
- filename
- in
- let doit task_id =
- let url = Printf.sprintf "%s&task_id=%s" url (Ref.string_of task_id) in
- if not (!Xapi_globs.slave_emergency_mode) then
- begin
- if n > 1
- then raise Not_found
- else
- let url = Printf.sprintf "https://%s%s" (safe_get_field (field_lookup host.fields "address")) url in
- HttpGet (filename, url)
- end
- else
- HttpGet (filename, url)
- in
- track_http_operation fd rpc session_id doit "system-status download"
- in
- ignore (do_host_op rpc session_id op params ["filename"; "entries"; "output"])
+ let filename = List.assoc "filename" params in
+ let entries = List.assoc_default "entries" params "" in
+ let output = try List.assoc "output" params with _ -> "tar.bz2" in
+ begin match output with "tar.bz2" | "tar" | "zip" -> () | _ ->
+ failwith "Invalid output format. Must be 'tar', 'zip' or 'tar.bz2'" end;
+ let url =
+ Printf.sprintf "%s?session_id=%s&entries=%s&output=%s"
+ Constants.system_status_uri
+ (Ref.string_of session_id)
+ entries
+ output
+ in
+ let op n host =
+ let _ (* unused variable 'fname' *) =
+ if n > 1
+ then
+ Printf.sprintf "%s-%s%s%s"
+ filename
+ (safe_get_field (field_lookup host.fields "name-label"))
+ (if output = "" then "" else ".")
+ output
+ else
+ filename
+ in
+ let doit task_id =
+ let url = Printf.sprintf "%s&task_id=%s" url (Ref.string_of task_id) in
+ if not (!Xapi_globs.slave_emergency_mode) then
+ begin
+ if n > 1
+ then raise Not_found
+ else
+ let url = Printf.sprintf "https://%s%s" (safe_get_field (field_lookup host.fields "address")) url in
+ HttpGet (filename, url)
+ end
+ else
+ HttpGet (filename, url)
+ in
+ track_http_operation fd rpc session_id doit "system-status download"
+ in
+ ignore (do_host_op rpc session_id op params ["filename"; "entries"; "output"])
let host_set_hostname_live printer rpc session_id params =
- let host_uuid = List.assoc "host-uuid" params in
- let host = Client.Host.get_by_uuid rpc session_id host_uuid in
- let hostname = List.assoc "host-name" params in
- Client.Host.set_hostname_live rpc session_id host hostname
+ let host_uuid = List.assoc "host-uuid" params in
+ let host = Client.Host.get_by_uuid rpc session_id host_uuid in
+ let hostname = List.assoc "host-name" params in
+ Client.Host.set_hostname_live rpc session_id host hostname
let host_call_plugin printer rpc session_id params =
- let host_uuid = List.assoc "host-uuid" params in
- let host = Client.Host.get_by_uuid rpc session_id host_uuid in
- let plugin = List.assoc "plugin" params in
- let fn = List.assoc "fn" params in
- let args = read_map_params "args" params in
- let result = Client.Host.call_plugin rpc session_id host plugin fn args in
- printer (Cli_printer.PList [ result ])
+ let host_uuid = List.assoc "host-uuid" params in
+ let host = Client.Host.get_by_uuid rpc session_id host_uuid in
+ let plugin = List.assoc "plugin" params in
+ let fn = List.assoc "fn" params in
+ let args = read_map_params "args" params in
+ let result = Client.Host.call_plugin rpc session_id host plugin fn args in
+ printer (Cli_printer.PList [ result ])
let host_enable_external_auth printer rpc session_id params =
- if not (List.mem_assoc "force" params) then
- failwith "This operation is provided only to recover individual hosts that are unable to access the external authentication service. This operation must be forced (use --force).";
- let host_uuid = List.assoc "host-uuid" params in
- let auth_type = List.assoc "auth-type" params in
- let service_name = List.assoc "service-name" params in
- let config = read_map_params "config" params in
- let host = Client.Host.get_by_uuid rpc session_id host_uuid in
- Client.Host.enable_external_auth rpc session_id host config service_name auth_type
+ if not (List.mem_assoc "force" params) then
+ failwith "This operation is provided only to recover individual hosts that are unable to access the external authentication service. This operation must be forced (use --force).";
+ let host_uuid = List.assoc "host-uuid" params in
+ let auth_type = List.assoc "auth-type" params in
+ let service_name = List.assoc "service-name" params in
+ let config = read_map_params "config" params in
+ let host = Client.Host.get_by_uuid rpc session_id host_uuid in
+ Client.Host.enable_external_auth rpc session_id host config service_name auth_type
let host_disable_external_auth printer rpc session_id params =
- if not (List.mem_assoc "force" params) then
- failwith "This operation is provided only to recover individual hosts that are unable to access the external authentication service. This operation must be forced (use --force).";
- let host_uuid = List.assoc "host-uuid" params in
- let host = Client.Host.get_by_uuid rpc session_id host_uuid in
- let config = read_map_params "config" params in
- Client.Host.disable_external_auth rpc session_id host config
+ if not (List.mem_assoc "force" params) then
+ failwith "This operation is provided only to recover individual hosts that are unable to access the external authentication service. This operation must be forced (use --force).";
+ let host_uuid = List.assoc "host-uuid" params in
+ let host = Client.Host.get_by_uuid rpc session_id host_uuid in
+ let config = read_map_params "config" params in
+ Client.Host.disable_external_auth rpc session_id host config
let host_refresh_pack_info printer rpc session_id params =
- let host_uuid = List.assoc "host-uuid" params in
- let host = Client.Host.get_by_uuid rpc session_id host_uuid in
- Client.Host.refresh_pack_info rpc session_id host
+ let host_uuid = List.assoc "host-uuid" params in
+ let host = Client.Host.get_by_uuid rpc session_id host_uuid in
+ Client.Host.refresh_pack_info rpc session_id host
let host_cpu_info printer rpc session_id params =
- let host =
- if List.mem_assoc "uuid" params then
- Client.Host.get_by_uuid rpc session_id (List.assoc "uuid" params)
- else
- get_host_from_session rpc session_id in
- let cpu_info = Client.Host.get_cpu_info rpc session_id host in
- printer (Cli_printer.PTable [cpu_info])
+ let host =
+ if List.mem_assoc "uuid" params then
+ Client.Host.get_by_uuid rpc session_id (List.assoc "uuid" params)
+ else
+ get_host_from_session rpc session_id in
+ let cpu_info = Client.Host.get_cpu_info rpc session_id host in
+ printer (Cli_printer.PTable [cpu_info])
let host_get_cpu_features printer rpc session_id params =
- let host =
- if List.mem_assoc "uuid" params then
- Client.Host.get_by_uuid rpc session_id (List.assoc "uuid" params)
- else
- get_host_from_session rpc session_id in
- let cpu_info = Client.Host.get_cpu_info rpc session_id host in
- let features = List.assoc "features" cpu_info in
- printer (Cli_printer.PMsg features)
+ let host =
+ if List.mem_assoc "uuid" params then
+ Client.Host.get_by_uuid rpc session_id (List.assoc "uuid" params)
+ else
+ get_host_from_session rpc session_id in
+ let cpu_info = Client.Host.get_cpu_info rpc session_id host in
+ let features = List.assoc "features" cpu_info in
+ printer (Cli_printer.PMsg features)
let host_set_cpu_features printer rpc session_id params =
- let host =
- if List.mem_assoc "uuid" params then
- Client.Host.get_by_uuid rpc session_id (List.assoc "uuid" params)
- else
- get_host_from_session rpc session_id in
- let features = List.assoc "features" params in
- Client.Host.set_cpu_features rpc session_id host features
+ let host =
+ if List.mem_assoc "uuid" params then
+ Client.Host.get_by_uuid rpc session_id (List.assoc "uuid" params)
+ else
+ get_host_from_session rpc session_id in
+ let features = List.assoc "features" params in
+ Client.Host.set_cpu_features rpc session_id host features
let host_reset_cpu_features printer rpc session_id params =
- let host =
- if List.mem_assoc "uuid" params then
- Client.Host.get_by_uuid rpc session_id (List.assoc "uuid" params)
- else
- get_host_from_session rpc session_id in
- Client.Host.reset_cpu_features rpc session_id host
+ let host =
+ if List.mem_assoc "uuid" params then
+ Client.Host.get_by_uuid rpc session_id (List.assoc "uuid" params)
+ else
+ get_host_from_session rpc session_id in
+ Client.Host.reset_cpu_features rpc session_id host
let patch_upload fd printer rpc session_id params =
- let filename = List.assoc "file-name" params in
- let pool = Client.Pool.get_all rpc session_id in
- let pool_master = Client.Pool.get_master rpc session_id (List.hd pool) in
- let master_address = Client.Host.get_address rpc session_id pool_master in
- let make_command task_id =
- let uri = Printf.sprintf "https://%s%s?session_id=%s&task_id=%s"
- master_address Constants.pool_patch_upload_uri (Ref.string_of session_id) (Ref.string_of task_id) in
- let _ = debug "trying to post patch to uri:%s" uri in
- HttpPut (filename, uri) in
- let result = track_http_operation fd rpc session_id make_command "host patch upload" in
- let patch_ref = Ref.of_string result in
- let patch_uuid = Client.Pool_patch.get_uuid rpc session_id patch_ref in
- marshal fd (Command (Print patch_uuid))
+ let filename = List.assoc "file-name" params in
+ let pool = Client.Pool.get_all rpc session_id in
+ let pool_master = Client.Pool.get_master rpc session_id (List.hd pool) in
+ let master_address = Client.Host.get_address rpc session_id pool_master in
+ let make_command task_id =
+ let uri = Printf.sprintf "https://%s%s?session_id=%s&task_id=%s"
+ master_address Constants.pool_patch_upload_uri (Ref.string_of session_id) (Ref.string_of task_id) in
+ let _ = debug "trying to post patch to uri:%s" uri in
+ HttpPut (filename, uri) in
+ let result = track_http_operation fd rpc session_id make_command "host patch upload" in
+ let patch_ref = Ref.of_string result in
+ let patch_uuid = Client.Pool_patch.get_uuid rpc session_id patch_ref in
+ marshal fd (Command (Print patch_uuid))
let update_upload fd printer rpc session_id params =
- let filename = List.assoc "file-name" params in
- let host_uuid = List.assoc "host-uuid" params in
- let host = Client.Host.get_by_uuid rpc session_id host_uuid in
- let host_address = Client.Host.get_address rpc session_id host in
- let make_command task_id =
- let uri = Printf.sprintf "https://%s%s?session_id=%s&task_id=%s"
- host_address Constants.oem_patch_stream_uri (Ref.string_of session_id) (Ref.string_of task_id) in
- let _ = debug "trying to post patch to uri:%s" uri in
- HttpPut (filename, uri)
- in
- let result = track_http_operation fd rpc session_id make_command "host patch upload" in
- marshal fd (Command (Print result))
+ let filename = List.assoc "file-name" params in
+ let host_uuid = List.assoc "host-uuid" params in
+ let host = Client.Host.get_by_uuid rpc session_id host_uuid in
+ let host_address = Client.Host.get_address rpc session_id host in
+ let make_command task_id =
+ let uri = Printf.sprintf "https://%s%s?session_id=%s&task_id=%s"
+ host_address Constants.oem_patch_stream_uri (Ref.string_of session_id) (Ref.string_of task_id) in
+ let _ = debug "trying to post patch to uri:%s" uri in
+ HttpPut (filename, uri)
+ in
+ let result = track_http_operation fd rpc session_id make_command "host patch upload" in
+ marshal fd (Command (Print result))
let patch_clean printer rpc session_id params =
- let uuid = List.assoc "uuid" params in
- let patch_ref = Client.Pool_patch.get_by_uuid rpc session_id uuid in
- Client.Pool_patch.clean rpc session_id patch_ref
+ let uuid = List.assoc "uuid" params in
+ let patch_ref = Client.Pool_patch.get_by_uuid rpc session_id uuid in
+ Client.Pool_patch.clean rpc session_id patch_ref
let patch_destroy printer rpc session_id params =
- let uuid = List.assoc "uuid" params in
- let patch_ref = Client.Pool_patch.get_by_uuid rpc session_id uuid in
- Client.Pool_patch.destroy rpc session_id patch_ref
+ let uuid = List.assoc "uuid" params in
+ let patch_ref = Client.Pool_patch.get_by_uuid rpc session_id uuid in
+ Client.Pool_patch.destroy rpc session_id patch_ref
let patch_apply printer rpc session_id params =
- let patch_uuid = List.assoc "uuid" params in
- let host_uuid = List.assoc "host-uuid" params in
- let patch_ref = Client.Pool_patch.get_by_uuid rpc session_id patch_uuid in
- let host_ref = Client.Host.get_by_uuid rpc session_id host_uuid in
- let result = Client.Pool_patch.apply rpc session_id patch_ref host_ref in
- printer (Cli_printer.PList [ result ])
+ let patch_uuid = List.assoc "uuid" params in
+ let host_uuid = List.assoc "host-uuid" params in
+ let patch_ref = Client.Pool_patch.get_by_uuid rpc session_id patch_uuid in
+ let host_ref = Client.Host.get_by_uuid rpc session_id host_uuid in
+ let result = Client.Pool_patch.apply rpc session_id patch_ref host_ref in
+ printer (Cli_printer.PList [ result ])
let patch_precheck printer rpc session_id params =
- let patch_uuid = List.assoc "uuid" params in
- let host_uuid = List.assoc "host-uuid" params in
- let patch_ref = Client.Pool_patch.get_by_uuid rpc session_id patch_uuid in
- let host_ref = Client.Host.get_by_uuid rpc session_id host_uuid in
- let result = Client.Pool_patch.precheck rpc session_id patch_ref host_ref in
- printer (Cli_printer.PList [ result ])
+ let patch_uuid = List.assoc "uuid" params in
+ let host_uuid = List.assoc "host-uuid" params in
+ let patch_ref = Client.Pool_patch.get_by_uuid rpc session_id patch_uuid in
+ let host_ref = Client.Host.get_by_uuid rpc session_id host_uuid in
+ let result = Client.Pool_patch.precheck rpc session_id patch_ref host_ref in
+ printer (Cli_printer.PList [ result ])
let patch_pool_apply printer rpc session_id params =
- let patch_uuid = List.assoc "uuid" params in
- let patch_ref = Client.Pool_patch.get_by_uuid rpc session_id patch_uuid in
- Client.Pool_patch.pool_apply rpc session_id patch_ref
+ let patch_uuid = List.assoc "uuid" params in
+ let patch_ref = Client.Pool_patch.get_by_uuid rpc session_id patch_uuid in
+ Client.Pool_patch.pool_apply rpc session_id patch_ref
let host_logs_download fd printer rpc session_id params =
- let op n host =
- let filename = if List.mem_assoc "file-name" params then List.assoc "file-name" params
- else
- let tm = Unix.gmtime (Unix.time ()) in
- Printf.sprintf "logs-%d-%d-%dT%02d%02d%02dZ"
- (tm.Unix.tm_year + 1900) (tm.Unix.tm_mon + 1) tm.Unix.tm_mday
- tm.Unix.tm_hour tm.Unix.tm_min tm.Unix.tm_sec in
- let prefix =
- let localhost_uuid = Helpers.get_localhost_uuid () in
- if (safe_get_field (field_lookup host.fields "uuid")) = localhost_uuid
- then ""
- else "https://"^(safe_get_field (field_lookup host.fields "address"))
- in
- let filesuffix =
- if n=1 then "" else "-"^(safe_get_field (field_lookup host.fields "name-label"))
- in
- let make_command task_id =
- let uri = Printf.sprintf "%s%s?session_id=%s&task_id=%s" prefix
- Constants.host_logs_download_uri (Ref.string_of session_id) (Ref.string_of task_id) in
- HttpGet (filename^filesuffix, uri) in
- ignore(track_http_operation fd rpc session_id make_command "host logs download")
- in
- ignore(do_host_op rpc session_id op params ["file-name"])
+ let op n host =
+ let filename = if List.mem_assoc "file-name" params then List.assoc "file-name" params
+ else
+ let tm = Unix.gmtime (Unix.time ()) in
+ Printf.sprintf "logs-%d-%d-%dT%02d%02d%02dZ"
+ (tm.Unix.tm_year + 1900) (tm.Unix.tm_mon + 1) tm.Unix.tm_mday
+ tm.Unix.tm_hour tm.Unix.tm_min tm.Unix.tm_sec in
+ let prefix =
+ let localhost_uuid = Helpers.get_localhost_uuid () in
+ if (safe_get_field (field_lookup host.fields "uuid")) = localhost_uuid
+ then ""
+ else "https://"^(safe_get_field (field_lookup host.fields "address"))
+ in
+ let filesuffix =
+ if n=1 then "" else "-"^(safe_get_field (field_lookup host.fields "name-label"))
+ in
+ let make_command task_id =
+ let uri = Printf.sprintf "%s%s?session_id=%s&task_id=%s" prefix
+ Constants.host_logs_download_uri (Ref.string_of session_id) (Ref.string_of task_id) in
+ HttpGet (filename^filesuffix, uri) in
+ ignore(track_http_operation fd rpc session_id make_command "host logs download")
+ in
+ ignore(do_host_op rpc session_id op params ["file-name"])
let host_is_in_emergency_mode printer rpc session_id params =
- let mode = Client.Host.is_in_emergency_mode ~rpc ~session_id in
- printer (Cli_printer.PMsg (Printf.sprintf "%b" mode))
+ let mode = Client.Host.is_in_emergency_mode ~rpc ~session_id in
+ printer (Cli_printer.PMsg (Printf.sprintf "%b" mode))
let host_emergency_management_reconfigure printer rpc session_id params =
- let interface = List.assoc "interface" params in
- Client.Host.local_management_reconfigure rpc session_id interface
+ let interface = List.assoc "interface" params in
+ Client.Host.local_management_reconfigure rpc session_id interface
let host_emergency_ha_disable printer rpc session_id params =
- let force = get_bool_param params "force" in
- if not force then failwith "This operation is extremely dangerous and may cause data loss. This operation must be forced (use --force).";
- Client.Host.emergency_ha_disable rpc session_id
+ let force = get_bool_param params "force" in
+ if not force then failwith "This operation is extremely dangerous and may cause data loss. This operation must be forced (use --force).";
+ Client.Host.emergency_ha_disable rpc session_id
let host_management_reconfigure printer rpc session_id params =
- let pif = Client.PIF.get_by_uuid rpc session_id (List.assoc "pif-uuid" params) in
- Client.Host.management_reconfigure rpc session_id pif
+ let pif = Client.PIF.get_by_uuid rpc session_id (List.assoc "pif-uuid" params) in
+ Client.Host.management_reconfigure rpc session_id pif
let host_management_disable printer rpc session_id params =
- Client.Host.management_disable rpc session_id
+ Client.Host.management_disable rpc session_id
let host_signal_networking_change printer rpc session_id params =
- Client.Host.signal_networking_change rpc session_id
+ Client.Host.signal_networking_change rpc session_id
let host_notify printer rpc session_id params =
- let ty = List.assoc "type" params in
- let args = List.assoc_default "params" params "" in
- Client.Host.notify rpc session_id ty args
+ let ty = List.assoc "type" params in
+ let args = List.assoc_default "params" params "" in
+ Client.Host.notify rpc session_id ty args
let host_syslog_reconfigure printer rpc session_id params =
- let host = Client.Host.get_by_uuid rpc session_id (List.assoc "host-uuid" params) in
- Client.Host.syslog_reconfigure rpc session_id host
+ let host = Client.Host.get_by_uuid rpc session_id (List.assoc "host-uuid" params) in
+ Client.Host.syslog_reconfigure rpc session_id host
let host_send_debug_keys printer rpc session_id params =
- let host = Client.Host.get_by_uuid rpc session_id (List.assoc "host-uuid" params) in
- let keys = List.assoc "keys" params in
- Client.Host.send_debug_keys rpc session_id host keys
+ let host = Client.Host.get_by_uuid rpc session_id (List.assoc "host-uuid" params) in
+ let keys = List.assoc "keys" params in
+ Client.Host.send_debug_keys rpc session_id host keys
(*
-let host_introduce printer rpc session_id params =
+ let host_introduce printer rpc session_id params =
let name = List.assoc "name" params in
let descr = if List.mem_assoc "description" params then List.assoc "description" params else "" in
let address = List.assoc "address" params in
let remote_username = List.assoc "remote-username" params in
let remote_password = List.assoc "remote-password" params in
ignore(Client.Credential.create_with_password rpc session_id name descr address (Int64.of_string port) remote_username remote_password)
-*)
+ *)
let task_cancel printer rpc session_id params =
- let uuid = List.assoc "uuid" params in
- let task = Client.Task.get_by_uuid rpc session_id uuid in
- Client.Task.cancel rpc session_id task
+ let uuid = List.assoc "uuid" params in
+ let task = Client.Task.get_by_uuid rpc session_id uuid in
+ Client.Task.cancel rpc session_id task
(*
-let alert_create printer rpc session_id params =
+ let alert_create printer rpc session_id params =
let string_to_alert_level s =
- match s with
- | "info" -> `Info
- | "warning" | "warn" -> `Warn
- | "error" -> `Error
- | _ -> `Info
- in
+ match s with
+ | "info" -> `Info
+ | "warning" | "warn" -> `Warn
+ | "error" -> `Error
+ | _ -> `Info
+ in
let message = List.assoc "message" params in
let level = if List.mem_assoc "level" params then List.assoc "level" params else "info" in
let level = string_to_alert_level level in
let uuid = Client.Alert.get_uuid rpc session_id alert in
printer (Cli_printer.PList [uuid])
-let alert_destroy printer rpc session_id params =
+ let alert_destroy printer rpc session_id params =
let uuid = List.assoc "uuid" params in
let alert = Client.Alert.get_by_uuid rpc session_id uuid in
Client.Alert.destroy rpc session_id alert
-*)
+ *)
(*
-let subject_list printer rpc session_id params =
- (* we get all subjects from the pool *)
+ let subject_list printer rpc session_id params =
+(* we get all subjects from the pool *)
let subjects = Client.Subject.get_all_records rpc session_id in
let table_of_subject (subject,record) =
- [ "subject-uuid", record.API.subject_uuid;
- "subject-identifier", record.API.subject_subject_identifier;
- (* "subject-name", Client.Subject.get_subject_name rpc session_id subject;*)
- ] @
- record.API.subject_other_config
+ [ "subject-uuid", record.API.subject_uuid;
+ "subject-identifier", record.API.subject_subject_identifier;
+(* "subject-name", Client.Subject.get_subject_name rpc session_id subject;*)
+ ] @
+ record.API.subject_other_config
in
let all = List.map table_of_subject subjects in
printer (Cli_printer.PTable all)
-*)
+ *)
let subject_add printer rpc session_id params =
- let subject_name = List.assoc "subject-name" params in
- (* let's try to resolve the subject_name to a subject_id using the external directory *)
- let subject_identifier = Client.Auth.get_subject_identifier ~rpc ~session_id ~subject_name in
- (* obtains a list of name-value pairs with info about the subject from the external directory *)
- let subject_info = Client.Auth.get_subject_information_from_identifier ~rpc ~session_id ~subject_identifier in
- (* now we've got enough information to create our new subject in the pool *)
- let subject_ref = Client.Subject.create ~rpc ~session_id ~subject_identifier ~other_config:subject_info in
- let subject_uuid = Client.Subject.get_uuid rpc session_id subject_ref in
- printer (Cli_printer.PList [subject_uuid])
+ let subject_name = List.assoc "subject-name" params in
+ (* let's try to resolve the subject_name to a subject_id using the external directory *)
+ let subject_identifier = Client.Auth.get_subject_identifier ~rpc ~session_id ~subject_name in
+ (* obtains a list of name-value pairs with info about the subject from the external directory *)
+ let subject_info = Client.Auth.get_subject_information_from_identifier ~rpc ~session_id ~subject_identifier in
+ (* now we've got enough information to create our new subject in the pool *)
+ let subject_ref = Client.Subject.create ~rpc ~session_id ~subject_identifier ~other_config:subject_info in
+ let subject_uuid = Client.Subject.get_uuid rpc session_id subject_ref in
+ printer (Cli_printer.PList [subject_uuid])
let subject_remove printer rpc session_id params =
- (* we are removing by subject-uuid *)
- let subject_uuid = List.assoc "subject-uuid" params in
- let subject = Client.Subject.get_by_uuid ~rpc ~session_id ~uuid:subject_uuid in
- Client.Subject.destroy ~rpc ~session_id ~self:subject
+ (* we are removing by subject-uuid *)
+ let subject_uuid = List.assoc "subject-uuid" params in
+ let subject = Client.Subject.get_by_uuid ~rpc ~session_id ~uuid:subject_uuid in
+ Client.Subject.destroy ~rpc ~session_id ~self:subject
let subject_role_common rpc session_id params =
- let role_uuid = List.assoc_default "role-uuid" params "" in
- let role_name = List.assoc_default "role-name" params "" in
- if role_uuid="" && role_name=""
- then failwith "Required parameter not found: role-uuid or role-name"
- else
- if role_uuid<>"" && role_name<>""
- then failwith "Parameters role-uuid and role-name cannot be used together"
- else
- let subject_uuid = List.assoc "uuid" params in
- let role =
- if role_uuid<>""
- then Client.Role.get_by_uuid ~rpc ~session_id ~uuid:role_uuid
- else begin
- let roles = (Client.Role.get_by_name_label ~rpc ~session_id ~label:role_name) in
- if List.length roles > 0
- then List.hd roles (* names are unique, there's either 0 or 1*)
- else Ref.null (*role not found* raise (Api_errors.Server_error (Api_errors.role_not_found, []))*)
- end
- in
- let subject = Client.Subject.get_by_uuid ~rpc ~session_id ~uuid:subject_uuid in
- (subject,role)
+ let role_uuid = List.assoc_default "role-uuid" params "" in
+ let role_name = List.assoc_default "role-name" params "" in
+ if role_uuid="" && role_name=""
+ then failwith "Required parameter not found: role-uuid or role-name"
+ else
+ if role_uuid<>"" && role_name<>""
+ then failwith "Parameters role-uuid and role-name cannot be used together"
+ else
+ let subject_uuid = List.assoc "uuid" params in
+ let role =
+ if role_uuid<>""
+ then Client.Role.get_by_uuid ~rpc ~session_id ~uuid:role_uuid
+ else begin
+ let roles = (Client.Role.get_by_name_label ~rpc ~session_id ~label:role_name) in
+ if List.length roles > 0
+ then List.hd roles (* names are unique, there's either 0 or 1*)
+ else Ref.null (*role not found* raise (Api_errors.Server_error (Api_errors.role_not_found, []))*)
+ end
+ in
+ let subject = Client.Subject.get_by_uuid ~rpc ~session_id ~uuid:subject_uuid in
+ (subject,role)
let subject_role_add printer rpc session_id params =
- let (subject,role) = subject_role_common rpc session_id params in
- Client.Subject.add_to_roles ~rpc ~session_id ~self:subject ~role
+ let (subject,role) = subject_role_common rpc session_id params in
+ Client.Subject.add_to_roles ~rpc ~session_id ~self:subject ~role
let subject_role_remove printer rpc session_id params =
- let (subject,role) = subject_role_common rpc session_id params in
- Client.Subject.remove_from_roles ~rpc ~session_id ~self:subject ~role
+ let (subject,role) = subject_role_common rpc session_id params in
+ Client.Subject.remove_from_roles ~rpc ~session_id ~self:subject ~role
let audit_log_get fd printer rpc session_id params =
- let filename = List.assoc "filename" params in
- let since =
- if List.mem_assoc "since" params
+ let filename = List.assoc "filename" params in
+ let since =
+ if List.mem_assoc "since" params
then (* make sure since has a reasonable length *)
let unsanitized_since = List.assoc "since" params in
if String.length unsanitized_since > 255
then String.sub unsanitized_since 0 255
else unsanitized_since
else ""
- in
- let label = Printf.sprintf "audit-log-get%sinto file %s"
+ in
+ let label = Printf.sprintf "audit-log-get%sinto file %s"
(if since="" then " " else Printf.sprintf " (since \"%s\") " since)
(if String.length filename <= 255
- then filename (* make sure filename has a reasonable length in the logs *)
- else String.sub filename 0 255
+ then filename (* make sure filename has a reasonable length in the logs *)
+ else String.sub filename 0 255
)
in
let query =
if since="" then ""
else Printf.sprintf "since=%s" (Http.urlencode since)
in
- download_file_with_task
- fd rpc session_id filename Constants.audit_log_uri query label label
+ download_file_with_task
+ fd rpc session_id filename Constants.audit_log_uri query label label
(* RBAC 2.0 only
-let role_create printer rpc session_id params =
- (*let id = List.assoc "id" params in*)
- let name = List.assoc "name" params in
- ignore (Client.Role.create ~rpc ~session_id ~name ~description:"" ~permissions:[] ~is_basic:false ~is_complete:false)
-*)
+ let role_create printer rpc session_id params =
+(*let id = List.assoc "id" params in*)
+ let name = List.assoc "name" params in
+ ignore (Client.Role.create ~rpc ~session_id ~name ~description:"" ~permissions:[] ~is_basic:false ~is_complete:false)
+ *)
let session_subject_identifier_list printer rpc session_id params =
- let subject_identifiers = Client.Session.get_all_subject_identifiers ~rpc ~session_id in
- let table_of_subject_identifiers subject_identifier =
- [ "subject-identifier ( RO)", subject_identifier ]
- in
- let all = List.map table_of_subject_identifiers subject_identifiers in
- printer (Cli_printer.PTable all)
+ let subject_identifiers = Client.Session.get_all_subject_identifiers ~rpc ~session_id in
+ let table_of_subject_identifiers subject_identifier =
+ [ "subject-identifier ( RO)", subject_identifier ]
+ in
+ let all = List.map table_of_subject_identifiers subject_identifiers in
+ printer (Cli_printer.PTable all)
let session_subject_identifier_logout printer rpc session_id params =
- let subject_identifier = List.assoc "subject-identifier" params in
- Client.Session.logout_subject_identifier ~rpc ~session_id ~subject_identifier
+ let subject_identifier = List.assoc "subject-identifier" params in
+ Client.Session.logout_subject_identifier ~rpc ~session_id ~subject_identifier
let session_subject_identifier_logout_all printer rpc session_id params =
- let subject_identifiers = Client.Session.get_all_subject_identifiers ~rpc ~session_id in
- List.iter (fun subject_identifier -> Client.Session.logout_subject_identifier ~rpc ~session_id ~subject_identifier) subject_identifiers
+ let subject_identifiers = Client.Session.get_all_subject_identifiers ~rpc ~session_id in
+ List.iter (fun subject_identifier -> Client.Session.logout_subject_identifier ~rpc ~session_id ~subject_identifier) subject_identifiers
let secret_create printer rpc session_id params =
let value = List.assoc "value" params in
Client.Secret.destroy ~rpc ~session_id ~self:ref
let regenerate_built_in_templates printer rpc session_id params =
- Create_templates.create_all_templates rpc session_id
+ Create_templates.create_all_templates rpc session_id
let vmpp_create printer rpc session_id params =
let get ?default param_name =
| Some default_value -> default_value
| None -> failwith ("No default value for parameter "^param_name)
in
- let map param_name ?default xmlrpc_to_type api_from_type =
+ let map param_name ?default xmlrpc_to_type api_from_type =
api_from_type param_name (xmlrpc_to_type (get ?default param_name))
in
let name_label = List.assoc "name-label" params in
let backup_type = map "backup-type" XMLRPC.To.string API.From.vmpp_backup_type in
let backup_frequency = map "backup-frequency" XMLRPC.To.string API.From.vmpp_backup_frequency in
let backup_schedule = read_map_params "backup-schedule" params in
- (* optional parameters with default values *)
+ (* optional parameters with default values *)
let name_description = get "name-description" ~default:"" in
let is_policy_enabled = Record_util.bool_of_string(get "is-policy-enabled" ~default:"true") in
- let backup_retention_value = map "backup-retention-value" ~default:"7" XMLRPC.To.string API.From.int64 in
+ let backup_retention_value = map "backup-retention-value" ~default:"7" XMLRPC.To.string API.From.int64 in
let archive_frequency = map "archive-frequency" ~default:"never" XMLRPC.To.string API.From.vmpp_archive_frequency in
let archive_target_type = map "archive-target-type" ~default:"none" XMLRPC.To.string API.From.vmpp_archive_target_type in
let archive_target_config = read_map_params "archive-target-config" params in
let alarm_config = read_map_params "alarm-config" params in
let ref = Client.VMPP.create ~rpc ~session_id ~name_label ~name_description
~is_policy_enabled ~backup_type ~backup_retention_value ~backup_frequency
- ~backup_schedule ~archive_target_type
- ~archive_target_config ~archive_frequency ~archive_schedule
- ~is_alarm_enabled ~alarm_config
+ ~backup_schedule ~archive_target_type
+ ~archive_target_config ~archive_frequency ~archive_schedule
+ ~is_alarm_enabled ~alarm_config
in
- let uuid = Client.VMPP.get_uuid ~rpc ~session_id ~self:ref in
- printer (Cli_printer.PList [uuid])
+ let uuid = Client.VMPP.get_uuid ~rpc ~session_id ~self:ref in
+ printer (Cli_printer.PList [uuid])
let vmpp_destroy printer rpc session_id params =
let uuid = List.assoc "uuid" params in
projects / xcp / xen-api.git / commitdiff