Skip to content

Commit

Permalink
Merge pull request #5570 from psafont/xn
Browse files Browse the repository at this point in the history
  • Loading branch information
@psafont
psafont committed Apr 19, 2024
2 parents 2d5f9a7 + f753ee2 commit 21721ad
Show file tree
Hide file tree
Showing 3 changed files with 73 additions and 298 deletions.
297 changes: 0 additions & 297 deletions ocaml/xenopsd/cli/xn.ml
View file
Expand Up @@ -65,74 +65,6 @@ let diagnose_error f =
exit 1
)

let usage () =
Printf.fprintf stderr
"%s <command> [args] - send commands to the xenops daemon\n" Sys.argv.(0) ;
Printf.fprintf stderr "%s add <config> - add a VM from <config>\n"
Sys.argv.(0) ;
Printf.fprintf stderr "%s list [verbose] - query the states of known VMs\n"
Sys.argv.(0) ;
Printf.fprintf stderr "%s remove <name or id> - forget about a VM\n"
Sys.argv.(0) ;
Printf.fprintf stderr "%s start <name or id> [paused] - start a VM\n"
Sys.argv.(0) ;
Printf.fprintf stderr "%s pause <name or id> - pause a VM\n" Sys.argv.(0) ;
Printf.fprintf stderr "%s unpause <name or id> - unpause a VM\n" Sys.argv.(0) ;
Printf.fprintf stderr "%s shutdown <name or id> - shutdown a VM\n"
Sys.argv.(0) ;
Printf.fprintf stderr "%s reboot <name or id> - reboot a VM\n" Sys.argv.(0) ;
Printf.fprintf stderr "%s suspend <name or id> <disk> - suspend a VM\n"
Sys.argv.(0) ;
Printf.fprintf stderr "%s resume <name or id> <disk> - resume a VM\n"
Sys.argv.(0) ;
Printf.fprintf stderr
"%s migrate <name or id> <url> - migrate a VM to <url>\n" Sys.argv.(0) ;
Printf.fprintf stderr
"%s vbd-list <name or id> - query the states of a VM's block devices\n"
Sys.argv.(0) ;
Printf.fprintf stderr
"%s console-list <name or id> - query the states of a VM's consoles\n"
Sys.argv.(0) ;
Printf.fprintf stderr
"%s pci-add <name or id> <number> <bdf> - associate the PCI device <bdf> \
with <name or id>\n"
Sys.argv.(0) ;
Printf.fprintf stderr
"%s pci-remove <name or id> <number> - disassociate the PCI device <bdf> \
with <name or id>\n"
Sys.argv.(0) ;
Printf.fprintf stderr
"%s pci-list <name or id> - query the states of a VM's PCI devices\n"
Sys.argv.(0) ;
Printf.fprintf stderr "%s cd-insert <id> <disk> - insert a CD into a VBD\n"
Sys.argv.(0) ;
Printf.fprintf stderr "%s cd-eject <id> - eject a CD from a VBD\n"
Sys.argv.(0) ;
Printf.fprintf stderr
"%s export-metadata <id> - export metadata associated with <id>\n"
Sys.argv.(0) ;
Printf.fprintf stderr
"%s export-metadata-xm <id> - export metadata associated with <id> in xm \
format\n"
Sys.argv.(0) ;
Printf.fprintf stderr
"%s delay <id> <time> - add an explicit delay of length <time> to this \
VM's queue\n"
Sys.argv.(0) ;
Printf.fprintf stderr
"%s events-watch - display all events generated by the server\n"
Sys.argv.(0) ;
Printf.fprintf stderr
"%s set-worker-pool-size <threads> - set the size of the worker pool\n"
Sys.argv.(0) ;
Printf.fprintf stderr "%s diagnostics - display diagnostic information\n"
Sys.argv.(0) ;
Printf.fprintf stderr "%s task-list - display the state of all known tasks\n"
Sys.argv.(0) ;
Printf.fprintf stderr "%s shutdown - shutdown the xenops service\n"
Sys.argv.(0) ;
()

let dbg = "xn"

