From 4c8bdd342450aad1f49a44a009eae015a44f9572 Mon Sep 17 00:00:00 2001 From: Richard Jones Date: Sat, 26 Sep 2009 12:45:37 +0100 Subject: [PATCH] OCaml example: graphical disk usage viewer. This is an example of how to write an app which uses libguestfs and libvirt, and has a responsive user interface (using threads). It is a Gtk-based "graphical virt-df". Read the top of the 'viewer.ml' file first for instructions on how to compile. This program is not compiled by default. --- .gitignore | 2 + configure.ac | 8 + ocaml/examples/LICENSE | 4 + ocaml/examples/Makefile.am | 29 +- ocaml/examples/README | 4 + ocaml/examples/Throbber.gif | Bin 0 -> 913 bytes ocaml/examples/Throbber.png | Bin 0 -> 223 bytes ocaml/examples/viewer.ml | 732 ++++++++++++++++++++++++++++++++++++++++++++ 8 files changed, 776 insertions(+), 3 deletions(-) create mode 100644 ocaml/examples/Throbber.gif create mode 100644 ocaml/examples/Throbber.png create mode 100644 ocaml/examples/viewer.ml diff --git a/.gitignore b/.gitignore index b57dddd..634da99 100644 --- a/.gitignore +++ b/.gitignore @@ -133,6 +133,8 @@ ocaml/bindtests ocaml/bindtests.ml ocaml/dllmlguestfs.so ocaml/examples/lvs +ocaml/examples/throbber.ml +ocaml/examples/viewer ocaml/guestfs_c_actions.c ocaml/guestfs.ml ocaml/guestfs.mli diff --git a/configure.ac b/configure.ac index 403a998..d3c3e19 100644 --- a/configure.ac +++ b/configure.ac @@ -416,6 +416,14 @@ AC_PROG_OCAML AC_PROG_FINDLIB AM_CONDITIONAL([HAVE_OCAML],[test "x$OCAMLC" != "xno" -a "x$OCAMLFIND" != "xno"]) +dnl Build the OCaml viewer example. +AC_ARG_ENABLE([ocaml-viewer], + [AS_HELP_STRING([--enable-ocaml-viewer], + [enable OCaml viewer (see ocaml/examples) @<:@default=no@:>@])], + [], + [enable_ocaml_viewer=no]) +AM_CONDITIONAL([BUILD_OCAML_VIEWER],[test "x$enable_ocaml_viewer" = "xyes"]) + dnl Check for Perl (optional, for Perl bindings). dnl XXX This isn't quite right, we should check for Perl devel library. AC_CHECK_PROG([PERL],[perl],[perl],[no]) diff --git a/ocaml/examples/LICENSE b/ocaml/examples/LICENSE index 8f0b20b..990daef 100644 --- a/ocaml/examples/LICENSE +++ b/ocaml/examples/LICENSE @@ -1,2 +1,6 @@ All the examples in the ocaml/examples/ subdirectory may be freely copied without any restrictions. + +The files 'Throbber.png' and 'Throbber.gif' come from the source to +Firefox, and you should check the Firefox license before +redistributing those files. diff --git a/ocaml/examples/Makefile.am b/ocaml/examples/Makefile.am index abe6cdf..d088c4a 100644 --- a/ocaml/examples/Makefile.am +++ b/ocaml/examples/Makefile.am @@ -1,10 +1,33 @@ -EXTRA_DIST = LICENSE README lvs.ml +EXTRA_DIST = LICENSE README lvs.ml viewer.ml Throbber.png Throbber.gif + +CLEANFILES = throbber.ml *.cmi *.cmo *.cmx *.o lvs if HAVE_OCAML +noinst_SCRIPTS = lvs + lvs: lvs.ml - $(OCAMLFIND) ocamlopt -I .. mlguestfs.cmxa $< -o $@ + $(OCAMLFIND) ocamlopt -warn-error A -I .. mlguestfs.cmxa $< -o $@ + +if BUILD_OCAML_VIEWER + +noinst_SCRIPTS += viewer + +viewer: throbber.ml viewer.ml + $(OCAMLFIND) ocamlopt \ + -warn-error A \ + -thread \ + -package libvirt,lablgtk2,extlib,xml-light,threads -I .. \ + -predicates init,threads \ + -linkpkg mlguestfs.cmxa gtkThread.cmx \ + $^ -o $@ + +throbber.ml: Throbber.png Throbber.gif + gdk_pixbuf_mlsource --build-list \ + static Throbber.png \ + animation Throbber.gif \ + > $@-t && mv $@-t $@ -CLEANFILES = *.cmi *.cmo *.cmx *.o lvs +endif endif \ No newline at end of file diff --git a/ocaml/examples/README b/ocaml/examples/README index 679f506..663ab24 100644 --- a/ocaml/examples/README +++ b/ocaml/examples/README @@ -4,6 +4,10 @@ Guestfs bindings to the libguestfs API. As they are examples, these are licensed so they can be freely copied and used without any restrictions. +Note that 'viewer' needs some OCaml packages which aren't checked for +by default by the ./configure script. Read the comments at the top of +the source for more details. + Tips: (1) To enable verbose messages, set environment variable LIBGUESTFS_DEBUG=1 diff --git a/ocaml/examples/Throbber.gif b/ocaml/examples/Throbber.gif new file mode 100644 index 0000000000000000000000000000000000000000..deac700d4fc776933c8c82026dc246bfc50dceb2 GIT binary patch literal 913 zcmZ?wbhEHb6k!lyc+9~71X5B`#>U1zK0aw_X$=hxGiT1+v}x0S96<3ux1VcBu(M-; ztC5}oGb2#H;!hSvE(Q(;9gtxlV;NY21x|Xd-pj#oX6v(H0groaGRIZBmUJ$|Yq z%$~;uB-qn00E(YLpglZ?QSF(M_<`vlnt#eI5||oc_AoP$V9$CHQ2ZnU?GZSFYR{Fz z56$TIurnmEG{Njq79hc%^Ae!=DFoUhaun4b5rz*ehtT{Z&XK^@470~sfdqTr%YfpC e0celJF;sg(1U|H)+oLX!z|jJ;C)ohg9%}&U_H8c! literal 0 HcmV?d00001 diff --git a/ocaml/examples/Throbber.png b/ocaml/examples/Throbber.png new file mode 100644 index 0000000000000000000000000000000000000000..7f23bda10352210f9b087c52069b318ee600a451 GIT binary patch literal 223 zcmeAS@N?(olHy`uVBq!ia0vp^A|TAd3?%E9GuQzsi2$DvS0F7VC1q@E?BnB;mX_Ag z&@gl6%uSm%JusZl29#qg3GxeOaCmkj4a7d=jfz;B<4AnLx7`JYD@< J);T3K0RSM(J}>|P literal 0 HcmV?d00001 diff --git a/ocaml/examples/viewer.ml b/ocaml/examples/viewer.ml new file mode 100644 index 0000000..20fa608 --- /dev/null +++ b/ocaml/examples/viewer.ml @@ -0,0 +1,732 @@ +(* This is a virtual machine graphical viewer tool. + * Written by Richard W.M. Jones, Sept. 2009. + * + * It demonstrates some complex programming techniques: OCaml, Gtk+, + * threads, and use of both libguestfs and libvirt from threads. + * + * You will need the following installed in order to compile it: + * - ocaml (http://caml.inria.fr/) + * - ocamlfind (http://projects.camlcity.org/projects/findlib.html/) + * - extlib (http://code.google.com/p/ocaml-extlib/) + * - lablgtk2 (http://wwwfun.kurims.kyoto-u.ac.jp/soft/lsl/lablgtk.html + * - xml-light (http://tech.motion-twin.com/xmllight.html) + * - ocaml-libvirt (http://libvirt.org/ocaml) + * - ocaml-libguestfs + * + * Note that most/all of these are available as packages via Fedora, + * Debian, Ubuntu or GODI. You won't need to compile them from source. + * + * You will also need to configure libguestfs: + * ./configure --enable-ocaml-viewer + * + * All programs in the ocaml/examples subdirectory, including this + * one, may be freely copied without any restrictions. + *) + +(* Architecturally, there is one main thread which does all the Gtk + * calls, and one slave thread which executes all libguestfs and + * libvirt calls. The main thread sends commands to the slave thread, + * which are delivered in a queue and acted on in sequence. Responses + * are delivered back to the main thread as commands finish. + * + * The commands are just OCaml objects (type: Slave.command). The + * queue of commands is an OCaml Queue. The responses are sent by adding + * idle events to the glib main loop[1]. + * + * If a command fails, it causes the input queue to be cleared. In + * this case, a failure response is sent to the main loop which + * causes the display to be reset and possibly an error message to + * be shown. + * + * The global variables [conn], [dom] and [g] are the libvirt + * connection, current domain, and libguestfs handle respectively. + * Because these can be accessed by both threads, they are + * protected from the main thread by access methods which + * (a) prevent the main thread from using them unlocked, and + * (b) prevent the main thread from doing arbitrary / long-running + * operations on them (the main thread must send a command instead). + * + * [1] http://library.gnome.org/devel/gtk-faq/stable/x499.html + *) + +open Printf +open ExtList + +let (//) = Filename.concat + +(* Short names for commonly used modules. *) +module C = Libvirt.Connect +module Cd = Condition +module D = Libvirt.Domain +module G = Guestfs +module M = Mutex +module Q = Queue + +let verbose = ref false (* Verbose mode. *) + +let debug fs = + let f str = if !verbose then ( prerr_string str; prerr_newline () ) in + ksprintf f fs + +(*----------------------------------------------------------------------*) +(* Slave thread. The signature describes what operations the main + * thread can perform, and protects the locked internals of the + * slave thread. + *) +module Slave : sig + type 'a callback = 'a -> unit + + type partinfo = { + pt_name : string; (** device / LV name *) + pt_size : int64; (** in bytes *) + pt_content : string; (** the output of the 'file' command *) + pt_statvfs : G.statvfs option; (** None if not mountable *) + } + + val no_callback : 'a callback + (** Use this as the callback if you don't want a callback. *) + + val set_failure_callback : exn callback -> unit + (** Set the function that is called in the main thread whenever + there is a command failure in the slave. The command queue + is cleared before this is sent. [exn] is the exception + associated with the failure. *) + + val set_busy_callback : [`Busy|`Idle] callback -> unit + (** Set the function that is called in the main thread whenever + the slave thread goes busy or idle. *) + + val exit_thread : unit -> unit + (** [exit_thread ()] causes the slave thread to exit. *) + + val connect : string option -> string option callback -> unit + (** [connect uri cb] connects to libvirt [uri], and calls [cb] + if it completes successfully. Any previous connection is + automatically cleaned up and disconnected. *) + + val get_domains : string list callback -> unit + (** [get_domains cb] gets the list of active domains from libvirt, + and calls [cb domains] with the names of those domains. *) + + val open_domain : string -> partinfo list callback -> unit + (** [open_domain dom cb] sets the domain [dom] as the current + domain, and launches a libguestfs handle for it. Any previously + current domain and libguestfs handle is closed. Once the + libguestfs handle is opened (which usually takes some time), + callback [cb] is called with the list of partitions found + in the guest. *) + + val slave_loop : unit -> unit + (** The slave thread's main loop, running in the slave thread. *) + +end = struct + type partinfo = { + pt_name : string; + pt_size : int64; + pt_content : string; + pt_statvfs : G.statvfs option; + } + + (* Commands sent by the main thread to the slave thread. When + * [cmd] is successfully completed, [callback] will be delivered + * (in the main thread). If [cmd] fails, then the global error + * callback will be delivered in the main thread. + *) + type command = + | Exit_thread + | Connect of string option * string option callback + | Get_domains of string list callback + | Open_domain of string * partinfo list callback + and 'a callback = 'a -> unit + + let string_of_command = function + | Exit_thread -> "Exit_thread" + | Connect (None, _) -> "Connect [no uri]" + | Connect (Some uri, _) -> "Connect " ^ uri + | Get_domains _ -> "Get_domains" + | Open_domain (name, _) -> "Open_domain " ^ name + + let no_callback _ = () + + let failure_cb = ref (fun _ -> ()) + let set_failure_callback cb = failure_cb := cb + + let busy_cb = ref (fun _ -> ()) + let set_busy_callback cb = busy_cb := cb + + (* Execute a function, while holding a mutex. If the function + * fails, ensure we release the mutex before rethrowing the + * exception. + *) + type ('a, 'b) choice = Either of 'a | Or of 'b + let with_lock m f = + M.lock m; + let r = try Either (f ()) with exn -> Or exn in + M.unlock m; + match r with + | Either r -> r + | Or exn -> raise exn + + let q = Q.create () (* queue of commands *) + let q_lock = M.create () + let q_cond = Cd.create () + + (* Send a command message to the slave thread. *) + let send_to_slave c = + debug "sending to slave: %s" (string_of_command c); + with_lock q_lock ( + fun () -> + Q.push c q; + Cd.signal q_cond + ) + + let exit_thread () = + with_lock q_lock (fun () -> Q.clear q); + send_to_slave Exit_thread + + let connect uri cb = + send_to_slave (Connect (uri, cb)) + + let get_domains cb = + send_to_slave (Get_domains cb) + + let open_domain dom cb = + send_to_slave (Open_domain (dom, cb)) + + (* These are not protected by a mutex because we don't allow + * any references to these objects to escape from the slave + * thread. + *) + let conn = ref None (* libvirt connection *) + let dom = ref None (* libvirt domain *) + let g = ref None (* libguestfs handle *) + + let quit = ref false + + let rec slave_loop () = + debug "Slave.slave_loop: waiting for a command"; + let c = + with_lock q_lock ( + fun () -> + while Q.is_empty q do + Cd.wait q_cond q_lock + done; + Q.pop q + ) in + + (try + debug "Slave.slave_loop: executing: %s" (string_of_command c); + !busy_cb `Busy; + exec_command c; + !busy_cb `Idle; + debug "Slave.slave_loop: command succeeded"; + with exn -> + (* If an exception is thrown, it means the command failed. In + * this case we clear the command queue and deliver the failure + * callback in the main thread. + *) + debug "Slave.slave_loop: command failed"; + + with_lock q_lock (fun () -> Q.clear q); + GtkThread.async !failure_cb exn + ); + + if !quit then Thread.exit (); + slave_loop () + + and exec_command = function + | Exit_thread -> + quit := true; (* quit first in case disconnect_all throws an exn *) + disconnect_all () + + | Connect (name, cb) -> + disconnect_all (); + conn := Some (C.connect_readonly ?name ()); + cb name + + | Get_domains cb -> + let conn = Option.get !conn in + let doms = D.get_domains conn [D.ListAll] in + (* Only return the names, so that the libvirt objects + * aren't leaked outside the slave thread. + *) + let doms = List.map D.get_name doms in + cb doms + + | Open_domain (domname, cb) -> + let conn = Option.get !conn in + disconnect_dom (); + dom := Some (D.lookup_by_name conn domname); + let dom = Option.get !dom in + + (* Get the devices. *) + let xml = D.get_xml_desc dom in + let devs = get_devices_from_xml xml in + + (* Create the libguestfs handle and launch it. *) + let g' = G.create () in + List.iter (G.add_drive_ro g') devs; + G.launch g'; + g := Some g'; + + (* Get the list of partitions. *) + let parts = Array.to_list (G.list_partitions g') in + (* Remove any which are PVs. *) + let pvs = Array.to_list (G.pvs g') in + let parts = List.filter (fun part -> not (List.mem part pvs)) parts in + let lvs = Array.to_list (G.lvs g') in + let parts = parts @ lvs in + + let parts = List.map ( + fun part -> + (* Find out the size of each partition. *) + let size = G.blockdev_getsize64 g' part in + + (* Find out what's on each partition. *) + let content = G.file g' part in + + (* Try to mount it. *) + let statvfs = + try + G.mount_ro g' part "/"; + Some (G.statvfs g' "/") + with _ -> None in + G.umount_all g'; + + { pt_name = part; pt_size = size; pt_content = content; + pt_statvfs = statvfs } + ) parts in + + (* Call the callback. *) + cb parts + + (* Close all libvirt/libguestfs handles. *) + and disconnect_all () = + disconnect_dom (); + (match !conn with Some conn -> C.close conn | None -> ()); + conn := None + + (* Close dom and libguestfs handles. *) + and disconnect_dom () = + (match !g with Some g -> G.close g | None -> ()); + g := None; + (match !dom with Some dom -> D.free dom | None -> ()); + dom := None + + (* This would be much simpler if OCaml had either a decent XPath + * implementation, or if ocamlduce was stable enough that we + * could rely on it being available. So this is *not* an example + * of either good OCaml or good programming. XXX + *) + and get_devices_from_xml xml = + let xml = Xml.parse_string xml in + let devices = + match xml with + | Xml.Element ("domain", _, children) -> + let devices = + List.filter_map ( + function + | Xml.Element ("devices", _, devices) -> Some devices + | _ -> None + ) children in + List.concat devices + | _ -> + failwith "get_xml_desc didn't return " in + let rec source_dev_of = function + | [] -> None + | Xml.Element ("source", attrs, _) :: rest -> + (try Some (List.assoc "dev" attrs) + with Not_found -> source_dev_of rest) + | _ :: rest -> source_dev_of rest + in + let rec source_file_of = function + | [] -> None + | Xml.Element ("source", attrs, _) :: rest -> + (try Some (List.assoc "file" attrs) + with Not_found -> source_file_of rest) + | _ :: rest -> source_file_of rest + in + let devs = + List.filter_map ( + function + | Xml.Element ("disk", _, children) -> source_dev_of children + | _ -> None + ) devices in + let files = + List.filter_map ( + function + | Xml.Element ("disk", _, children) -> source_file_of children + | _ -> None + ) devices in + devs @ files +end +(* End of slave thread code. *) +(*----------------------------------------------------------------------*) + +(* Display state. *) +type display_state = { + window : GWindow.window; + vmlist_set : string list -> unit; + throbber_set : [`Busy|`Idle] -> unit; + da : GMisc.drawing_area; + draw : GDraw.drawable; + drawing_area_repaint : unit -> unit; + set_statusbar : string -> unit; + clear_statusbar : unit -> unit; + pango_large_context : GPango.context_rw; + pango_small_context : GPango.context_rw; +} + +(* This is called in the main thread whenever a command fails in the + * slave thread. The command queue has been cleared before this is + * called, so our job here is to reset the main window, and if + * necessary to turn the exception into an error message. + *) +let failure ds exn = + debug "failure callback: %s" (Printexc.to_string exn) + +(* This is called in the main thread when the slave thread transitions + * to busy or idle. + *) +let busy ds state = ds.throbber_set state + +(* Main window and callbacks from menu etc. *) +let main_window opened_domain repaint = + let window_title = "Virtual machine graphical viewer" in + let window = GWindow.window ~width:800 ~height:600 ~title:window_title () in + let vbox = GPack.vbox ~packing:window#add () in + + (* Do the menus. *) + let menubar = GMenu.menu_bar ~packing:vbox#pack () in + let factory = new GMenu.factory menubar in + let accel_group = factory#accel_group in + let connect_menu = factory#add_submenu "_Connect" in + + let factory = new GMenu.factory connect_menu ~accel_group in + let quit_item = factory#add_item "E_xit" ~key:GdkKeysyms._Q in + + (* Quit. *) + let quit _ = GMain.quit (); false in + ignore (window#connect#destroy ~callback:GMain.quit); + ignore (window#event#connect#delete ~callback:quit); + ignore (quit_item#connect#activate + ~callback:(fun () -> ignore (quit ()); ())); + + (* Top status area. *) + let hbox = GPack.hbox ~border_width:4 ~packing:vbox#pack () in + ignore (GMisc.label ~text:"Guest: " ~packing:hbox#pack ()); + + (* List of VMs. *) + let vmcombo = GEdit.combo_box_text ~packing:hbox#pack () in + let vmlist_set names = + let combo, (model, column) = vmcombo in + model#clear (); + List.iter ( + fun name -> + let row = model#append () in + model#set ~row ~column name + ) names + in + + (* Throbber, http://faq.pygtk.org/index.py?req=show&file=faq23.037.htp *) + let static = Throbber.static () in + (*let animation = Throbber.animation () in*) + let throbber = + GMisc.image ~pixbuf:static ~packing:(hbox#pack ~from:`END) () in + let throbber_set = function + | `Busy -> (*throbber#set_pixbuf animation*) + (* Workaround because no binding for GdkPixbufAnimation: *) + let file = Filename.dirname Sys.argv.(0) // "Throbber.gif" in + throbber#set_file file + | `Idle -> throbber#set_pixbuf static + in + + (* Drawing area. *) + let da = GMisc.drawing_area ~packing:(vbox#pack ~expand:true ~fill:true) () in + da#misc#realize (); + let draw = new GDraw.drawable da#misc#window in + window#set_geometry_hints ~min_size:(80,80) (da :> GObj.widget); + + (* Calling this can be used to force a redraw of the drawing area. *) + let drawing_area_repaint () = GtkBase.Widget.queue_draw da#as_widget in + + (* Pango contexts used to draw large and small text. *) + let pango_large_context = da#misc#create_pango_context in + pango_large_context#set_font_description (Pango.Font.from_string "Sans 12"); + let pango_small_context = da#misc#create_pango_context in + pango_small_context#set_font_description (Pango.Font.from_string "Sans 8"); + + (* Status bar at the bottom of the screen. *) + let set_statusbar = + let statusbar = GMisc.statusbar ~packing:vbox#pack () in + let context = statusbar#new_context ~name:"Standard" in + ignore (context#push window_title); + fun msg -> + context#pop (); + ignore (context#push msg) + in + let clear_statusbar () = set_statusbar "" in + + (* Display the window and enter Gtk+ main loop. *) + window#show (); + window#add_accel_group accel_group; + + (* display_state which is threaded through all the other callbacks, + * allowing callbacks to update the window. + *) + let ds = + { window = window; vmlist_set = vmlist_set; throbber_set = throbber_set; + da = da; draw = draw; drawing_area_repaint = drawing_area_repaint; + set_statusbar = set_statusbar; clear_statusbar = clear_statusbar; + pango_large_context = pango_large_context; + pango_small_context = pango_small_context; } in + + (* Set up some callbacks which require access to the display_state. *) + ignore ( + let combo, (model, column) = vmcombo in + combo#connect#changed + ~callback:( + fun () -> + match combo#active_iter with + | None -> () + | Some row -> + let name = model#get ~row ~column in + ds.set_statusbar (sprintf "Opening %s ..." name); + Slave.open_domain name (opened_domain ds)) + ); + + ignore (da#event#connect#expose ~callback:(repaint ds)); + + ds + +(* Partition info for the current domain, if one is loaded. *) +let parts = ref None + +(* This is called in the main thread when we've connected to libvirt. *) +let rec connected ds uri = + debug "connected callback"; + let msg = + match uri with + | None -> "Connected to libvirt" + | Some uri -> sprintf "Connected to %s" uri in + ds.set_statusbar msg; + Slave.get_domains (got_domains ds) + +(* This is called in the main thread when we've got the list of domains. *) +and got_domains ds doms = + debug "got_domains callback: (%s)" (String.concat " " doms); + ds.vmlist_set doms + +(* This is called when we have opened a domain. *) +and opened_domain ds parts' = + debug "opened_domain callback"; + ds.clear_statusbar (); + parts := Some parts'; + ds.drawing_area_repaint () + +and repaint ds _ = + (match !parts with + | None -> () + | Some parts -> + real_repaint ds parts + ); + false + +and real_repaint ds parts = + let width, height = ds.draw#size in + ds.draw#set_background `WHITE; + ds.draw#set_foreground `WHITE; + ds.draw#rectangle ~x:0 ~y:0 ~width ~height ~filled:true (); + + let sum = List.fold_left Int64.add 0L in + let totsize = sum (List.map (fun { Slave.pt_size = size } -> size) parts) in + + let scale = (float height -. 16.) /. Int64.to_float totsize in + + (* Calculate the height in pixels of each partition, if we were to + * display it at a true relative size. + *) + let parts = + List.map ( + fun ({ Slave.pt_size = size } as part) -> + let h = scale *. Int64.to_float size in + (h, part) + ) parts in + + (* + if !verbose then ( + eprintf "real_repaint: before borrowing:\n"; + List.iter ( + fun (h, part) -> + eprintf "%s\t%g pix\n" part.Slave.pt_name h + ) parts + ); + *) + + (* Now adjust the heights of small partitions so they "borrow" some + * height from the larger partitions. + *) + let min_h = 32. in + let rec borrow needed = function + | [] -> 0., [] + | (h, part) :: parts -> + let spare = h -. min_h in + if spare >= needed then ( + needed, (h -. needed, part) :: parts + ) else if spare > 0. then ( + let needed = needed -. spare in + let spare', parts = borrow needed parts in + spare +. spare', (h -. spare, part) :: parts + ) else ( + let spare', parts = borrow needed parts in + spare', (h, part) :: parts + ) + in + let rec loop = function + | parts, [] -> List.rev parts + | prev, ((h, part) :: parts) -> + let needed = min_h -. h in + let h, prev, parts = + if needed > 0. then ( + (* Find some spare height in a succeeding partition(s). *) + let spare, parts = borrow needed parts in + (* Or if not, in a preceeding partition(s). *) + let spare, prev = + if spare = 0. then borrow needed prev else spare, prev in + h +. spare, prev, parts + ) else ( + h, prev, parts + ) in + loop (((h, part) :: prev), parts) + in + let parts = loop ([], parts) in + + (* + if !verbose then ( + eprintf "real_repaint: after borrowing:\n"; + List.iter ( + fun (h, part) -> + eprintf "%s\t%g pix\n" part.Slave.pt_name h + ) parts + ); + *) + + (* Calculate the proportion space used in each partition. *) + let parts = List.map ( + fun (h, part) -> + let used = + match part.Slave.pt_statvfs with + | None -> 0. + | Some { G.bavail = bavail; blocks = blocks } -> + let num = Int64.to_float (Int64.sub blocks bavail) in + let denom = Int64.to_float blocks in + num /. denom in + (h, used, part) + ) parts in + + (* Draw it. *) + ignore ( + List.fold_left ( + fun y (h, used, part) -> + (* This partition occupies pixels 8+y .. 8+y+h-1 *) + let yb = 8 + int_of_float y + and yt = 8 + int_of_float (y +. h) in + + ds.draw#set_foreground `WHITE; + ds.draw#rectangle ~x:8 ~y:yb ~width:(width-16) ~height:(yt-yb) + ~filled:true (); + + let col = + if used < 0.6 then `NAME "grey" + else if used < 0.8 then `NAME "pink" + else if used < 0.9 then `NAME "hot pink" + else `NAME "red" in + ds.draw#set_foreground col; + let w = int_of_float (used *. (float width -. 16.)) in + ds.draw#rectangle ~x:8 ~y:yb ~width:w ~height:(yt-yb) ~filled:true (); + + ds.draw#set_foreground `BLACK; + ds.draw#rectangle ~x:8 ~y:yb ~width:(width-16) ~height:(yt-yb) (); + + (* Large text - the device name. *) + let txt = ds.pango_large_context#create_layout in + Pango.Layout.set_text txt part.Slave.pt_name; + let fore = `NAME "dark slate grey" in + ds.draw#put_layout ~x:12 ~y:(yb+4) ~fore txt; + + let { Pango.height = txtheight; Pango.width = txtwidth } = + Pango.Layout.get_pixel_extent txt in + + (* Small text below - the content. *) + let txt = ds.pango_small_context#create_layout in + Pango.Layout.set_text txt part.Slave.pt_content; + let fore = `BLACK in + ds.draw#put_layout ~x:12 ~y:(yb+4+txtheight) ~fore txt; + + (* Small text right - size. *) + let size = + match part.Slave.pt_statvfs with + | None -> printable_size part.Slave.pt_size + | Some { G.blocks = blocks; bsize = bsize } -> + let bytes = Int64.mul blocks bsize in + let pc = 100. *. used in + sprintf "%s (%.1f%% used)" (printable_size bytes) pc in + let txt = ds.pango_small_context#create_layout in + Pango.Layout.set_text txt size; + ds.draw#put_layout ~x:(16+txtwidth) ~y:(yb+4) ~fore txt; + + (y +. h) + ) 0. parts + ) + +and printable_size bytes = + if bytes < 16_384L then sprintf "%Ld bytes" bytes + else if bytes < 16_777_216L then + sprintf "%Ld KiB" (Int64.div bytes 1024L) + else if bytes < 17_179_869_184L then + sprintf "%Ld MiB" (Int64.div bytes 1_048_576L) + else + sprintf "%Ld GiB" (Int64.div bytes 1_073_741_824L) + +let default_uri = ref "" + +let argspec = Arg.align [ + "-verbose", Arg.Set verbose, "Verbose mode"; + "-connect", Arg.Set_string default_uri, "Connect to libvirt URI"; +] + +let anon_fun _ = + failwith (sprintf "%s: unknown command line argument" + (Filename.basename Sys.executable_name)) + +let usage_msg = + sprintf "\ + +%s: graphical virtual machine disk usage viewer + +Options:" + (Filename.basename Sys.executable_name) + +let main () = + Arg.parse argspec anon_fun usage_msg; + + (* Start up the slave thread. *) + let slave = Thread.create Slave.slave_loop () in + + (* Set up the display. *) + let ds = main_window opened_domain repaint in + + Slave.set_failure_callback (failure ds); + Slave.set_busy_callback (busy ds); + let uri = match !default_uri with "" -> None | s -> Some s in + Slave.connect uri (connected ds); + + (* Run the main thread. When this returns, the application has been closed. *) + GtkThread.main (); + + (* Tell the slave thread to exit and wait for it to do so. *) + Slave.exit_thread (); + Thread.join slave + +let () = + main () -- 1.8.3.1