--- /dev/null
+(* 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 "<name>value</name>". *)
+ 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
+
+ (* <os> section, describes kernel, boot locations. *)
+
+
+
+
+ (* Put it all together in <domain type='foo'>. *)
+ 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
git.annexia.org / virt-ctrl.git / blobdiff