let finally = Xapi_stdext_pervasives.Pervasiveext.finally
Expand Down Expand Up @@ -905,12 +837,6 @@ let export copts metadata xm filename (x : Vm.id option) () =
let export copts metadata xm filename x =
diagnose_error (export copts metadata xm filename x)

let delay x t =
let vm, _ = find_by_name x in
Client.VM.delay dbg vm.Vm.id t
|> wait_for_task dbg
|> success_task ignore_task

let import_metadata _copts filename =
let ic = open_in filename in
let buf = Buffer.create 128 in
Expand Down Expand Up @@ -1014,99 +940,6 @@ let resume _copts disk x =

let resume copts disk x = diagnose_error (need_vm (resume copts disk) x)

let migrate ~id ~url ~compress ~verify_dest =
let vm, _ = find_by_name id in
let bool b =
match String.lowercase_ascii b with
| "t" | "true" | "on" | "1" ->
true
| _ ->
false
in
Client.VM.migrate dbg vm.Vm.id [] [] [] url (bool compress) (bool verify_dest)
|> wait_for_task dbg

let trim limit str =
let l = String.length str in
if l < limit then
str
else
"..." ^ String.sub str (l - limit + 3) (limit - 3)

let vbd_list x =
let vm, _ = find_by_name x in
let vbds = Client.VBD.list dbg vm.Vm.id in
let line id position mode ty plugged disk disk2 =
Printf.sprintf "%-10s %-8s %-4s %-5s %-7s %-35s %-35s " id position mode ty
plugged disk disk2
in
let header =
line "id" "position" "mode" "type" "plugged" "disk" "xenstore_disk"
in
let lines =
List.map
(fun (vbd, state) ->
let id = snd vbd.Vbd.id in
let position =
match vbd.Vbd.position with
| None ->
"None"
| Some x ->
Device_number.to_linux_device x
in
let mode = if vbd.Vbd.mode = Vbd.ReadOnly then "RO" else "RW" in
let ty =
match vbd.Vbd.ty with
| Vbd.CDROM ->
"CDROM"
| Vbd.Floppy ->
"Floppy"
| Vbd.Disk ->
"HDD"
in
let plugged = if state.Vbd.plugged then "X" else " " in
let disk =
match vbd.Vbd.backend with
| None ->
""
| Some (Local x) ->
x |> trim 32
| Some (VDI path) ->
path |> trim 32
in
let info = Client.VBD.stat dbg vbd.Vbd.id in
let disk2 =
match (snd info).Vbd.backend_present with
| None ->
""
| Some (Local x) ->
x |> trim 32
| Some (VDI path) ->
path |> trim 32
in
line id position mode ty plugged disk disk2
)
vbds
in
List.iter print_endline (header :: lines)

let console_list _copts x =
let _, s = find_by_name x in
Printf.fprintf stderr "json=[%s]\n%!" (Jsonrpc.to_string (rpc_of Vm.state s)) ;
let line protocol port = Printf.sprintf "%-10s %-6s" protocol port in
let header = line "protocol" "port" in
let lines =
List.map
(fun c ->
let protocol =
match c.Vm.protocol with Vm.Rfb -> "RFB" | Vm.Vt100 -> "VT100"
in
line protocol (string_of_int c.Vm.port)
)
s.Vm.consoles
in
List.iter print_endline (header :: lines)

let raw_console_proxy sockaddr =
let long_connection_retry_timeout = 5. in
let with_raw_mode f =
Expand Down Expand Up @@ -1346,49 +1179,6 @@ let create copts x console () =

let create copts console x = diagnose_error (create copts console x)

let pci_add x idx bdf =
let vm, _ = find_by_name x in
let open Pci in
let domain, bus, dev, fn =
Scanf.sscanf bdf "%04x:%02x:%02x.%1x" (fun a b c d -> (a, b, c, d))
in
let address = {domain; bus; dev; fn} in
let id =
Client.PCI.add dbg
{
id= (vm.Vm.id, idx)
; position= int_of_string idx
; address
; msitranslate= None
; power_mgmt= None
}
in
Printf.printf "%s.%s\n" (fst id) (snd id)

