ocaml/examples/viewer.ml

   1 (* This is a virtual machine graphical viewer tool.
   2  * Written by Richard W.M. Jones, Sept. 2009.
   3  *
   4  * It demonstrates some complex programming techniques: OCaml, Gtk+,
   5  * threads, and use of both libguestfs and libvirt from threads.
   6  *
   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  *   - cduce and ocamlduce (http://cduce.org/)
  14  *   - ocaml-libvirt (http://libvirt.org/ocaml)
  15  *   - ocaml-libguestfs
  16  *
  17  * Note that most/all of these are available as packages via Fedora,
  18  * Debian, Ubuntu or GODI.  You won't need to compile them from source.
  19  *
  20  * You will also need to configure libguestfs:
  21  *   ./configure --enable-ocaml-viewer
  22  *
  23  * All programs in the ocaml/examples subdirectory, including this
  24  * one, may be freely copied without any restrictions.
  25  *)
  26
  27 (* Architecturally, there is one main thread which does all the Gtk
  28  * calls, and one slave thread which executes all libguestfs and
  29  * libvirt calls.  The main thread sends commands to the slave thread,
  30  * which are delivered in a queue and acted on in sequence.  Responses
  31  * are delivered back to the main thread as commands finish.
  32  *
  33  * The commands are just OCaml objects (type: Slave.command).  The
  34  * queue of commands is an OCaml Queue.  The responses are sent by adding
  35  * idle events to the glib main loop[1].
  36  *
  37  * If a command fails, it causes the input queue to be cleared.  In
  38  * this case, a failure response is sent to the main loop which
  39  * causes the display to be reset and possibly an error message to
  40  * be shown.
  41  *
  42  * The global variables [conn], [dom] and [g] are the libvirt
  43  * connection, current domain, and libguestfs handle respectively.
  44  * Because these can be accessed by both threads, they are
  45  * protected from the main thread by access methods which
  46  * (a) prevent the main thread from using them unlocked, and
  47  * (b) prevent the main thread from doing arbitrary / long-running
  48  * operations on them (the main thread must send a command instead).
  49  *
  50  * [1] http://library.gnome.org/devel/gtk-faq/stable/x499.html
  51  *)
  52
  53 open Printf
  54 open ExtList
  55
  56 let (//) = Filename.concat
  57
  58 (* Short names for commonly used modules. *)
  59 module C = Libvirt.Connect
  60 module Cd = Condition
  61 module D = Libvirt.Domain
  62 module G = Guestfs
  63 module M = Mutex
  64 module Q = Queue
  65
  66 let verbose = ref false                       (* Verbose mode. *)
  67
  68 let debug fs =
  69   let f str = if !verbose then ( prerr_string str; prerr_newline () ) in
  70   ksprintf f fs
  71
  72 (*----------------------------------------------------------------------*)
  73 (* Slave thread.  The signature describes what operations the main
  74  * thread can perform, and protects the locked internals of the
  75  * slave thread.
  76  *)
  77 module Slave : sig
  78   type 'a callback = 'a -> unit
  79
  80   type partinfo = {
  81     pt_name : string;                (** device / LV name *)
  82     pt_size : int64;                (** in bytes *)
  83     pt_content : string;        (** the output of the 'file' command *)
  84     pt_statvfs : G.statvfs option; (** None if not mountable *)
  85   }
  86
  87   val no_callback : 'a callback
  88     (** Use this as the callback if you don't want a callback. *)
  89
  90   val set_failure_callback : exn callback -> unit
  91     (** Set the function that is called in the main thread whenever
  92         there is a command failure in the slave.  The command queue
  93         is cleared before this is sent.  [exn] is the exception
  94         associated with the failure. *)
  95
  96   val set_busy_callback : [`Busy|`Idle] callback -> unit
  97     (** Set the function that is called in the main thread whenever
  98         the slave thread goes busy or idle. *)
  99
 100   val exit_thread : unit -> unit
 101     (** [exit_thread ()] causes the slave thread to exit. *)
 102
 103   val connect : string option -> string option callback -> unit
 104     (** [connect uri cb] connects to libvirt [uri], and calls [cb]
 105         if it completes successfully.  Any previous connection is
 106         automatically cleaned up and disconnected. *)
 107
 108   val get_domains : string list callback -> unit
 109     (** [get_domains cb] gets the list of active domains from libvirt,
 110         and calls [cb domains] with the names of those domains. *)
 111
 112   val open_domain : string -> partinfo list callback -> unit
 113     (** [open_domain dom cb] sets the domain [dom] as the current
 114         domain, and launches a libguestfs handle for it.  Any previously
 115         current domain and libguestfs handle is closed.  Once the
 116         libguestfs handle is opened (which usually takes some time),
 117         callback [cb] is called with the list of partitions found
 118         in the guest. *)
 119
 120   val slave_loop : unit -> unit
 121     (** The slave thread's main loop, running in the slave thread. *)
 122
 123 end = struct
 124   type partinfo = {
 125     pt_name : string;
 126     pt_size : int64;
 127     pt_content : string;
 128     pt_statvfs : G.statvfs option;
 129   }
 130
 131   (* Commands sent by the main thread to the slave thread.  When
 132    * [cmd] is successfully completed, [callback] will be delivered
 133    * (in the main thread).  If [cmd] fails, then the global error
 134    * callback will be delivered in the main thread.
 135    *)
 136   type command =
 137     | Exit_thread
 138     | Connect of string option * string option callback
 139     | Get_domains of string list callback
 140     | Open_domain of string * partinfo list callback
 141   and 'a callback = 'a -> unit
 142
 143   let string_of_command = function
 144     | Exit_thread -> "Exit_thread"
 145     | Connect (None, _) -> "Connect [no uri]"
 146     | Connect (Some uri, _) -> "Connect " ^ uri
 147     | Get_domains _ -> "Get_domains"
 148     | Open_domain (name, _) -> "Open_domain " ^ name
 149
 150   let no_callback _ = ()
 151
 152   let failure_cb = ref (fun _ -> ())
 153   let set_failure_callback cb = failure_cb := cb
 154
 155   let busy_cb = ref (fun _ -> ())
 156   let set_busy_callback cb = busy_cb := cb
 157
 158   (* Execute a function, while holding a mutex.  If the function
 159    * fails, ensure we release the mutex before rethrowing the
 160    * exception.
 161    *)
 162   type ('a, 'b) choice = Either of 'a | Or of 'b
 163   let with_lock m f =
 164     M.lock m;
 165     let r = try Either (f ()) with exn -> Or exn in
 166     M.unlock m;
 167     match r with
 168     | Either r -> r
 169     | Or exn -> raise exn
 170
 171   let q = Q.create ()                        (* queue of commands *)
 172   let q_lock = M.create ()
 173   let q_cond = Cd.create ()
 174
 175   (* Send a command message to the slave thread. *)
 176   let send_to_slave c =
 177     debug "sending to slave: %s" (string_of_command c);
 178     with_lock q_lock (
 179       fun () ->
 180         Q.push c q;
 181         Cd.signal q_cond
 182     )
 183
 184   let exit_thread () =
 185     with_lock q_lock (fun () -> Q.clear q);
 186     send_to_slave Exit_thread
 187
 188   let connect uri cb =
 189     send_to_slave (Connect (uri, cb))
 190
 191   let get_domains cb =
 192     send_to_slave (Get_domains cb)
 193
 194   let open_domain dom cb =
 195     send_to_slave (Open_domain (dom, cb))
 196
 197   (* These are not protected by a mutex because we don't allow
 198    * any references to these objects to escape from the slave
 199    * thread.
 200    *)
 201   let conn = ref None                        (* libvirt connection *)
 202   let dom = ref None                        (* libvirt domain *)
 203   let g = ref None                        (* libguestfs handle *)
 204
 205   let quit = ref false
 206
 207   let rec slave_loop () =
 208     debug "Slave.slave_loop: waiting for a command";
 209     let c =
 210       with_lock q_lock (
 211         fun () ->
 212           while Q.is_empty q do
 213             Cd.wait q_cond q_lock
 214           done;
 215           Q.pop q
 216       ) in
 217
 218     (try
 219        debug "Slave.slave_loop: executing: %s" (string_of_command c);
 220        !busy_cb `Busy;
 221        exec_command c;
 222        !busy_cb `Idle;
 223        debug "Slave.slave_loop: command succeeded";
 224      with exn ->
 225        (* If an exception is thrown, it means the command failed.  In
 226         * this case we clear the command queue and deliver the failure
 227         * callback in the main thread.
 228         *)
 229        debug "Slave.slave_loop: command failed";
 230
 231        !busy_cb `Idle;
 232        with_lock q_lock (fun () -> Q.clear q);
 233        GtkThread.async !failure_cb exn
 234     );
 235
 236     if !quit then Thread.exit ();
 237     slave_loop ()
 238
 239   and exec_command = function
 240     | Exit_thread ->
 241         quit := true; (* quit first in case disconnect_all throws an exn *)
 242         disconnect_all ()
 243
 244     | Connect (name, cb) ->
 245         disconnect_all ();
 246         conn := Some (C.connect_readonly ?name ());
 247         cb name
 248
 249     | Get_domains cb ->
 250         let conn = Option.get !conn in
 251         let doms = D.get_domains conn [D.ListAll] in
 252         (* Only return the names, so that the libvirt objects
 253          * aren't leaked outside the slave thread.
 254          *)
 255         let doms = List.map D.get_name doms in
 256         cb doms
 257
 258     | Open_domain (domname, cb) ->
 259         let conn = Option.get !conn in
 260         disconnect_dom ();
 261         dom := Some (D.lookup_by_name conn domname);
 262         let dom = Option.get !dom in
 263
 264         (* Get the devices. *)
 265         let xml = D.get_xml_desc dom in
 266         let devs = get_devices_from_xml xml in
 267
 268         (* Create the libguestfs handle and launch it. *)
 269         let g' = G.create () in
 270         List.iter (G.add_drive_ro g') devs;
 271         G.launch g';
 272         g := Some g';
 273
 274         (* Get the list of partitions. *)
 275         let parts = Array.to_list (G.list_partitions g') in
 276         (* Remove any which are PVs. *)
 277         let pvs = Array.to_list (G.pvs g') in
 278         let parts = List.filter (fun part -> not (List.mem part pvs)) parts in
 279         let lvs = Array.to_list (G.lvs g') in
 280         let parts = parts @ lvs in
 281
 282         let parts = List.map (
 283           fun part ->
 284             (* Find out the size of each partition. *)
 285             let size = G.blockdev_getsize64 g' part in
 286
 287             (* Find out what's on each partition. *)
 288             let content = G.file g' part in
 289
 290             (* Try to mount it. *)
 291             let statvfs =
 292               try
 293                 G.mount_ro g' part "/";
 294                 Some (G.statvfs g' "/")
 295               with _ -> None in
 296             G.umount_all g';
 297
 298             { pt_name = part; pt_size = size; pt_content = content;
 299               pt_statvfs = statvfs }
 300         ) parts in
 301
 302         (* Call the callback. *)
 303         cb parts
 304
 305   (* Close all libvirt/libguestfs handles. *)
 306   and disconnect_all () =
 307     disconnect_dom ();
 308     (match !conn with Some conn -> C.close conn | None -> ());
 309     conn := None
 310
 311   (* Close dom and libguestfs handles. *)
 312   and disconnect_dom () =
 313     (match !g with Some g -> G.close g | None -> ());
 314     g := None;
 315     (match !dom with Some dom -> D.free dom | None -> ());
 316     dom := None
 317
 318   and get_devices_from_xml xml =
 319     (* Lengthy discussion of the merits or otherwise of this code here:
 320      * http://groups.google.com/group/fa.caml/browse_thread/thread/48e05d49b0f21b8a/5296bceb31ebfff3
 321      *)
 322     let xml = Xmllight_loader.from_string xml in
 323     let xs = {{ [xml] }} in
 324     let xs = {{ (((xs.(<domain..>_)) / .(<devices..>_)) / .(<disk..>_)) / }} in
 325     let xs = {{ map xs with
 326                 | <source dev=(Latin1 & s) ..>_
 327                 | <source file=(Latin1 & s) ..>_ -> [s]
 328                 | _ -> [] }} in
 329     {: xs :}
 330 end
 331 (* End of slave thread code. *)
 332 (*----------------------------------------------------------------------*)
 333
 334 (* Display state. *)
 335 type display_state = {
 336   window : GWindow.window;
 337   vmlist_set : string list -> unit;
 338   throbber_set : [`Busy|`Idle] -> unit;
 339   da : GMisc.drawing_area;
 340   draw : GDraw.drawable;
 341   drawing_area_repaint : unit -> unit;
 342   set_statusbar : string -> unit;
 343   clear_statusbar : unit -> unit;
 344   pango_large_context : GPango.context_rw;
 345   pango_small_context : GPango.context_rw;
 346 }
 347
 348 (* This is called in the main thread whenever a command fails in the
 349  * slave thread.  The command queue has been cleared before this is
 350  * called, so our job here is to reset the main window, and if
 351  * necessary to turn the exception into an error message.
 352  *)
 353 let failure ds exn =
 354   let title = "Error" in
 355   let msg = Printexc.to_string exn in
 356   debug "failure callback: %s" msg;
 357   let icon = GMisc.image () in
 358   icon#set_stock `DIALOG_ERROR;
 359   icon#set_icon_size `DIALOG;
 360   GToolbox.message_box ~title ~icon msg
 361
 362 (* This is called in the main thread when the slave thread transitions
 363  * to busy or idle.
 364  *)
 365 let busy ds state = ds.throbber_set state
 366
 367 (* Main window and callbacks from menu etc. *)
 368 let main_window opened_domain repaint =
 369   let window_title = "Virtual machine graphical viewer" in
 370   let window = GWindow.window ~width:800 ~height:600 ~title:window_title () in
 371   let vbox = GPack.vbox ~packing:window#add () in
 372
 373   (* Do the menus. *)
 374   let menubar = GMenu.menu_bar ~packing:vbox#pack () in
 375   let factory = new GMenu.factory menubar in
 376   let accel_group = factory#accel_group in
 377   let connect_menu = factory#add_submenu "_Connect" in
 378
 379   let factory = new GMenu.factory connect_menu ~accel_group in
 380   let quit_item = factory#add_item "E_xit" ~key:GdkKeysyms._Q in
 381
 382   (* Quit. *)
 383   let quit _ = GMain.quit (); false in
 384   ignore (window#connect#destroy ~callback:GMain.quit);
 385   ignore (window#event#connect#delete ~callback:quit);
 386   ignore (quit_item#connect#activate
 387             ~callback:(fun () -> ignore (quit ()); ()));
 388
 389   (* Top status area. *)
 390   let hbox = GPack.hbox ~border_width:4 ~packing:vbox#pack () in
 391   ignore (GMisc.label ~text:"Guest: " ~packing:hbox#pack ());
 392
 393   (* List of VMs. *)
 394   let vmcombo = GEdit.combo_box_text ~packing:hbox#pack () in
 395   let vmlist_set names =
 396     let combo, (model, column) = vmcombo in
 397     model#clear ();
 398     List.iter (
 399       fun name ->
 400         let row = model#append () in
 401         model#set ~row ~column name
 402     ) names
 403   in
 404
 405   (* Throbber, http://faq.pygtk.org/index.py?req=show&file=faq23.037.htp *)
 406   let static = Throbber.static () in
 407   (*let animation = Throbber.animation () in*)
 408   let throbber =
 409     GMisc.image ~pixbuf:static ~packing:(hbox#pack ~from:`END) () in
 410   let throbber_set = function
 411     | `Busy -> (*throbber#set_pixbuf animation*)
 412         (* Workaround because no binding for GdkPixbufAnimation: *)
 413         let file = Filename.dirname Sys.argv.(0) // "Throbber.gif" in
 414         throbber#set_file file
 415     | `Idle -> throbber#set_pixbuf static
 416   in
 417
 418   (* Drawing area. *)
 419   let da = GMisc.drawing_area ~packing:(vbox#pack ~expand:true ~fill:true) () in
 420   da#misc#realize ();
 421   let draw = new GDraw.drawable da#misc#window in
 422   window#set_geometry_hints ~min_size:(80,80) (da :> GObj.widget);
 423
 424   (* Calling this can be used to force a redraw of the drawing area. *)
 425   let drawing_area_repaint () = GtkBase.Widget.queue_draw da#as_widget in
 426
 427   (* Pango contexts used to draw large and small text. *)
 428   let pango_large_context = da#misc#create_pango_context in
 429   pango_large_context#set_font_description (Pango.Font.from_string "Sans 12");
 430   let pango_small_context = da#misc#create_pango_context in
 431   pango_small_context#set_font_description (Pango.Font.from_string "Sans 8");
 432
 433   (* Status bar at the bottom of the screen. *)
 434   let set_statusbar =
 435     let statusbar = GMisc.statusbar ~packing:vbox#pack () in
 436     let context = statusbar#new_context ~name:"Standard" in
 437     ignore (context#push window_title);
 438     fun msg ->
 439       context#pop ();
 440       ignore (context#push msg)
 441   in
 442   let clear_statusbar () = set_statusbar "" in
 443
 444   (* Display the window and enter Gtk+ main loop. *)
 445   window#show ();
 446   window#add_accel_group accel_group;
 447
 448   (* display_state which is threaded through all the other callbacks,
 449    * allowing callbacks to update the window.
 450    *)
 451   let ds =
 452     { window = window; vmlist_set = vmlist_set; throbber_set = throbber_set;
 453       da = da; draw = draw; drawing_area_repaint = drawing_area_repaint;
 454       set_statusbar = set_statusbar; clear_statusbar = clear_statusbar;
 455       pango_large_context = pango_large_context;
 456       pango_small_context = pango_small_context; } in
 457
 458   (* Set up some callbacks which require access to the display_state. *)
 459   ignore (
 460     let combo, (model, column) = vmcombo in
 461     combo#connect#changed
 462       ~callback:(
 463         fun () ->
 464           match combo#active_iter with
 465           | None -> ()
 466           | Some row ->
 467               let name = model#get ~row ~column in
 468               ds.set_statusbar (sprintf "Opening %s ..." name);
 469               Slave.open_domain name (opened_domain ds))
 470   );
 471
 472   ignore (da#event#connect#expose ~callback:(repaint ds));
 473
 474   ds
 475
 476 (* Partition info for the current domain, if one is loaded. *)
 477 let parts = ref None
 478
 479 (* This is called in the main thread when we've connected to libvirt. *)
 480 let rec connected ds uri =
 481   debug "connected callback";
 482   let msg =
 483     match uri with
 484     | None -> "Connected to libvirt"
 485     | Some uri -> sprintf "Connected to %s" uri in
 486   ds.set_statusbar msg;
 487   Slave.get_domains (got_domains ds)
 488
 489 (* This is called in the main thread when we've got the list of domains. *)
 490 and got_domains ds doms =
 491   debug "got_domains callback: (%s)" (String.concat " " doms);
 492   ds.vmlist_set doms
 493
 494 (* This is called when we have opened a domain. *)
 495 and opened_domain ds parts' =
 496   debug "opened_domain callback";
 497   ds.clear_statusbar ();
 498   parts := Some parts';
 499   ds.drawing_area_repaint ()
 500
 501 and repaint ds _ =
 502   (match !parts with
 503    | None -> ()
 504    | Some parts ->
 505        real_repaint ds parts
 506   );
 507   false
 508
 509 and real_repaint ds parts =
 510   let width, height = ds.draw#size in
 511   ds.draw#set_background `WHITE;
 512   ds.draw#set_foreground `WHITE;
 513   ds.draw#rectangle ~x:0 ~y:0 ~width ~height ~filled:true ();
 514
 515   let sum = List.fold_left Int64.add 0L in
 516   let totsize = sum (List.map (fun { Slave.pt_size = size } -> size) parts) in
 517
 518   let scale = (float height -. 16.) /. Int64.to_float totsize in
 519
 520   (* Calculate the height in pixels of each partition, if we were to
 521    * display it at a true relative size.
 522    *)
 523   let parts =
 524     List.map (
 525       fun ({ Slave.pt_size = size } as part) ->
 526         let h = scale *. Int64.to_float size in
 527         (h, part)
 528     ) parts in
 529
 530   (*
 531   if !verbose then (
 532     eprintf "real_repaint: before borrowing:\n";
 533     List.iter (
 534       fun (h, part) ->
 535         eprintf "%s\t%g pix\n" part.Slave.pt_name h
 536     ) parts
 537   );
 538   *)
 539
 540   (* Now adjust the heights of small partitions so they "borrow" some
 541    * height from the larger partitions.
 542    *)
 543   let min_h = 32. in
 544   let rec borrow needed = function
 545     | [] -> 0., []
 546     | (h, part) :: parts ->
 547         let spare = h -. min_h in
 548         if spare >= needed then (
 549           needed, (h -. needed, part) :: parts
 550         ) else if spare > 0. then (
 551           let needed = needed -. spare in
 552           let spare', parts = borrow needed parts in
 553           spare +. spare', (h -. spare, part) :: parts
 554         ) else (
 555           let spare', parts = borrow needed parts in
 556           spare', (h, part) :: parts
 557         )
 558   in
 559   let rec loop = function
 560     | parts, [] -> List.rev parts
 561     | prev, ((h, part) :: parts) ->
 562         let needed = min_h -. h in
 563         let h, prev, parts =
 564           if needed > 0. then (
 565             (* Find some spare height in a succeeding partition(s). *)
 566             let spare, parts = borrow needed parts in
 567             (* Or if not, in a preceeding partition(s). *)
 568             let spare, prev =
 569               if spare = 0. then borrow needed prev else spare, prev in
 570             h +. spare, prev, parts
 571           ) else (
 572             h, prev, parts
 573           ) in
 574         loop (((h, part) :: prev), parts)
 575   in
 576   let parts = loop ([], parts) in
 577
 578   (*
 579   if !verbose then (
 580     eprintf "real_repaint: after borrowing:\n";
 581     List.iter (
 582       fun (h, part) ->
 583         eprintf "%s\t%g pix\n" part.Slave.pt_name h
 584     ) parts
 585   );
 586   *)
 587
 588   (* Calculate the proportion space used in each partition. *)
 589   let parts = List.map (
 590     fun (h, part) ->
 591       let used =
 592         match part.Slave.pt_statvfs with
 593         | None -> 0.
 594         | Some { G.bavail = bavail; blocks = blocks } ->
 595             let num = Int64.to_float (Int64.sub blocks bavail) in
 596             let denom = Int64.to_float blocks in
 597             num /. denom in
 598       (h, used, part)
 599   ) parts in
 600
 601   (* Draw it. *)
 602   ignore (
 603     List.fold_left (
 604       fun y (h, used, part) ->
 605         (* This partition occupies pixels 8+y .. 8+y+h-1 *)
 606         let yb = 8 + int_of_float y
 607         and yt = 8 + int_of_float (y +. h) in
 608
 609         ds.draw#set_foreground `WHITE;
 610         ds.draw#rectangle ~x:8 ~y:yb ~width:(width-16) ~height:(yt-yb)
 611           ~filled:true ();
 612
 613         let col =
 614           if used < 0.6 then `NAME "grey"
 615           else if used < 0.8 then `NAME "pink"
 616           else if used < 0.9 then `NAME "hot pink"
 617           else `NAME "red" in
 618         ds.draw#set_foreground col;
 619         let w = int_of_float (used *. (float width -. 16.)) in
 620         ds.draw#rectangle ~x:8 ~y:yb ~width:w ~height:(yt-yb) ~filled:true ();
 621
 622         ds.draw#set_foreground `BLACK;
 623         ds.draw#rectangle ~x:8 ~y:yb ~width:(width-16) ~height:(yt-yb) ();
 624
 625         (* Large text - the device name. *)
 626         let txt = ds.pango_large_context#create_layout in
 627         Pango.Layout.set_text txt part.Slave.pt_name;
 628         let fore = `NAME "dark slate grey" in
 629         ds.draw#put_layout ~x:12 ~y:(yb+4) ~fore txt;
 630
 631         let { Pango.height = txtheight; Pango.width = txtwidth } =
 632           Pango.Layout.get_pixel_extent txt in
 633
 634         (* Small text below - the content. *)
 635         let txt = ds.pango_small_context#create_layout in
 636         Pango.Layout.set_text txt part.Slave.pt_content;
 637         let fore = `BLACK in
 638         ds.draw#put_layout ~x:12 ~y:(yb+4+txtheight) ~fore txt;
 639
 640         (* Small text right - size. *)
 641         let size =
 642           match part.Slave.pt_statvfs with
 643           | None -> printable_size part.Slave.pt_size
 644           | Some { G.blocks = blocks; bsize = bsize } ->
 645               let bytes = Int64.mul blocks bsize in
 646               let pc = 100. *. used in
 647               sprintf "%s (%.1f%% used)" (printable_size bytes) pc in
 648         let txt = ds.pango_small_context#create_layout in
 649         Pango.Layout.set_text txt size;
 650         ds.draw#put_layout ~x:(16+txtwidth) ~y:(yb+4) ~fore txt;
 651
 652         (y +. h)
 653     ) 0. parts
 654   )
 655
 656 and printable_size bytes =
 657   if bytes < 16_384L then sprintf "%Ld bytes" bytes
 658   else if bytes < 16_777_216L then
 659     sprintf "%Ld KiB" (Int64.div bytes 1024L)
 660   else if bytes < 17_179_869_184L then
 661     sprintf "%Ld MiB" (Int64.div bytes 1_048_576L)
 662   else
 663     sprintf "%Ld GiB" (Int64.div bytes 1_073_741_824L)
 664
 665 let default_uri = ref ""
 666
 667 let argspec = Arg.align [
 668   "-verbose", Arg.Set verbose, "Verbose mode";
 669   "-connect", Arg.Set_string default_uri, "Connect to libvirt URI";
 670 ]
 671
 672 let anon_fun _ =
 673   failwith (sprintf "%s: unknown command line argument"
 674               (Filename.basename Sys.executable_name))
 675
 676 let usage_msg =
 677   sprintf "\
 678
 679 %s: graphical virtual machine disk usage viewer
 680
 681 Options:"
 682     (Filename.basename Sys.executable_name)
 683
 684 let main () =
 685   Arg.parse argspec anon_fun usage_msg;
 686
 687   (* Start up the slave thread. *)
 688   let slave = Thread.create Slave.slave_loop () in
 689
 690   (* Set up the display. *)
 691   let ds = main_window opened_domain repaint in
 692
 693   Slave.set_failure_callback (failure ds);
 694   Slave.set_busy_callback (busy ds);
 695   let uri = match !default_uri with "" -> None | s -> Some s in
 696   Slave.connect uri (connected ds);
 697
 698   (* Run the main thread. When this returns, the application has been closed. *)
 699   GtkThread.main ();
 700
 701   (* Tell the slave thread to exit and wait for it to do so. *)
 702   Slave.exit_thread ();
 703   Thread.join slave
 704
 705 let () =
 706   main ()