From b64cf8e133089a82996beb01402eb504eb30ac38 Mon Sep 17 00:00:00 2001 From: "rjones@thinkpad" Date: Thu, 1 May 2008 19:52:35 +0100 Subject: [PATCH] Random changes. --- configure.ac | 10 + virt-ctrl/.depend | 12 +- virt-ctrl/Makefile.in | 3 +- virt-ctrl/vc_connection_dlg.mli | 2 +- virt-ctrl/vc_connections.ml | 50 +++- virt-ctrl/vc_connections.mli | 6 + virt-ctrl/vc_install_dlg.ml | 611 ++++++++++++++++++++++++++++++++++++++++ virt-ctrl/vc_install_dlg.mli | 23 ++ virt-ctrl/vc_mainwindow.ml | 57 +++- 9 files changed, 754 insertions(+), 20 deletions(-) create mode 100644 virt-ctrl/vc_install_dlg.ml create mode 100644 virt-ctrl/vc_install_dlg.mli diff --git a/configure.ac b/configure.ac index d777be6..86bea59 100644 --- a/configure.ac +++ b/configure.ac @@ -70,6 +70,16 @@ if test "x$pkg_lablgtk2" != "xyes"; then AC_MSG_ERROR([Cannot find required OCaml package 'lablgtk2']) fi +AC_CHECK_OCAML_PKG(xml-light) +if test "x$pkg_xml_light" != "xyes"; then + AC_MSG_ERROR([Cannot find required OCaml package 'xml-light']) +fi + +AC_CHECK_OCAML_PKG(extlib) +if test "x$pkg_extlib" != "xyes"; then + AC_MSG_ERROR([Cannot find required OCaml package 'extlib']) +fi + dnl Check for optional OCaml packages. AC_CHECK_OCAML_PKG(gettext) AC_CHECK_OCAML_PKG(dbus) diff --git a/virt-ctrl/.depend b/virt-ctrl/.depend index 28ac5c2..572479d 100644 --- a/virt-ctrl/.depend +++ b/virt-ctrl/.depend @@ -14,9 +14,13 @@ vc_helpers.cmo: virt_ctrl_gettext.cmo vc_helpers.cmi vc_helpers.cmx: virt_ctrl_gettext.cmx vc_helpers.cmi vc_icons.cmo: vc_connection_dlg.cmi vc_icons.cmx: vc_connection_dlg.cmx -vc_mainwindow.cmo: virt_ctrl_gettext.cmo vc_connections.cmi \ - vc_connection_dlg.cmi vc_mainwindow.cmi -vc_mainwindow.cmx: virt_ctrl_gettext.cmx vc_connections.cmx \ - vc_connection_dlg.cmx vc_mainwindow.cmi +vc_install_dlg.cmo: virt_ctrl_gettext.cmo vc_connections.cmi \ + vc_install_dlg.cmi +vc_install_dlg.cmx: virt_ctrl_gettext.cmx vc_connections.cmx \ + vc_install_dlg.cmi +vc_mainwindow.cmo: virt_ctrl_gettext.cmo vc_install_dlg.cmi \ + vc_connections.cmi vc_connection_dlg.cmi vc_mainwindow.cmi +vc_mainwindow.cmx: virt_ctrl_gettext.cmx vc_install_dlg.cmx \ + vc_connections.cmx vc_connection_dlg.cmx vc_mainwindow.cmi virt_ctrl.cmo: virt_ctrl_gettext.cmo vc_mainwindow.cmi vc_domain_ops.cmi virt_ctrl.cmx: virt_ctrl_gettext.cmx vc_mainwindow.cmx vc_domain_ops.cmx diff --git a/virt-ctrl/Makefile.in b/virt-ctrl/Makefile.in index 625afda..5b7d44c 100644 --- a/virt-ctrl/Makefile.in +++ b/virt-ctrl/Makefile.in @@ -37,9 +37,10 @@ OBJS := \ vc_connections.cmo \ vc_domain_ops.cmo \ vc_connection_dlg.cmo \ + vc_install_dlg.cmo \ vc_mainwindow.cmo -OCAMLCPACKAGES := -package unix,lablgtk2,libvirt +OCAMLCPACKAGES := -package unix,lablgtk2,libvirt,extlib,xml-light ifeq ($(pkg_dbus),yes) OCAMLCPACKAGES += -package dbus OBJS += vc_dbus.cmo diff --git a/virt-ctrl/vc_connection_dlg.mli b/virt-ctrl/vc_connection_dlg.mli index 0102713..83d4694 100644 --- a/virt-ctrl/vc_connection_dlg.mli +++ b/virt-ctrl/vc_connection_dlg.mli @@ -16,7 +16,7 @@ along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - Make the main window. + The connection dialog. *) (** The connection dialog. *) diff --git a/virt-ctrl/vc_connections.ml b/virt-ctrl/vc_connections.ml index 03d06ac..5d9e22c 100644 --- a/virt-ctrl/vc_connections.ml +++ b/virt-ctrl/vc_connections.ml @@ -46,7 +46,7 @@ let get_conns, add_conn, del_conn = (* Store the node_info and hostname for each connection, fetched * once just after we connect since these don't normally change. - * Hash of connid -> (C.node_info, hostname option, uri) + * Hash of connid -> (C.node_info, hostname option, uri, capabilities) *) let static_conn_info = Hashtbl.create 13 @@ -56,16 +56,48 @@ let open_connection uri = *) let conn = C.connect ~name:uri () in + (* Get the static info from the connection. *) let node_info = C.get_node_info conn in let hostname = try Some (C.get_hostname conn) with - | Libvirt.Not_supported "virConnectGetHostname" - | Libvirt.Virterror _ -> None in + | Libvirt.Not_supported "virConnectGetHostname" -> None + | Libvirt.Virterror err -> + prerr_endline (Libvirt.Virterror.to_string err); + None in + let capabilities = + try + let caps = C.get_capabilities conn in + let caps = Xml.parse_string caps in + Some caps + with + | Libvirt.Not_supported "virConnectGetCapabilities" -> None + | Libvirt.Virterror err -> + prerr_endline (Libvirt.Virterror.to_string err); + None + | Xml.Error err -> + prerr_endline (Xml.error err); + None in (* Add it to our list of connections. *) let conn_id = add_conn conn in - Hashtbl.add static_conn_info conn_id (node_info, hostname, uri) + Hashtbl.add static_conn_info conn_id (node_info, hostname, uri, capabilities) + +let get_node_info conn_id = + let node_info, _, _, _ = Hashtbl.find static_conn_info conn_id in + node_info + +let get_hostname conn_id = + let _, hostname, _, _ = Hashtbl.find static_conn_info conn_id in + hostname + +let get_uri conn_id = + let _, _, uri, _ = Hashtbl.find static_conn_info conn_id in + uri + +let get_capabilities conn_id = + let _, _, _, capabilities = Hashtbl.find static_conn_info conn_id in + capabilities (* Stores the state and history for each domain. * Hash of (connid, domid) -> mutable domhistory structure. @@ -116,7 +148,7 @@ and inactive = string (* domain's name *) *) type columns = string GTree.column * string GTree.column * string GTree.column * string GTree.column * string GTree.column * int GTree.column -let debug_repopulate = true +let debug_repopulate = false (* Populate the tree with the current list of connections, domains. * This function is called once per second. @@ -148,9 +180,9 @@ let repopulate (tree : GTree.view) (model : GTree.tree_store) let row = model#append () in (* Get the connection name, usually the hostname. *) let name = - match Hashtbl.find static_conn_info conn_id with - | (_, Some hostname, _) -> hostname - | (_, None, _) -> sprintf "Conn #%d" conn_id in + match get_hostname conn_id with + | Some hostname -> hostname + | None -> sprintf "Conn #%d" conn_id in model#set ~row ~column:col_name_id name; model#set ~row ~column:col_id conn_id; (* Expand the new row. *) @@ -178,7 +210,7 @@ let repopulate (tree : GTree.view) (model : GTree.tree_store) try (* Number of CPUs available. *) - let node_info, _, _ = Hashtbl.find static_conn_info conn_id in + let node_info = get_node_info conn_id in let nr_cpus = C.maxcpus_of_node_info node_info in (* For this connection, get a current list of active domains (IDs) *) diff --git a/virt-ctrl/vc_connections.mli b/virt-ctrl/vc_connections.mli index 261f853..0fe7fa5 100644 --- a/virt-ctrl/vc_connections.mli +++ b/virt-ctrl/vc_connections.mli @@ -48,6 +48,12 @@ val make_treeview : (** Open a new connection to the hypervisor URI given. *) val open_connection : string -> unit +(** Get node info, hostname, URI and capabilities from a connection. *) +val get_node_info : int -> Libvirt.Connect.node_info +val get_hostname : int -> string option +val get_uri : int -> string +val get_capabilities : int -> Xml.xml option + (** Return the amount of historical data that we hold about a domain (in seconds). diff --git a/virt-ctrl/vc_install_dlg.ml b/virt-ctrl/vc_install_dlg.ml new file mode 100644 index 0000000..f5758e5 --- /dev/null +++ b/virt-ctrl/vc_install_dlg.ml @@ -0,0 +1,611 @@ +(* virt-ctrl: A graphical management tool. + (C) Copyright 2007 Richard W.M. Jones, Red Hat Inc. + http://libvirt.org/ + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +*) + +open Printf +open Unix +open ExtList +open Xml + +open Virt_ctrl_gettext.Gettext + +let (//) = Filename.concat + +type virt_type = + | VT_HVM | VT_Xen | UnknownVirtType +type arch = + | I386 | X86_64 | IA64 | PPC | PPC64 | SPARC | SPARC64 + | OtherArch of string + | UnknownArch +type hv_name = (* implicitly ordered worst->best *) + | UnknownHVType | QEMU | Xen | KVM + +(* List of supported distros. The name field must be unique but + * doesn't need to be constant. + *) +let distros = [ + "Fedora 8 (i386, 32 bit, Xen paravirtualized)", ( + VT_Xen, I386 + ); + "Fedora 8 (i386, 32 bit, fully virtualized)", ( + VT_HVM, I386 + ); + "Fedora 8 (x86-64, 64 bit, Xen paravirtualized)", ( + VT_Xen, X86_64 + ); + "Fedora 8 (x86-64, 64 bit, fully virtualized)", ( + VT_HVM, X86_64 + ); + "Fedora 9 (i386, 32 bit, Xen paravirtualized)", ( + VT_Xen, I386 + ); + "Fedora 9 (i386, 32 bit, fully virtualized)", ( + VT_HVM, I386 + ); + "Fedora 9 (x86-64, 64 bit, Xen paravirtualized)", ( + VT_Xen, X86_64 + ); + "Fedora 9 (x86-64, 64 bit, fully virtualized)", ( + VT_HVM, X86_64 + ); +] + +let string_of_virt_type = function + | VT_HVM -> "hvm" + | VT_Xen -> "xen" + | UnknownVirtType -> invalid_arg "string_of_virt_type" + +let string_of_architecture = function + | I386 -> "i386" + | X86_64 -> "x86_64" + | IA64 -> "ia64" + | PPC -> "ppc" + | PPC64 -> "ppc64" + | SPARC -> "sparc" + | SPARC64 -> "sparc64" + | OtherArch arch -> arch + | UnknownArch -> invalid_arg "string_of_architecture" + +let architecture_of_string = function + | str when + String.length str = 4 && + (str.[0] = 'i' || str.[0] = 'I') && + (str.[1] >= '3' && str.[1] <= '6') && + str.[2] = '8' && str.[3] = '6' -> I386 + | "x86_64" | "X86_64" | "x86-64" | "X86-64" -> X86_64 + | "ia64" | "IA64" -> IA64 + | "ppc" | "PPC" | "ppc32" | "PPC32" -> PPC + | "ppc64" | "PPC64" -> PPC64 + | "sparc" | "SPARC" | "sparc32" | "SPARC32" -> SPARC + | "sparc64" | "SPARC64" -> SPARC64 + | str -> OtherArch str + +let string_of_hv_name = function + | Xen -> "Xen" + | QEMU -> "QEMU" + | KVM -> "KVM" + | UnknownHVType -> "unknown" + +(* Choose a disk location for images. + * This changed in libvirt 0.4.something. + *) +let disk_location = + let dirs = [ + "/var/lib/libvirt/images"; + "/var/lib/libvirt/xen"; + ] in + let dirs = + try dirs @ [Sys.getenv "HOME"] + with Not_found -> dirs in + try + List.find ( + fun d -> + try (stat d).st_kind = S_DIR + with Unix_error _ -> false + ) dirs + with + Not_found -> "/var/tmp" + +type edit_status = UserEdit | ProgramEdit | Disconnected + +let rec find_map f = function + | [] -> raise Not_found + | x :: xs -> + match f x with + | Some y -> y + | None -> find_map f xs + +(* Install guest dialog. *) +let rec install_guest parent conn_id () = + let title = s_"Install new guest" in + let position = `CENTER_ON_PARENT in + + let dlg = GWindow.dialog ~title ~position ~parent ~modal:true () in + + (* We will enter the Gtk main loop recursively. Wire up close and + * other buttons to quit the recursive main loop. + *) + ignore (dlg#connect#destroy ~callback:GMain.quit); + ignore (dlg#event#connect#delete + ~callback:(fun _ -> GMain.quit (); false)); + + (* Action area. *) + let cancel_button = + GButton.button ~label:(s_"Cancel") ~packing:dlg#action_area#pack () in + ignore (cancel_button#connect#clicked ~callback:dlg#destroy); + + let install_button = + GButton.button ~label:(s_"Install") ~packing:dlg#action_area#pack () in + + (* Connections. *) + let conns = get_connections () in + + let frame = + GBin.frame ~label:(s_"Hypervisor connection") + ~packing:dlg#vbox#pack () in + let hbox = GPack.hbox ~packing:frame#add () in + + ignore (GMisc.label ~text:(s_"Connection:") ~xalign:1.0 + ~packing:hbox#pack ()); + + let conn_combo, (conn_model : GTree.list_store), conn_col_id, conn_active = + populate_conns conns hbox#pack conn_id in + + (* Distro. *) + let frame = + GBin.frame ~label:(s_"Operating system") ~packing:dlg#vbox#pack () in + + let (distro_combo, (distro_list, distro_col_name)) = + GEdit.combo_box_text ~packing:frame#add () in + + (* VM name. *) + let frame = + GBin.frame ~label:(s_"Guest details") ~packing:dlg#vbox#pack () in + + let tbl = GPack.table ~columns:3 ~rows:5 ~packing:frame#add () in + + ignore (GMisc.label ~text:(s_"Name:") ~xalign:1.0 + ~packing:(tbl#attach ~top:0 ~left:0) ()); + let name_entry = + GEdit.entry ~width_chars:32 + ~packing:(tbl#attach ~top:0 ~left:1) () in + + (* Disk image. *) + ignore (GMisc.label ~text:(s_"Disk image:") ~xalign:1.0 + ~packing:(tbl#attach ~top:1 ~left:0) ()); + let disk_entry = + GEdit.entry ~width_chars:48 + ~packing:(tbl#attach ~top:1 ~left:1) () in + let hbox = GPack.hbox ~packing:(tbl#attach ~top:1 ~left:2) () in + let disk_size = + GEdit.spin_button ~numeric:true ~digits:1 + ~packing:hbox#pack () in + disk_size#adjustment#set_bounds ~lower:2.0 ~upper:999.0 ~step_incr:0.5 (); + disk_size#adjustment#set_value 8.0; + ignore (GMisc.label ~text:" GB" ~packing:hbox#pack ()); + + (* Network. *) + ignore (GMisc.label ~text:(s_"Network:") ~xalign:1.0 + ~packing:(tbl#attach ~top:2 ~left:0) ()); + let (net_combo, _) = + GEdit.combo_box_text + ~strings:["default"] (* XXX not implemented *) + ~packing:(tbl#attach ~top:2 ~left:1) () in + net_combo#set_active 0; + + (* RAM. *) + ignore (GMisc.label ~text:(s_"RAM:") ~xalign:1.0 + ~packing:(tbl#attach ~top:3 ~left:0) ()); + let hbox = GPack.hbox ~packing:(tbl#attach ~top:3 ~left:1) () in + let ram = + GEdit.spin_button ~numeric:true ~digits:0 + ~packing:hbox#pack () in + ram#adjustment#set_bounds ~lower:128.0 ~upper:131_072.0 ~step_incr:32.0 (); + ram#adjustment#set_value 512.0; + ignore (GMisc.label ~text:" MB" ~packing:hbox#pack ()); + + (* CPUs. *) + ignore (GMisc.label ~text:(s_"CPUs:") ~xalign:1.0 + ~packing:(tbl#attach ~top:4 ~left:0) ()); + let hbox = GPack.hbox ~packing:(tbl#attach ~top:4 ~left:1) () in + let vcpus = + GEdit.spin_button ~numeric:true ~digits:0 + ~packing:hbox#pack () in + vcpus#adjustment#set_bounds ~lower:1.0 ~upper:4.0 ~step_incr:1.0 (); + vcpus#adjustment#set_value 1.0; + + let () = + (* When connection combo changes we need to repopulate list of distros. *) + ignore ( + conn_combo#connect#changed + ~callback:( + fun () -> + repopulate_distros conns conn_combo conn_model conn_col_id + distro_combo distro_list distro_col_name + ) + ); + + (* When distro changes we need to change the name, provided the name + * hasn't been edited by the user (in which case we leave it alone). + * + * We have to use a shared reference so that we don't disconnect + * the signal when we are editing the field (not the user). Ugh ... + *) + let edit_status = ref UserEdit in + let distro_changed_id = + distro_combo#connect#changed + ~callback:( + fun () -> + let row = distro_combo#active_iter in + match row with + | None -> () (* no distro selected *) + | Some row -> + let name = distro_list#get ~row ~column:distro_col_name in + let name = short_name_of_distro name in + + let old_status = !edit_status in + edit_status := ProgramEdit; + name_entry#set_text name; + disk_entry#set_text (disk_location // name ^ ".img"); + edit_status := old_status + ) in + + ignore ( + name_entry#connect#changed ~callback:( + fun () -> + if !edit_status = UserEdit then ( + distro_combo#misc#disconnect distro_changed_id; + edit_status := Disconnected (* prevent multiple disconnections *) + ) + ) + ); + + ignore ( + disk_entry#connect#changed ~callback:( + fun () -> + if !edit_status = UserEdit then ( + distro_combo#misc#disconnect distro_changed_id; + edit_status := Disconnected (* prevent multiple disconnections *) + ) + ) + ); + + (* Wire up the install button. *) + ignore ( + install_button#connect#clicked ~callback:( + fun () -> + (* Get the required settings. *) + let conn_id = + match conn_combo#active_iter with + | None -> (* no connection selected *) + invalid_arg (s_"No connection selected") + | Some row -> + conn_model#get ~row ~column:conn_col_id in + let distro = + match distro_combo#active_iter with + | None -> (* no distro selected *) + invalid_arg (s_"No operating system selected") + | Some row -> + distro_list#get ~row ~column:distro_col_name in + let name = name_entry#text in + let disk = disk_entry#text in + let disk_size = disk_size#value in + let net = "default" (* XXX network not implemented *) in + let ram = ram#value_as_int in + let vcpus = vcpus#value_as_int in + + dlg#destroy (); + start_install parent conns + conn_id distro name disk disk_size net ram vcpus + ) + ) in + + (* See combobox.ml example in %doc directory. + * NB. Don't use ~active label above. It is buggy and won't trigger + * the selection callback. + *) + conn_combo#set_active conn_active; + + (* Set focus on the distro. *) + distro_combo#misc#grab_focus (); + + dlg#show (); + + (* Enter Gtk main loop recursively. *) + GMain.main () + +(* Populate the list of connections. *) +and populate_conns conns packing conn_id = + (* Model/columns. *) + let cols = new GTree.column_list in + let col_name = cols#add Gobject.Data.string in + let col_id = cols#add Gobject.Data.int in + let model = GTree.list_store cols in + + (* View. *) + let conn_combo = GEdit.combo_box ~model ~packing () in + + let renderer = GTree.cell_renderer_text [] in + conn_combo#pack renderer; + ignore (conn_combo#add_attribute renderer "text" col_name); + + (* Populate the connection combo box. *) + let active = ref 0 in + List.iteri ( + fun i (id, (conn, hostname, guests)) -> + if id = conn_id then active := i; + + let name = + (* Get unique list of all HV types supported. *) + let hvs = List.map (fun (_, _, domains) -> domains) guests in + let hvs = List.concat hvs in + let hvs = List.map fst hvs in + let hvs = List.unique hvs in + let hvs = List.sort hvs in + + (* Make a printable string for this connection. *) + sprintf "%s (%s)" hostname + (String.concat "/" (List.map string_of_hv_name hvs)) in + + let row = model#append () in + model#set ~row ~column:col_name name; + model#set ~row ~column:col_id conn_id + ) conns; + + conn_combo, model, col_id, !active + +(* When connection combo selection changes, repopulate list of distros. *) +and repopulate_distros conns conn_combo conn_model conn_col_id + distro_combo distro_list distro_col_name = + (* Clear the distro list. *) + distro_list#clear (); + + let row = conn_combo#active_iter in + match row with + | None -> () (* no connection selected *) + | Some row -> + let conn_id = conn_model#get ~row ~column:conn_col_id in + let conn, hostname, guests = List.assoc conn_id conns in + + (* Get the distros which match one of the guest types. *) + let distros = List.map get_matching_distros guests in + let distros = List.concat distros in + let distros = List.unique distros in + let distros = List.sort distros in + + (* Populate the list with distros which match. *) + List.iter ( + fun (name, _) -> + let row = distro_list#append () in + distro_list#set ~row ~column:distro_col_name name + ) distros; + + if List.length distros > 0 then distro_combo#set_active 0 + +and get_matching_distros (virt_type, arch, domains) = + List.filter ( + fun (_, (virt_type', arch')) -> + virt_type = virt_type' && arch = arch' + ) distros + +(* Get a short name from the selected distro's name. *) +and short_name_of_distro name = + let len = String.length name in + let buf = Buffer.create 16 in + let rec loop i = + if i < len then ( + let c = name.[i] in + match c with + | 'A' .. 'Z' -> + Buffer.add_char buf (Char.chr (Char.code c + 0x20)); + loop (i+1) + | 'a' .. 'z' | '0' .. '9' -> + Buffer.add_char buf c; + loop (i+1) + | '(' -> () (* stop at first '(' character *) + | _ -> loop (i+1) + ) + in + loop 0; + Buffer.contents buf + +(* Get connection details, mainly from the capabilities XML. *) +and get_connections () = + let conns = Vc_connections.get_conns () in + List.map ( + fun (conn_id, conn) -> + let hostname = + match Vc_connections.get_hostname conn_id with + | Some hostname -> hostname + | None -> sprintf "Conn #%d" conn_id in + + (* Get some idea of what the hypervisor supports. *) + let guests = + let caps = Vc_connections.get_capabilities conn_id in + match caps with + | Some (Element ("capabilities", _, children)) -> + List.filter_map ( + function + | Element ("guest", _, children) -> Some children + | _ -> None + ) children + | _ -> [] in (* XXX should do better if no caps *) + + let guests = + List.map ( + fun guest -> + let os_type = + try + find_map ( + function + | Element ("os_type", _, [PCData "hvm"]) -> Some VT_HVM + | Element ("os_type", _, [PCData "xen"]) -> Some VT_Xen + | _ -> None + ) guest + with + Not_found -> UnknownVirtType in + + let arch, domains = + try + find_map ( + function + | Element ("arch", attrs, children) -> + let arch = + try architecture_of_string (List.assoc "name" attrs) + with Not_found -> UnknownArch in + let domains = + List.filter_map ( + function + | Element ("domain", attrs, children) -> + let domtype = + try + match List.assoc "type" attrs with + | "xen" -> Xen + | "qemu" -> QEMU + | "kvm" -> KVM + | _ -> UnknownHVType + with Not_found -> UnknownHVType in + Some (domtype, children) + | _ -> None + ) children in + Some (arch, domains) + | _ -> None + ) guest + with + Not_found -> UnknownArch, [] in + + (os_type, arch, domains) + ) guests in + + (conn_id, (conn, hostname, guests)) + ) conns + +(* Perform (or at least start off) the install. *) +and start_install parent conns + conn_id distro name disk disk_size net ram vcpus = + (* Create new toplevel dialog to show the progress of the steps. *) + let title = s_"Guest installing" in + let position = `CENTER_ON_PARENT in + + let dlg = GWindow.dialog + ~title ~position ~parent ~modal:false ~width:480 () in + + let frame = + GBin.frame ~label:(s_ "Download kernel") ~packing:dlg#vbox#pack () in + let kernel_bar = GRange.progress_bar ~packing:frame#add () in + + let frame = + GBin.frame ~label:(s_ "Download initrd") ~packing:dlg#vbox#pack () in + let initrd_bar = GRange.progress_bar ~packing:frame#add () in + + let frame = + GBin.frame ~label:(s_ "Create disk image") ~packing:dlg#vbox#pack () in + let disk_bar = GRange.progress_bar ~packing:frame#add () in + + (* We will enter the Gtk main loop recursively. Wire up close and + * other buttons to quit the recursive main loop. + *) + ignore (dlg#connect#destroy ~callback:GMain.quit); + ignore (dlg#event#connect#delete + ~callback:(fun _ -> GMain.quit (); false)); + + (* Action area. *) + let cancel_button = + GButton.button ~label:(s_"Cancel") ~packing:dlg#action_area#pack () in + ignore (cancel_button#connect#clicked ~callback:dlg#destroy); + +(* + (* Create the disk image if necessary. + * XXX Should have checked earlier if it already exists. + *) + let disk_exists = + try (stat disk).st_kind = S_REG + with Unix_error _ -> false in + if not disk_exists then ( + try + let fd = openfile disk [O_WRONLY;O_CREAT] in + let onemeg = 1024*1024 in + let buffer = String.make onemeg '\000' in + let nmegs = int_of_float (disk_size *. 1024.) in + for i = 0 to nmegs-1 do + write fd buffer 0 onemeg + done; + close fd + with + exn -> + (* Remove the disk image. *) + (try unlink disk with _ -> ()); + (* Re-raise the original exception. *) + raise exn + ); +*) + + (* Get the distro by name. *) + let virt_type, arch = List.assoc distro distros in + + (* Generate the XML configuration. *) + let xml = + (* Shortcut to make "value". *) + let leaf name value = Xml.Element (name, [], [Xml.PCData value]) in + (* ... and the _other_ sort of leaf (god I hate XML). *) + let tleaf name attribs = Xml.Element (name, attribs, []) in + + (* Standard stuff for every domain. *) + let name = leaf "name" name in + let uuid = leaf "uuid" (random_uuid ()) in + let maxmem, memory = + let m = string_of_int (ram * 1024) in + leaf "maxmem" m, leaf "memory" m in + let vcpus = leaf "vcpu" (string_of_int vcpus) in + + (* section, describes kernel, boot locations. *) + + + + + (* Put it all together in . *) + Xml.Element ( + "domain", + [ "type", string_of_virt_type virt_type ], + name :: uuid :: memory :: maxmem :: vcpus :: [] + ) in + + let xml = Xml.to_string_fmt xml in + + prerr_endline xml; + + dlg#show (); + + (* Enter Gtk main loop recursively. *) + GMain.main () + +(* Generate a random MAC address in the Xen-reserved space. *) +and random_mac_address () = + let random = + List.map (sprintf "%02x") ( + List.map (fun _ -> Random.int 256) [0;0;0] + ) in + String.concat ":" ("00"::"16"::"3e"::random) + +(* Generate a random UUID. *) +and random_uuid = + let hex = "0123456789abcdef" in + fun () -> + let str = String.create 32 in + for i = 0 to 31 do str.[i] <- hex.[Random.int 16] done; + str diff --git a/virt-ctrl/vc_install_dlg.mli b/virt-ctrl/vc_install_dlg.mli new file mode 100644 index 0000000..c8754e0 --- /dev/null +++ b/virt-ctrl/vc_install_dlg.mli @@ -0,0 +1,23 @@ +(* virt-ctrl: A graphical management tool. + (C) Copyright 2007 Richard W.M. Jones, Red Hat Inc. + http://libvirt.org/ + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + + The install guest dialog. +*) + +(** Install guest dialog. *) +val install_guest : GWindow.window -> int -> unit -> unit diff --git a/virt-ctrl/vc_mainwindow.ml b/virt-ctrl/vc_mainwindow.ml index c34a803..71083fa 100644 --- a/virt-ctrl/vc_mainwindow.ml +++ b/virt-ctrl/vc_mainwindow.ml @@ -45,7 +45,9 @@ Libvirt version: %s Gtk toolkit version: %s") utf8_copyright virt_version gtk_version) -(* Catch any exception and throw up a dialog. *) +(* Set up a global exception handler to catch any exception and throw + * up a dialog. + *) let () = (* A nicer exception printing function. *) let string_of_exn = function @@ -64,7 +66,7 @@ let () = icon#set_icon_size `DIALOG; GToolbox.message_box ~title ~icon label -let make +let rec make ~start_domain ~pause_domain ~resume_domain ~shutdown_domain ~open_domain_details = (* Create the main window. *) @@ -72,7 +74,7 @@ let make let vbox = GPack.vbox ~packing:window#add () in (* Menu bar. *) - let quit_item = + let quit_item, install_item = let menubar = GMenu.menu_bar ~packing:vbox#pack () in let factory = new GMenu.factory menubar in let accel_group = factory#accel_group in @@ -86,11 +88,13 @@ let make let open_item = factory#add_item (s_ "Open connection ...") ~key:GdkKeysyms._O in ignore (factory#add_separator ()); + let install_item = factory#add_item (s_ "Install new guest ...") + ~key:GdkKeysyms._N in + ignore (factory#add_separator ()); let quit_item = factory#add_item (s_ "Quit") ~key:GdkKeysyms._Q in ignore (open_item#connect#activate ~callback:(Vc_connection_dlg.open_connection window)); - (* Help menu. *) let factory = new GMenu.factory help_menu ~accel_group in let help_item = factory#add_item (s_ "Help") in @@ -98,7 +102,7 @@ let make ignore (help_about_item#connect#activate ~callback:help_about); - quit_item in + quit_item, install_item in (* The toolbar. *) let toolbar = GButton.toolbar ~packing:vbox#pack () in @@ -108,6 +112,18 @@ let make Vc_connections.make_treeview ~packing:(vbox#pack ~expand:true ~fill:true) () in + (* Wire up the install item (requires the treeview for selection). *) + ignore (install_item#connect#activate + ~callback:( + fun () -> + let conn_id = get_conn_id tree model columns in + match conn_id with + | None -> () (* nothing selected *) + | Some conn_id -> (* connection ID selected *) + Vc_install_dlg.install_guest window conn_id () + ) + ); + (* Add buttons to the toolbar (requires the treeview to * have been made above). *) @@ -200,3 +216,34 @@ let make (* Display the window. *) window#show () + +(* Get the selected connection ID if there is one or return None. *) +and get_conn_id (tree : GTree.view) (model : GTree.tree_store) + (columns : Vc_connections.columns) = + let path, _ = tree#get_cursor () in + match path with + | None -> None (* No row at all selected. *) + | Some path -> + let row = model#get_iter path in + let (_, _, _, _, _, col_id) = columns in + (* Visit parent to get the connid. + * If this returns None, then this is already a top-level row + * (ie. a connection). + *) + match model#iter_parent row with + | None -> + let connid = model#get ~row ~column:col_id in + Some connid + | Some parent -> + try + let connid = model#get ~row:parent ~column:col_id in + Some connid + with + (* Domain or connection disappeared under us. *) + | Not_found -> None + | Failure msg -> + prerr_endline msg; + None + | Libvirt.Virterror err -> + prerr_endline (Libvirt.Virterror.to_string err); + None -- 1.8.3.1