let pci_remove x idx =
let vm, _ = find_by_name x in
Client.PCI.remove dbg (vm.Vm.id, idx)

let pci_list x =
let vm, _ = find_by_name x in
let pcis = Client.PCI.list dbg vm.Vm.id in
let line id bdf = Printf.sprintf "%-10s %-3s %-12s" id bdf in
let header = line "id" "pos" "bdf" in
let lines =
List.map
(fun (pci, _state) ->
let open Pci in
let id = snd pci.id in
let bdf =
Printf.sprintf "%04x:%02x:%02x.%01x" pci.address.domain
pci.address.bus pci.address.dev pci.address.fn
in
line id (string_of_int pci.position) bdf
)
pcis
in
List.iter print_endline (header :: lines)

let find_vbd id =
let vbd_id : Vbd.id =
match Re.Str.bounded_split_delim (Re.Str.regexp "[.]") id 2 with
Expand Down Expand Up @@ -1454,8 +1244,6 @@ let rec events_watch from =

let events _copts = events_watch None

let set_worker_pool_size size = Client.HOST.set_worker_pool_size dbg size

let print_date float =
let time = Unix.gmtime float in
Printf.sprintf "%04d%02d%02dT%02d:%02d:%02dZ" (time.Unix.tm_year + 1900)
Expand Down Expand Up @@ -1484,88 +1272,3 @@ let task_cancel _ = function
`Error (true, "Please supply a task id")
| Some id ->
Client.TASK.cancel dbg id ; `Ok ()

let debug_shutdown () = Client.DEBUG.shutdown dbg ()

let verbose_task t =
let string_of_state = function
| Task.Completed t ->
Printf.sprintf "%.2f" t.Task.duration
| Task.Failed x ->
Printf.sprintf "Error: %s" (x |> Jsonrpc.to_string)
| Task.Pending _ ->
Printf.sprintf "Error: still pending"
in
let rows =
List.map
(fun (name, state) -> [name; string_of_state state])
t.Task.subtasks
in
let rows = rows @ List.map (fun (k, v) -> [k; v]) t.Task.debug_info in
Table.print rows ;
Printf.printf "\n" ;
Printf.printf "Overall: %s\n" (string_of_state t.Task.state)

let old_main () =
let args = Sys.argv |> Array.to_list |> List.tl in
let verbose = List.mem "-v" args in
let args = List.filter (fun x -> x <> "-v") args in
(* Extract any -path X argument *)
let extract args key =
let result = ref None in
let args =
List.fold_left
(fun (acc, foundit) x ->
if foundit then (
result := Some x ;
(acc, false)
) else if x = key then
(acc, true)
else
(x :: acc, false)
)
([], false) args
|> fst
|> List.rev
in
(!result, args)
in
let path, args = extract args "-path" in
( match path with
| Some path ->
Xenops_interface.set_sockets_dir path
| None ->
()
) ;
let task = success_task (if verbose then verbose_task else ignore_task) in
match args with
| ["help"] | [] ->
usage () ; exit 0
| ["migrate"; id; url] ->
migrate ~id ~url ~compress:"false" ~verify_dest:"false" |> task
| ["migrate"; id; url; compress] ->
migrate ~id ~url ~compress ~verify_dest:"false" |> task
| ["migrate"; id; url; compress; verify_dest] ->
migrate ~id ~url ~compress ~verify_dest |> task
| ["vbd-list"; id] ->
vbd_list id
| ["pci-add"; id; idx; bdf] ->
pci_add id idx bdf
| ["pci-remove"; id; idx] ->
pci_remove id idx
| ["pci-list"; id] ->
pci_list id
| ["cd-insert"; id; disk] ->
cd_insert id disk |> task
| ["delay"; id; t] ->
delay id (float_of_string t)
| ["events-watch"] ->
events_watch None
| ["set-worker-pool-size"; size] ->
set_worker_pool_size (int_of_string size)
| ["shutdown"] ->
debug_shutdown ()
| cmd :: _ ->
Printf.fprintf stderr "Unrecognised command: %s\n" cmd ;
usage () ;
exit 1

0 comments on commit 21721ad

Please sign in to comment.