(* 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) * - cduce and ocamlduce (http://cduce.org/) * - 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"; !busy_cb `Idle; 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 and get_devices_from_xml xml = (* Lengthy discussion of the merits or otherwise of this code here: * http://groups.google.com/group/fa.caml/browse_thread/thread/48e05d49b0f21b8a/5296bceb31ebfff3 *) let xml = Xmllight_loader.from_string xml in let xs = {{ [xml] }} in let xs = {{ (((xs.(_)) / .(_)) / .(_)) / }} in let xs = {{ map xs with | _ | _ -> [s] | _ -> [] }} in {: xs :} 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 = let title = "Error" in let msg = Printexc.to_string exn in debug "failure callback: %s" msg; let icon = GMisc.image () in icon#set_stock `DIALOG_ERROR; icon#set_icon_size `DIALOG; GToolbox.message_box ~title ~icon msg (* 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 ()