1 (* virt-ctrl: A graphical management tool.
2 (C) Copyright 2007 Richard W.M. Jones, Red Hat Inc.
5 This program is free software; you can redistribute it and/or modify
6 it under the terms of the GNU General Public License as published by
7 the Free Software Foundation; either version 2 of the License, or
8 (at your option) any later version.
10 This program is distributed in the hope that it will be useful,
11 but WITHOUT ANY WARRANTY; without even the implied warranty of
12 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13 GNU General Public License for more details.
15 You should have received a copy of the GNU General Public License
16 along with this program; if not, write to the Free Software
17 Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
25 open Virt_ctrl_gettext.Gettext
27 let (//) = Filename.concat
30 | VT_HVM | VT_Xen | UnknownVirtType
32 | I386 | X86_64 | IA64 | PPC | PPC64 | SPARC | SPARC64
35 type hv_name = (* implicitly ordered worst->best *)
36 | UnknownHVType | QEMU | Xen | KVM
38 (* List of supported distros. The name field must be unique but
39 * doesn't need to be constant.
42 "Fedora 8 (i386, 32 bit, Xen paravirtualized)", (
45 "Fedora 8 (i386, 32 bit, fully virtualized)", (
48 "Fedora 8 (x86-64, 64 bit, Xen paravirtualized)", (
51 "Fedora 8 (x86-64, 64 bit, fully virtualized)", (
54 "Fedora 9 (i386, 32 bit, Xen paravirtualized)", (
57 "Fedora 9 (i386, 32 bit, fully virtualized)", (
60 "Fedora 9 (x86-64, 64 bit, Xen paravirtualized)", (
63 "Fedora 9 (x86-64, 64 bit, fully virtualized)", (
68 let string_of_virt_type = function
71 | UnknownVirtType -> invalid_arg "string_of_virt_type"
73 let string_of_architecture = function
80 | SPARC64 -> "sparc64"
81 | OtherArch arch -> arch
82 | UnknownArch -> invalid_arg "string_of_architecture"
84 let architecture_of_string = function
86 String.length str = 4 &&
87 (str.[0] = 'i' || str.[0] = 'I') &&
88 (str.[1] >= '3' && str.[1] <= '6') &&
89 str.[2] = '8' && str.[3] = '6' -> I386
90 | "x86_64" | "X86_64" | "x86-64" | "X86-64" -> X86_64
91 | "ia64" | "IA64" -> IA64
92 | "ppc" | "PPC" | "ppc32" | "PPC32" -> PPC
93 | "ppc64" | "PPC64" -> PPC64
94 | "sparc" | "SPARC" | "sparc32" | "SPARC32" -> SPARC
95 | "sparc64" | "SPARC64" -> SPARC64
96 | str -> OtherArch str
98 let string_of_hv_name = function
102 | UnknownHVType -> "unknown"
104 (* Choose a disk location for images.
105 * This changed in libvirt 0.4.something.
109 "/var/lib/libvirt/images";
110 "/var/lib/libvirt/xen";
113 try dirs @ [Sys.getenv "HOME"]
114 with Not_found -> dirs in
118 try (stat d).st_kind = S_DIR
119 with Unix_error _ -> false
122 Not_found -> "/var/tmp"
124 type edit_status = UserEdit | ProgramEdit | Disconnected
126 let rec find_map f = function
127 | [] -> raise Not_found
131 | None -> find_map f xs
133 (* Install guest dialog. *)
134 let rec install_guest parent conn_id () =
135 let title = s_"Install new guest" in
136 let position = `CENTER_ON_PARENT in
138 let dlg = GWindow.dialog ~title ~position ~parent ~modal:true () in
140 (* We will enter the Gtk main loop recursively. Wire up close and
141 * other buttons to quit the recursive main loop.
143 ignore (dlg#connect#destroy ~callback:GMain.quit);
144 ignore (dlg#event#connect#delete
145 ~callback:(fun _ -> GMain.quit (); false));
149 GButton.button ~label:(s_"Cancel") ~packing:dlg#action_area#pack () in
150 ignore (cancel_button#connect#clicked ~callback:dlg#destroy);
153 GButton.button ~label:(s_"Install") ~packing:dlg#action_area#pack () in
156 let conns = get_connections () in
159 GBin.frame ~label:(s_"Hypervisor connection")
160 ~packing:dlg#vbox#pack () in
161 let hbox = GPack.hbox ~packing:frame#add () in
163 ignore (GMisc.label ~text:(s_"Connection:") ~xalign:1.0
164 ~packing:hbox#pack ());
166 let conn_combo, (conn_model : GTree.list_store), conn_col_id, conn_active =
167 populate_conns conns hbox#pack conn_id in
171 GBin.frame ~label:(s_"Operating system") ~packing:dlg#vbox#pack () in
173 let (distro_combo, (distro_list, distro_col_name)) =
174 GEdit.combo_box_text ~packing:frame#add () in
178 GBin.frame ~label:(s_"Guest details") ~packing:dlg#vbox#pack () in
180 let tbl = GPack.table ~columns:3 ~rows:5 ~packing:frame#add () in
182 ignore (GMisc.label ~text:(s_"Name:") ~xalign:1.0
183 ~packing:(tbl#attach ~top:0 ~left:0) ());
185 GEdit.entry ~width_chars:32
186 ~packing:(tbl#attach ~top:0 ~left:1) () in
189 ignore (GMisc.label ~text:(s_"Disk image:") ~xalign:1.0
190 ~packing:(tbl#attach ~top:1 ~left:0) ());
192 GEdit.entry ~width_chars:48
193 ~packing:(tbl#attach ~top:1 ~left:1) () in
194 let hbox = GPack.hbox ~packing:(tbl#attach ~top:1 ~left:2) () in
196 GEdit.spin_button ~numeric:true ~digits:1
197 ~packing:hbox#pack () in
198 disk_size#adjustment#set_bounds ~lower:2.0 ~upper:999.0 ~step_incr:0.5 ();
199 disk_size#adjustment#set_value 8.0;
200 ignore (GMisc.label ~text:" GB" ~packing:hbox#pack ());
203 ignore (GMisc.label ~text:(s_"Network:") ~xalign:1.0
204 ~packing:(tbl#attach ~top:2 ~left:0) ());
207 ~strings:["default"] (* XXX not implemented *)
208 ~packing:(tbl#attach ~top:2 ~left:1) () in
209 net_combo#set_active 0;
212 ignore (GMisc.label ~text:(s_"RAM:") ~xalign:1.0
213 ~packing:(tbl#attach ~top:3 ~left:0) ());
214 let hbox = GPack.hbox ~packing:(tbl#attach ~top:3 ~left:1) () in
216 GEdit.spin_button ~numeric:true ~digits:0
217 ~packing:hbox#pack () in
218 ram#adjustment#set_bounds ~lower:128.0 ~upper:131_072.0 ~step_incr:32.0 ();
219 ram#adjustment#set_value 512.0;
220 ignore (GMisc.label ~text:" MB" ~packing:hbox#pack ());
223 ignore (GMisc.label ~text:(s_"CPUs:") ~xalign:1.0
224 ~packing:(tbl#attach ~top:4 ~left:0) ());
225 let hbox = GPack.hbox ~packing:(tbl#attach ~top:4 ~left:1) () in
227 GEdit.spin_button ~numeric:true ~digits:0
228 ~packing:hbox#pack () in
229 vcpus#adjustment#set_bounds ~lower:1.0 ~upper:4.0 ~step_incr:1.0 ();
230 vcpus#adjustment#set_value 1.0;
233 (* When connection combo changes we need to repopulate list of distros. *)
235 conn_combo#connect#changed
238 repopulate_distros conns conn_combo conn_model conn_col_id
239 distro_combo distro_list distro_col_name
243 (* When distro changes we need to change the name, provided the name
244 * hasn't been edited by the user (in which case we leave it alone).
246 * We have to use a shared reference so that we don't disconnect
247 * the signal when we are editing the field (not the user). Ugh ...
249 let edit_status = ref UserEdit in
250 let distro_changed_id =
251 distro_combo#connect#changed
254 let row = distro_combo#active_iter in
256 | None -> () (* no distro selected *)
258 let name = distro_list#get ~row ~column:distro_col_name in
259 let name = short_name_of_distro name in
261 let old_status = !edit_status in
262 edit_status := ProgramEdit;
263 name_entry#set_text name;
264 disk_entry#set_text (disk_location // name ^ ".img");
265 edit_status := old_status
269 name_entry#connect#changed ~callback:(
271 if !edit_status = UserEdit then (
272 distro_combo#misc#disconnect distro_changed_id;
273 edit_status := Disconnected (* prevent multiple disconnections *)
279 disk_entry#connect#changed ~callback:(
281 if !edit_status = UserEdit then (
282 distro_combo#misc#disconnect distro_changed_id;
283 edit_status := Disconnected (* prevent multiple disconnections *)
288 (* Wire up the install button. *)
290 install_button#connect#clicked ~callback:(
292 (* Get the required settings. *)
294 match conn_combo#active_iter with
295 | None -> (* no connection selected *)
296 invalid_arg (s_"No connection selected")
298 conn_model#get ~row ~column:conn_col_id in
300 match distro_combo#active_iter with
301 | None -> (* no distro selected *)
302 invalid_arg (s_"No operating system selected")
304 distro_list#get ~row ~column:distro_col_name in
305 let name = name_entry#text in
306 let disk = disk_entry#text in
307 let disk_size = disk_size#value in
308 let net = "default" (* XXX network not implemented *) in
309 let ram = ram#value_as_int in
310 let vcpus = vcpus#value_as_int in
313 start_install parent conns
314 conn_id distro name disk disk_size net ram vcpus
318 (* See combobox.ml example in %doc directory.
319 * NB. Don't use ~active label above. It is buggy and won't trigger
320 * the selection callback.
322 conn_combo#set_active conn_active;
324 (* Set focus on the distro. *)
325 distro_combo#misc#grab_focus ();
329 (* Enter Gtk main loop recursively. *)
332 (* Populate the list of connections. *)
333 and populate_conns conns packing conn_id =
335 let cols = new GTree.column_list in
336 let col_name = cols#add Gobject.Data.string in
337 let col_id = cols#add Gobject.Data.int in
338 let model = GTree.list_store cols in
341 let conn_combo = GEdit.combo_box ~model ~packing () in
343 let renderer = GTree.cell_renderer_text [] in
344 conn_combo#pack renderer;
345 ignore (conn_combo#add_attribute renderer "text" col_name);
347 (* Populate the connection combo box. *)
348 let active = ref 0 in
350 fun i (id, (conn, hostname, guests)) ->
351 if id = conn_id then active := i;
354 (* Get unique list of all HV types supported. *)
355 let hvs = List.map (fun (_, _, domains) -> domains) guests in
356 let hvs = List.concat hvs in
357 let hvs = List.map fst hvs in
358 let hvs = List.unique hvs in
359 let hvs = List.sort hvs in
361 (* Make a printable string for this connection. *)
362 sprintf "%s (%s)" hostname
363 (String.concat "/" (List.map string_of_hv_name hvs)) in
365 let row = model#append () in
366 model#set ~row ~column:col_name name;
367 model#set ~row ~column:col_id conn_id
370 conn_combo, model, col_id, !active
372 (* When connection combo selection changes, repopulate list of distros. *)
373 and repopulate_distros conns conn_combo conn_model conn_col_id
374 distro_combo distro_list distro_col_name =
375 (* Clear the distro list. *)
376 distro_list#clear ();
378 let row = conn_combo#active_iter in
380 | None -> () (* no connection selected *)
382 let conn_id = conn_model#get ~row ~column:conn_col_id in
383 let conn, hostname, guests = List.assoc conn_id conns in
385 (* Get the distros which match one of the guest types. *)
386 let distros = List.map get_matching_distros guests in
387 let distros = List.concat distros in
388 let distros = List.unique distros in
389 let distros = List.sort distros in
391 (* Populate the list with distros which match. *)
394 let row = distro_list#append () in
395 distro_list#set ~row ~column:distro_col_name name
398 if List.length distros > 0 then distro_combo#set_active 0
400 and get_matching_distros (virt_type, arch, domains) =
402 fun (_, (virt_type', arch')) ->
403 virt_type = virt_type' && arch = arch'
406 (* Get a short name from the selected distro's name. *)
407 and short_name_of_distro name =
408 let len = String.length name in
409 let buf = Buffer.create 16 in
415 Buffer.add_char buf (Char.chr (Char.code c + 0x20));
417 | 'a' .. 'z' | '0' .. '9' ->
418 Buffer.add_char buf c;
420 | '(' -> () (* stop at first '(' character *)
427 (* Get connection details, mainly from the capabilities XML. *)
428 and get_connections () =
429 let conns = Vc_connections.get_conns () in
431 fun (conn_id, conn) ->
433 match Vc_connections.get_hostname conn_id with
434 | Some hostname -> hostname
435 | None -> sprintf "Conn #%d" conn_id in
437 (* Get some idea of what the hypervisor supports. *)
439 let caps = Vc_connections.get_capabilities conn_id in
441 | Some (Element ("capabilities", _, children)) ->
444 | Element ("guest", _, children) -> Some children
447 | _ -> [] in (* XXX should do better if no caps *)
456 | Element ("os_type", _, [PCData "hvm"]) -> Some VT_HVM
457 | Element ("os_type", _, [PCData "xen"]) -> Some VT_Xen
461 Not_found -> UnknownVirtType in
467 | Element ("arch", attrs, children) ->
469 try architecture_of_string (List.assoc "name" attrs)
470 with Not_found -> UnknownArch in
474 | Element ("domain", attrs, children) ->
477 match List.assoc "type" attrs with
482 with Not_found -> UnknownHVType in
483 Some (domtype, children)
490 Not_found -> UnknownArch, [] in
492 (os_type, arch, domains)
495 (conn_id, (conn, hostname, guests))
498 (* Perform (or at least start off) the install. *)
499 and start_install parent conns
500 conn_id distro name disk disk_size net ram vcpus =
501 (* Create new toplevel dialog to show the progress of the steps. *)
502 let title = s_"Guest installing" in
503 let position = `CENTER_ON_PARENT in
505 let dlg = GWindow.dialog
506 ~title ~position ~parent ~modal:false ~width:480 () in
509 GBin.frame ~label:(s_ "Download kernel") ~packing:dlg#vbox#pack () in
510 let kernel_bar = GRange.progress_bar ~packing:frame#add () in
513 GBin.frame ~label:(s_ "Download initrd") ~packing:dlg#vbox#pack () in
514 let initrd_bar = GRange.progress_bar ~packing:frame#add () in
517 GBin.frame ~label:(s_ "Create disk image") ~packing:dlg#vbox#pack () in
518 let disk_bar = GRange.progress_bar ~packing:frame#add () in
520 (* We will enter the Gtk main loop recursively. Wire up close and
521 * other buttons to quit the recursive main loop.
523 ignore (dlg#connect#destroy ~callback:GMain.quit);
524 ignore (dlg#event#connect#delete
525 ~callback:(fun _ -> GMain.quit (); false));
529 GButton.button ~label:(s_"Cancel") ~packing:dlg#action_area#pack () in
530 ignore (cancel_button#connect#clicked ~callback:dlg#destroy);
533 (* Create the disk image if necessary.
534 * XXX Should have checked earlier if it already exists.
537 try (stat disk).st_kind = S_REG
538 with Unix_error _ -> false in
539 if not disk_exists then (
541 let fd = openfile disk [O_WRONLY;O_CREAT] in
542 let onemeg = 1024*1024 in
543 let buffer = String.make onemeg '\000' in
544 let nmegs = int_of_float (disk_size *. 1024.) in
545 for i = 0 to nmegs-1 do
546 write fd buffer 0 onemeg
551 (* Remove the disk image. *)
552 (try unlink disk with _ -> ());
553 (* Re-raise the original exception. *)
558 (* Get the distro by name. *)
559 let virt_type, arch = List.assoc distro distros in
561 (* Generate the XML configuration. *)
563 (* Shortcut to make "<name>value</name>". *)
564 let leaf name value = Xml.Element (name, [], [Xml.PCData value]) in
565 (* ... and the _other_ sort of leaf (god I hate XML). *)
566 let tleaf name attribs = Xml.Element (name, attribs, []) in
568 (* Standard stuff for every domain. *)
569 let name = leaf "name" name in
570 let uuid = leaf "uuid" (random_uuid ()) in
572 let m = string_of_int (ram * 1024) in
573 leaf "maxmem" m, leaf "memory" m in
574 let vcpus = leaf "vcpu" (string_of_int vcpus) in
576 (* <os> section, describes kernel, boot locations. *)
581 (* Put it all together in <domain type='foo'>. *)
584 [ "type", string_of_virt_type virt_type ],
585 name :: uuid :: memory :: maxmem :: vcpus :: []
588 let xml = Xml.to_string_fmt xml in
594 (* Enter Gtk main loop recursively. *)
597 (* Generate a random MAC address in the Xen-reserved space. *)
598 and random_mac_address () =
600 List.map (sprintf "%02x") (
601 List.map (fun _ -> Random.int 256) [0;0;0]
603 String.concat ":" ("00"::"16"::"3e"::random)
605 (* Generate a random UUID. *)
607 let hex = "0123456789abcdef" in
609 let str = String.create 32 in
610 for i = 0 to 31 do str.[i] <- hex.[Random.int 16] done;