1 (* This is a virtual machine graphical viewer tool.
2 * Written by Richard W.M. Jones, Sept. 2009.
4 * It demonstrates some complex programming techniques: OCaml, Gtk+,
5 * threads, and use of both libguestfs and libvirt from threads.
7 * You will need the following installed in order to compile it:
8 * - ocaml (http://caml.inria.fr/)
9 * - ocamlfind (http://projects.camlcity.org/projects/findlib.html/)
10 * - extlib (http://code.google.com/p/ocaml-extlib/)
11 * - lablgtk2 (http://wwwfun.kurims.kyoto-u.ac.jp/soft/lsl/lablgtk.html
12 * - xml-light (http://tech.motion-twin.com/xmllight.html)
13 * - ocaml-libvirt (http://libvirt.org/ocaml)
16 * Note that most/all of these are available as packages via Fedora,
17 * Debian, Ubuntu or GODI. You won't need to compile them from source.
19 * You will also need to configure libguestfs:
20 * ./configure --enable-ocaml-viewer
22 * All programs in the ocaml/examples subdirectory, including this
23 * one, may be freely copied without any restrictions.
26 (* Architecturally, there is one main thread which does all the Gtk
27 * calls, and one slave thread which executes all libguestfs and
28 * libvirt calls. The main thread sends commands to the slave thread,
29 * which are delivered in a queue and acted on in sequence. Responses
30 * are delivered back to the main thread as commands finish.
32 * The commands are just OCaml objects (type: Slave.command). The
33 * queue of commands is an OCaml Queue. The responses are sent by adding
34 * idle events to the glib main loop[1].
36 * If a command fails, it causes the input queue to be cleared. In
37 * this case, a failure response is sent to the main loop which
38 * causes the display to be reset and possibly an error message to
41 * The global variables [conn], [dom] and [g] are the libvirt
42 * connection, current domain, and libguestfs handle respectively.
43 * Because these can be accessed by both threads, they are
44 * protected from the main thread by access methods which
45 * (a) prevent the main thread from using them unlocked, and
46 * (b) prevent the main thread from doing arbitrary / long-running
47 * operations on them (the main thread must send a command instead).
49 * [1] http://library.gnome.org/devel/gtk-faq/stable/x499.html
55 let (//) = Filename.concat
57 (* Short names for commonly used modules. *)
58 module C = Libvirt.Connect
60 module D = Libvirt.Domain
65 let verbose = ref false (* Verbose mode. *)
68 let f str = if !verbose then ( prerr_string str; prerr_newline () ) in
71 (*----------------------------------------------------------------------*)
72 (* Slave thread. The signature describes what operations the main
73 * thread can perform, and protects the locked internals of the
77 type 'a callback = 'a -> unit
80 pt_name : string; (** device / LV name *)
81 pt_size : int64; (** in bytes *)
82 pt_content : string; (** the output of the 'file' command *)
83 pt_statvfs : G.statvfs option; (** None if not mountable *)
86 val no_callback : 'a callback
87 (** Use this as the callback if you don't want a callback. *)
89 val set_failure_callback : exn callback -> unit
90 (** Set the function that is called in the main thread whenever
91 there is a command failure in the slave. The command queue
92 is cleared before this is sent. [exn] is the exception
93 associated with the failure. *)
95 val set_busy_callback : [`Busy|`Idle] callback -> unit
96 (** Set the function that is called in the main thread whenever
97 the slave thread goes busy or idle. *)
99 val exit_thread : unit -> unit
100 (** [exit_thread ()] causes the slave thread to exit. *)
102 val connect : string option -> string option callback -> unit
103 (** [connect uri cb] connects to libvirt [uri], and calls [cb]
104 if it completes successfully. Any previous connection is
105 automatically cleaned up and disconnected. *)
107 val get_domains : string list callback -> unit
108 (** [get_domains cb] gets the list of active domains from libvirt,
109 and calls [cb domains] with the names of those domains. *)
111 val open_domain : string -> partinfo list callback -> unit
112 (** [open_domain dom cb] sets the domain [dom] as the current
113 domain, and launches a libguestfs handle for it. Any previously
114 current domain and libguestfs handle is closed. Once the
115 libguestfs handle is opened (which usually takes some time),
116 callback [cb] is called with the list of partitions found
119 val slave_loop : unit -> unit
120 (** The slave thread's main loop, running in the slave thread. *)
127 pt_statvfs : G.statvfs option;
130 (* Commands sent by the main thread to the slave thread. When
131 * [cmd] is successfully completed, [callback] will be delivered
132 * (in the main thread). If [cmd] fails, then the global error
133 * callback will be delivered in the main thread.
137 | Connect of string option * string option callback
138 | Get_domains of string list callback
139 | Open_domain of string * partinfo list callback
140 and 'a callback = 'a -> unit
142 let string_of_command = function
143 | Exit_thread -> "Exit_thread"
144 | Connect (None, _) -> "Connect [no uri]"
145 | Connect (Some uri, _) -> "Connect " ^ uri
146 | Get_domains _ -> "Get_domains"
147 | Open_domain (name, _) -> "Open_domain " ^ name
149 let no_callback _ = ()
151 let failure_cb = ref (fun _ -> ())
152 let set_failure_callback cb = failure_cb := cb
154 let busy_cb = ref (fun _ -> ())
155 let set_busy_callback cb = busy_cb := cb
157 (* Execute a function, while holding a mutex. If the function
158 * fails, ensure we release the mutex before rethrowing the
161 type ('a, 'b) choice = Either of 'a | Or of 'b
164 let r = try Either (f ()) with exn -> Or exn in
168 | Or exn -> raise exn
170 let q = Q.create () (* queue of commands *)
171 let q_lock = M.create ()
172 let q_cond = Cd.create ()
174 (* Send a command message to the slave thread. *)
175 let send_to_slave c =
176 debug "sending to slave: %s" (string_of_command c);
184 with_lock q_lock (fun () -> Q.clear q);
185 send_to_slave Exit_thread
188 send_to_slave (Connect (uri, cb))
191 send_to_slave (Get_domains cb)
193 let open_domain dom cb =
194 send_to_slave (Open_domain (dom, cb))
196 (* These are not protected by a mutex because we don't allow
197 * any references to these objects to escape from the slave
200 let conn = ref None (* libvirt connection *)
201 let dom = ref None (* libvirt domain *)
202 let g = ref None (* libguestfs handle *)
206 let rec slave_loop () =
207 debug "Slave.slave_loop: waiting for a command";
211 while Q.is_empty q do
212 Cd.wait q_cond q_lock
218 debug "Slave.slave_loop: executing: %s" (string_of_command c);
222 debug "Slave.slave_loop: command succeeded";
224 (* If an exception is thrown, it means the command failed. In
225 * this case we clear the command queue and deliver the failure
226 * callback in the main thread.
228 debug "Slave.slave_loop: command failed";
231 with_lock q_lock (fun () -> Q.clear q);
232 GtkThread.async !failure_cb exn
235 if !quit then Thread.exit ();
238 and exec_command = function
240 quit := true; (* quit first in case disconnect_all throws an exn *)
243 | Connect (name, cb) ->
245 conn := Some (C.connect_readonly ?name ());
249 let conn = Option.get !conn in
250 let doms = D.get_domains conn [D.ListAll] in
251 (* Only return the names, so that the libvirt objects
252 * aren't leaked outside the slave thread.
254 let doms = List.map D.get_name doms in
257 | Open_domain (domname, cb) ->
258 let conn = Option.get !conn in
260 dom := Some (D.lookup_by_name conn domname);
261 let dom = Option.get !dom in
263 (* Get the devices. *)
264 let xml = D.get_xml_desc dom in
265 let devs = get_devices_from_xml xml in
267 (* Create the libguestfs handle and launch it. *)
268 let g' = G.create () in
269 List.iter (G.add_drive_ro g') devs;
273 (* Get the list of partitions. *)
274 let parts = Array.to_list (G.list_partitions g') in
275 (* Remove any which are PVs. *)
276 let pvs = Array.to_list (G.pvs g') in
277 let parts = List.filter (fun part -> not (List.mem part pvs)) parts in
278 let lvs = Array.to_list (G.lvs g') in
279 let parts = parts @ lvs in
281 let parts = List.map (
283 (* Find out the size of each partition. *)
284 let size = G.blockdev_getsize64 g' part in
286 (* Find out what's on each partition. *)
287 let content = G.file g' part in
289 (* Try to mount it. *)
292 G.mount_ro g' part "/";
293 Some (G.statvfs g' "/")
297 { pt_name = part; pt_size = size; pt_content = content;
298 pt_statvfs = statvfs }
301 (* Call the callback. *)
304 (* Close all libvirt/libguestfs handles. *)
305 and disconnect_all () =
307 (match !conn with Some conn -> C.close conn | None -> ());
310 (* Close dom and libguestfs handles. *)
311 and disconnect_dom () =
312 (match !g with Some g -> G.close g | None -> ());
314 (match !dom with Some dom -> D.free dom | None -> ());
317 (* This would be much simpler if OCaml had either a decent XPath
318 * implementation, or if ocamlduce was stable enough that we
319 * could rely on it being available. So this is *not* an example
320 * of either good OCaml or good programming. XXX
322 and get_devices_from_xml xml =
323 let xml = Xml.parse_string xml in
326 | Xml.Element ("domain", _, children) ->
330 | Xml.Element ("devices", _, devices) -> Some devices
335 failwith "get_xml_desc didn't return <domain/>" in
336 let rec source_dev_of = function
338 | Xml.Element ("source", attrs, _) :: rest ->
339 (try Some (List.assoc "dev" attrs)
340 with Not_found -> source_dev_of rest)
341 | _ :: rest -> source_dev_of rest
343 let rec source_file_of = function
345 | Xml.Element ("source", attrs, _) :: rest ->
346 (try Some (List.assoc "file" attrs)
347 with Not_found -> source_file_of rest)
348 | _ :: rest -> source_file_of rest
353 | Xml.Element ("disk", _, children) -> source_dev_of children
359 | Xml.Element ("disk", _, children) -> source_file_of children
364 (* End of slave thread code. *)
365 (*----------------------------------------------------------------------*)
368 type display_state = {
369 window : GWindow.window;
370 vmlist_set : string list -> unit;
371 throbber_set : [`Busy|`Idle] -> unit;
372 da : GMisc.drawing_area;
373 draw : GDraw.drawable;
374 drawing_area_repaint : unit -> unit;
375 set_statusbar : string -> unit;
376 clear_statusbar : unit -> unit;
377 pango_large_context : GPango.context_rw;
378 pango_small_context : GPango.context_rw;
381 (* This is called in the main thread whenever a command fails in the
382 * slave thread. The command queue has been cleared before this is
383 * called, so our job here is to reset the main window, and if
384 * necessary to turn the exception into an error message.
387 let title = "Error" in
388 let msg = Printexc.to_string exn in
389 debug "failure callback: %s" msg;
390 let icon = GMisc.image () in
391 icon#set_stock `DIALOG_ERROR;
392 icon#set_icon_size `DIALOG;
393 GToolbox.message_box ~title ~icon msg
395 (* This is called in the main thread when the slave thread transitions
398 let busy ds state = ds.throbber_set state
400 (* Main window and callbacks from menu etc. *)
401 let main_window opened_domain repaint =
402 let window_title = "Virtual machine graphical viewer" in
403 let window = GWindow.window ~width:800 ~height:600 ~title:window_title () in
404 let vbox = GPack.vbox ~packing:window#add () in
407 let menubar = GMenu.menu_bar ~packing:vbox#pack () in
408 let factory = new GMenu.factory menubar in
409 let accel_group = factory#accel_group in
410 let connect_menu = factory#add_submenu "_Connect" in
412 let factory = new GMenu.factory connect_menu ~accel_group in
413 let quit_item = factory#add_item "E_xit" ~key:GdkKeysyms._Q in
416 let quit _ = GMain.quit (); false in
417 ignore (window#connect#destroy ~callback:GMain.quit);
418 ignore (window#event#connect#delete ~callback:quit);
419 ignore (quit_item#connect#activate
420 ~callback:(fun () -> ignore (quit ()); ()));
422 (* Top status area. *)
423 let hbox = GPack.hbox ~border_width:4 ~packing:vbox#pack () in
424 ignore (GMisc.label ~text:"Guest: " ~packing:hbox#pack ());
427 let vmcombo = GEdit.combo_box_text ~packing:hbox#pack () in
428 let vmlist_set names =
429 let combo, (model, column) = vmcombo in
433 let row = model#append () in
434 model#set ~row ~column name
438 (* Throbber, http://faq.pygtk.org/index.py?req=show&file=faq23.037.htp *)
439 let static = Throbber.static () in
440 (*let animation = Throbber.animation () in*)
442 GMisc.image ~pixbuf:static ~packing:(hbox#pack ~from:`END) () in
443 let throbber_set = function
444 | `Busy -> (*throbber#set_pixbuf animation*)
445 (* Workaround because no binding for GdkPixbufAnimation: *)
446 let file = Filename.dirname Sys.argv.(0) // "Throbber.gif" in
447 throbber#set_file file
448 | `Idle -> throbber#set_pixbuf static
452 let da = GMisc.drawing_area ~packing:(vbox#pack ~expand:true ~fill:true) () in
454 let draw = new GDraw.drawable da#misc#window in
455 window#set_geometry_hints ~min_size:(80,80) (da :> GObj.widget);
457 (* Calling this can be used to force a redraw of the drawing area. *)
458 let drawing_area_repaint () = GtkBase.Widget.queue_draw da#as_widget in
460 (* Pango contexts used to draw large and small text. *)
461 let pango_large_context = da#misc#create_pango_context in
462 pango_large_context#set_font_description (Pango.Font.from_string "Sans 12");
463 let pango_small_context = da#misc#create_pango_context in
464 pango_small_context#set_font_description (Pango.Font.from_string "Sans 8");
466 (* Status bar at the bottom of the screen. *)
468 let statusbar = GMisc.statusbar ~packing:vbox#pack () in
469 let context = statusbar#new_context ~name:"Standard" in
470 ignore (context#push window_title);
473 ignore (context#push msg)
475 let clear_statusbar () = set_statusbar "" in
477 (* Display the window and enter Gtk+ main loop. *)
479 window#add_accel_group accel_group;
481 (* display_state which is threaded through all the other callbacks,
482 * allowing callbacks to update the window.
485 { window = window; vmlist_set = vmlist_set; throbber_set = throbber_set;
486 da = da; draw = draw; drawing_area_repaint = drawing_area_repaint;
487 set_statusbar = set_statusbar; clear_statusbar = clear_statusbar;
488 pango_large_context = pango_large_context;
489 pango_small_context = pango_small_context; } in
491 (* Set up some callbacks which require access to the display_state. *)
493 let combo, (model, column) = vmcombo in
494 combo#connect#changed
497 match combo#active_iter with
500 let name = model#get ~row ~column in
501 ds.set_statusbar (sprintf "Opening %s ..." name);
502 Slave.open_domain name (opened_domain ds))
505 ignore (da#event#connect#expose ~callback:(repaint ds));
509 (* Partition info for the current domain, if one is loaded. *)
512 (* This is called in the main thread when we've connected to libvirt. *)
513 let rec connected ds uri =
514 debug "connected callback";
517 | None -> "Connected to libvirt"
518 | Some uri -> sprintf "Connected to %s" uri in
519 ds.set_statusbar msg;
520 Slave.get_domains (got_domains ds)
522 (* This is called in the main thread when we've got the list of domains. *)
523 and got_domains ds doms =
524 debug "got_domains callback: (%s)" (String.concat " " doms);
527 (* This is called when we have opened a domain. *)
528 and opened_domain ds parts' =
529 debug "opened_domain callback";
530 ds.clear_statusbar ();
531 parts := Some parts';
532 ds.drawing_area_repaint ()
538 real_repaint ds parts
542 and real_repaint ds parts =
543 let width, height = ds.draw#size in
544 ds.draw#set_background `WHITE;
545 ds.draw#set_foreground `WHITE;
546 ds.draw#rectangle ~x:0 ~y:0 ~width ~height ~filled:true ();
548 let sum = List.fold_left Int64.add 0L in
549 let totsize = sum (List.map (fun { Slave.pt_size = size } -> size) parts) in
551 let scale = (float height -. 16.) /. Int64.to_float totsize in
553 (* Calculate the height in pixels of each partition, if we were to
554 * display it at a true relative size.
558 fun ({ Slave.pt_size = size } as part) ->
559 let h = scale *. Int64.to_float size in
565 eprintf "real_repaint: before borrowing:\n";
568 eprintf "%s\t%g pix\n" part.Slave.pt_name h
573 (* Now adjust the heights of small partitions so they "borrow" some
574 * height from the larger partitions.
577 let rec borrow needed = function
579 | (h, part) :: parts ->
580 let spare = h -. min_h in
581 if spare >= needed then (
582 needed, (h -. needed, part) :: parts
583 ) else if spare > 0. then (
584 let needed = needed -. spare in
585 let spare', parts = borrow needed parts in
586 spare +. spare', (h -. spare, part) :: parts
588 let spare', parts = borrow needed parts in
589 spare', (h, part) :: parts
592 let rec loop = function
593 | parts, [] -> List.rev parts
594 | prev, ((h, part) :: parts) ->
595 let needed = min_h -. h in
597 if needed > 0. then (
598 (* Find some spare height in a succeeding partition(s). *)
599 let spare, parts = borrow needed parts in
600 (* Or if not, in a preceeding partition(s). *)
602 if spare = 0. then borrow needed prev else spare, prev in
603 h +. spare, prev, parts
607 loop (((h, part) :: prev), parts)
609 let parts = loop ([], parts) in
613 eprintf "real_repaint: after borrowing:\n";
616 eprintf "%s\t%g pix\n" part.Slave.pt_name h
621 (* Calculate the proportion space used in each partition. *)
622 let parts = List.map (
625 match part.Slave.pt_statvfs with
627 | Some { G.bavail = bavail; blocks = blocks } ->
628 let num = Int64.to_float (Int64.sub blocks bavail) in
629 let denom = Int64.to_float blocks in
637 fun y (h, used, part) ->
638 (* This partition occupies pixels 8+y .. 8+y+h-1 *)
639 let yb = 8 + int_of_float y
640 and yt = 8 + int_of_float (y +. h) in
642 ds.draw#set_foreground `WHITE;
643 ds.draw#rectangle ~x:8 ~y:yb ~width:(width-16) ~height:(yt-yb)
647 if used < 0.6 then `NAME "grey"
648 else if used < 0.8 then `NAME "pink"
649 else if used < 0.9 then `NAME "hot pink"
651 ds.draw#set_foreground col;
652 let w = int_of_float (used *. (float width -. 16.)) in
653 ds.draw#rectangle ~x:8 ~y:yb ~width:w ~height:(yt-yb) ~filled:true ();
655 ds.draw#set_foreground `BLACK;
656 ds.draw#rectangle ~x:8 ~y:yb ~width:(width-16) ~height:(yt-yb) ();
658 (* Large text - the device name. *)
659 let txt = ds.pango_large_context#create_layout in
660 Pango.Layout.set_text txt part.Slave.pt_name;
661 let fore = `NAME "dark slate grey" in
662 ds.draw#put_layout ~x:12 ~y:(yb+4) ~fore txt;
664 let { Pango.height = txtheight; Pango.width = txtwidth } =
665 Pango.Layout.get_pixel_extent txt in
667 (* Small text below - the content. *)
668 let txt = ds.pango_small_context#create_layout in
669 Pango.Layout.set_text txt part.Slave.pt_content;
671 ds.draw#put_layout ~x:12 ~y:(yb+4+txtheight) ~fore txt;
673 (* Small text right - size. *)
675 match part.Slave.pt_statvfs with
676 | None -> printable_size part.Slave.pt_size
677 | Some { G.blocks = blocks; bsize = bsize } ->
678 let bytes = Int64.mul blocks bsize in
679 let pc = 100. *. used in
680 sprintf "%s (%.1f%% used)" (printable_size bytes) pc in
681 let txt = ds.pango_small_context#create_layout in
682 Pango.Layout.set_text txt size;
683 ds.draw#put_layout ~x:(16+txtwidth) ~y:(yb+4) ~fore txt;
689 and printable_size bytes =
690 if bytes < 16_384L then sprintf "%Ld bytes" bytes
691 else if bytes < 16_777_216L then
692 sprintf "%Ld KiB" (Int64.div bytes 1024L)
693 else if bytes < 17_179_869_184L then
694 sprintf "%Ld MiB" (Int64.div bytes 1_048_576L)
696 sprintf "%Ld GiB" (Int64.div bytes 1_073_741_824L)
698 let default_uri = ref ""
700 let argspec = Arg.align [
701 "-verbose", Arg.Set verbose, "Verbose mode";
702 "-connect", Arg.Set_string default_uri, "Connect to libvirt URI";
706 failwith (sprintf "%s: unknown command line argument"
707 (Filename.basename Sys.executable_name))
712 %s: graphical virtual machine disk usage viewer
715 (Filename.basename Sys.executable_name)
718 Arg.parse argspec anon_fun usage_msg;
720 (* Start up the slave thread. *)
721 let slave = Thread.create Slave.slave_loop () in
723 (* Set up the display. *)
724 let ds = main_window opened_domain repaint in
726 Slave.set_failure_callback (failure ds);
727 Slave.set_busy_callback (busy ds);
728 let uri = match !default_uri with "" -> None | s -> Some s in
729 Slave.connect uri (connected ds);
731 (* Run the main thread. When this returns, the application has been closed. *)
734 (* Tell the slave thread to exit and wait for it to do so. *)
735 Slave.exit_thread ();