diff options
Diffstat (limited to 'mlvirtmanager')
| -rw-r--r-- | mlvirtmanager/.cvsignore | 8 | ||||
| -rw-r--r-- | mlvirtmanager/.depend | 22 | ||||
| -rw-r--r-- | mlvirtmanager/Makefile | 51 | ||||
| -rw-r--r-- | mlvirtmanager/Makefile.in | 51 | ||||
| -rw-r--r-- | mlvirtmanager/mlvirtmanager.ml | 19 | ||||
| -rw-r--r-- | mlvirtmanager/mlvirtmanager_connections.ml | 313 | ||||
| -rw-r--r-- | mlvirtmanager/mlvirtmanager_connections.mli | 34 | ||||
| -rw-r--r-- | mlvirtmanager/mlvirtmanager_domain_ops.ml | 83 | ||||
| -rw-r--r-- | mlvirtmanager/mlvirtmanager_domain_ops.mli | 12 | ||||
| -rw-r--r-- | mlvirtmanager/mlvirtmanager_helpers.ml | 82 | ||||
| -rw-r--r-- | mlvirtmanager/mlvirtmanager_helpers.mli | 38 | ||||
| -rw-r--r-- | mlvirtmanager/mlvirtmanager_mainwindow.ml | 134 | ||||
| -rw-r--r-- | mlvirtmanager/mlvirtmanager_mainwindow.mli | 16 |
13 files changed, 863 insertions, 0 deletions
diff --git a/mlvirtmanager/.cvsignore b/mlvirtmanager/.cvsignore new file mode 100644 index 0000000..df80d41 --- /dev/null +++ b/mlvirtmanager/.cvsignore @@ -0,0 +1,8 @@ +*.cmi +*.cmo +*.cmx +*.cma +*.cmxa +Makefile +mlvirtmanager +mlvirtmanager.opt
\ No newline at end of file diff --git a/mlvirtmanager/.depend b/mlvirtmanager/.depend new file mode 100644 index 0000000..01a1aa6 --- /dev/null +++ b/mlvirtmanager/.depend @@ -0,0 +1,22 @@ +mlvirtmanager_connections.cmi: ../libvirt/libvirt.cmi +mlvirtmanager_domain_ops.cmi: mlvirtmanager_connections.cmi +mlvirtmanager_helpers.cmi: ../libvirt/libvirt.cmi +mlvirtmanager_mainwindow.cmi: mlvirtmanager_connections.cmi +mlvirtmanager_connections.cmo: mlvirtmanager_helpers.cmi \ + ../libvirt/libvirt.cmi mlvirtmanager_connections.cmi +mlvirtmanager_connections.cmx: mlvirtmanager_helpers.cmx \ + ../libvirt/libvirt.cmx mlvirtmanager_connections.cmi +mlvirtmanager_domain_ops.cmo: mlvirtmanager_connections.cmi \ + ../libvirt/libvirt.cmi mlvirtmanager_domain_ops.cmi +mlvirtmanager_domain_ops.cmx: mlvirtmanager_connections.cmx \ + ../libvirt/libvirt.cmx mlvirtmanager_domain_ops.cmi +mlvirtmanager_helpers.cmo: ../libvirt/libvirt.cmi mlvirtmanager_helpers.cmi +mlvirtmanager_helpers.cmx: ../libvirt/libvirt.cmx mlvirtmanager_helpers.cmi +mlvirtmanager_mainwindow.cmo: mlvirtmanager_connections.cmi \ + ../libvirt/libvirt.cmi mlvirtmanager_mainwindow.cmi +mlvirtmanager_mainwindow.cmx: mlvirtmanager_connections.cmx \ + ../libvirt/libvirt.cmx mlvirtmanager_mainwindow.cmi +mlvirtmanager.cmo: mlvirtmanager_mainwindow.cmi mlvirtmanager_domain_ops.cmi \ + mlvirtmanager_connections.cmi +mlvirtmanager.cmx: mlvirtmanager_mainwindow.cmx mlvirtmanager_domain_ops.cmx \ + mlvirtmanager_connections.cmx diff --git a/mlvirtmanager/Makefile b/mlvirtmanager/Makefile new file mode 100644 index 0000000..3921a15 --- /dev/null +++ b/mlvirtmanager/Makefile @@ -0,0 +1,51 @@ +# $Id: Makefile.in,v 1.2 2007/08/21 14:24:38 rjones Exp $ + +INSTALL := /usr/bin/install -c + +prefix = /usr/local +exec_prefix = ${prefix} +bindir = ${exec_prefix}/bin + +OCAMLCPACKAGES := -package extlib,unix,lablgtk2 -I ../libvirt +OCAMLCFLAGS := -g +OCAMLCLIBS := -linkpkg + +OCAMLOPTPACKAGES := $(OCAMLCPACKAGES) +OCAMLOPTFLAGS := +OCAMLOPTLIBS := $(OCAMLCLIBS) + +export LIBRARY_PATH=../libvirt +export LD_LIBRARY_PATH=../libvirt + +BYTE_TARGETS := mlvirtmanager +OPT_TARGETS := mlvirtmanager.opt + +VIRTMANAGER_OBJS := \ + mlvirtmanager_helpers.cmo \ + mlvirtmanager_connections.cmo \ + mlvirtmanager_domain_ops.cmo \ + mlvirtmanager_mainwindow.cmo \ + mlvirtmanager.cmo + +VIRTMANAGER_XOBJS := $(VIRTMANAGER_OBJS:.cmo=.cmx) + +all: $(BYTE_TARGETS) + +opt: $(OPT_TARGETS) + +mlvirtmanager: $(VIRTMANAGER_OBJS) + ocamlfind ocamlc $(OCAMLCPACKAGES) $(OCAMLCFLAGS) $(OCAMLCLIBS) \ + ../libvirt/mllibvirt.cma gtkInit.cmo -o $@ $< + +mlvirtmanager.opt: $(VIRTMANAGER_XOBJS) + ocamlfind ocamlopt \ + $(OCAMLOPTPACKAGES) $(OCAMLOPTFLAGS) $(OCAMLOPTLIBS) \ + ../libvirt/mllibvirt.cmxa gtkInit.cmx -o $@ $< + +install: + if [ -x mlvirtmanager.opt ]; then \ + mkdir -p $(DESTDIR)$(bindir); \ + $(INSTALL) -m 0755 mlvirtmanager.opt $(DESTDIR)$(bindir)/mlvirtmanager; \ + fi + +include ../Make.rules diff --git a/mlvirtmanager/Makefile.in b/mlvirtmanager/Makefile.in new file mode 100644 index 0000000..fe75929 --- /dev/null +++ b/mlvirtmanager/Makefile.in @@ -0,0 +1,51 @@ +# $Id: Makefile.in,v 1.2 2007/08/21 14:24:38 rjones Exp $ + +INSTALL := @INSTALL@ + +prefix = @prefix@ +exec_prefix = @exec_prefix@ +bindir = @bindir@ + +OCAMLCPACKAGES := -package extlib,unix,lablgtk2 -I ../libvirt +OCAMLCFLAGS := -g +OCAMLCLIBS := -linkpkg + +OCAMLOPTPACKAGES := $(OCAMLCPACKAGES) +OCAMLOPTFLAGS := +OCAMLOPTLIBS := $(OCAMLCLIBS) + +export LIBRARY_PATH=../libvirt +export LD_LIBRARY_PATH=../libvirt + +BYTE_TARGETS := mlvirtmanager +OPT_TARGETS := mlvirtmanager.opt + +VIRTMANAGER_OBJS := \ + mlvirtmanager_helpers.cmo \ + mlvirtmanager_connections.cmo \ + mlvirtmanager_domain_ops.cmo \ + mlvirtmanager_mainwindow.cmo \ + mlvirtmanager.cmo + +VIRTMANAGER_XOBJS := $(VIRTMANAGER_OBJS:.cmo=.cmx) + +all: $(BYTE_TARGETS) + +opt: $(OPT_TARGETS) + +mlvirtmanager: $(VIRTMANAGER_OBJS) + ocamlfind ocamlc $(OCAMLCPACKAGES) $(OCAMLCFLAGS) $(OCAMLCLIBS) \ + ../libvirt/mllibvirt.cma gtkInit.cmo -o $@ $< + +mlvirtmanager.opt: $(VIRTMANAGER_XOBJS) + ocamlfind ocamlopt \ + $(OCAMLOPTPACKAGES) $(OCAMLOPTFLAGS) $(OCAMLOPTLIBS) \ + ../libvirt/mllibvirt.cmxa gtkInit.cmx -o $@ $< + +install: + if [ -x mlvirtmanager.opt ]; then \ + mkdir -p $(DESTDIR)$(bindir); \ + $(INSTALL) -m 0755 mlvirtmanager.opt $(DESTDIR)$(bindir)/mlvirtmanager; \ + fi + +include ../Make.rules diff --git a/mlvirtmanager/mlvirtmanager.ml b/mlvirtmanager/mlvirtmanager.ml new file mode 100644 index 0000000..091c026 --- /dev/null +++ b/mlvirtmanager/mlvirtmanager.ml @@ -0,0 +1,19 @@ +(* virt-manager-like graphical management tool. + (C) Copyright 2007 Richard W.M. Jones, Red Hat Inc. + http://libvirt.org/ + $Id: mlvirtmanager.ml,v 1.1 2007/08/06 10:16:53 rjones Exp $ +*) + +open Printf + +let () = + (* Build the main window and wire up the buttons to the callback functions *) + Mlvirtmanager_mainwindow.make + ~open_connection:Mlvirtmanager_connections.open_connection + ~start_domain:Mlvirtmanager_domain_ops.start_domain + ~pause_domain:Mlvirtmanager_domain_ops.pause_domain + ~resume_domain:Mlvirtmanager_domain_ops.resume_domain + ~shutdown_domain:Mlvirtmanager_domain_ops.shutdown_domain; + + (* Enter the Gtk main loop. *) + GMain.main () diff --git a/mlvirtmanager/mlvirtmanager_connections.ml b/mlvirtmanager/mlvirtmanager_connections.ml new file mode 100644 index 0000000..2fda3e9 --- /dev/null +++ b/mlvirtmanager/mlvirtmanager_connections.ml @@ -0,0 +1,313 @@ +(* virt-manager-like graphical management tool. + (C) Copyright 2007 Richard W.M. Jones, Red Hat Inc. + http://libvirt.org/ + $Id: mlvirtmanager_connections.ml,v 1.1 2007/08/06 10:16:53 rjones Exp $ +*) + +open Printf + +module C = Libvirt.Connect +module D = Libvirt.Domain +module N = Libvirt.Network + +open Mlvirtmanager_helpers + +(* List of currently open connections. Actually it's a list of + * (id, Libvirt.Connect.t) so that we can easily identify + * connections by their unique ID. + *) +let get_conns, add_conn, del_conn = + let conns = ref [] in + let id = ref 0 in + let get_conns () = !conns in + let add_conn conn = + incr id; let id = !id in + conns := (id, conn) :: !conns; + id + in + let del_conn id = + conns := List.filter (fun (id', _) -> id <> id') !conns + in + get_conns, add_conn, del_conn + +(* The current state. This is used so that we can see changes that + * have happened and add or remove parts of the model. (Previously + * we used to recreate the whole model each time, but the problem + * with that is we "forget" things like the selection). + *) +type state = connection list +and connection = int (* connection ID *) * (active list * inactive list) +and active = int (* domain's ID *) +and inactive = string (* domain's name *) + +(* The last "CPU time" seen for a domain, so we can calculate CPU % usage. + * Hash of (connid, domid) -> cpu_time [int64]. + *) +let last_cpu_time = Hashtbl.create 13 +let last_time = ref (Unix.gettimeofday ()) + +type columns = string GTree.column * string GTree.column * string GTree.column * string GTree.column * string GTree.column * int GTree.column + +let debug_repopulate = true + +(* Populate the tree with the current list of connections, domains. + * This function is called once per second. + *) +let repopulate (tree : GTree.view) (model : GTree.tree_store) + (col_name_id, col_domname, col_status, col_cpu, col_mem, col_id) + state = + let time_passed = + let time_now = Unix.gettimeofday () in + let time_passed = time_now -. !last_time in + last_time := time_now; + time_passed in + + (* Which connections have been added or removed? *) + let conns = get_conns () in + let added, _, removed = + let old_conn_ids = List.map fst state + and new_conn_ids = List.map fst conns in + differences old_conn_ids new_conn_ids in + + (* Remove the subtrees for any connections which have gone. *) + if debug_repopulate then List.iter (eprintf "-connection %d\n%!") removed; + + List.iter ( + fun conn_id -> + filter_top_level_rows model + (fun row -> conn_id <> model#get ~row ~column:col_id) + ) removed; + + (* Add placeholder subtree for any new connections. *) + if debug_repopulate then List.iter (eprintf "+connection %d\n%!") added; + + List.iter ( + fun conn_id -> + let row = model#append () in + (* Get the connection name. *) + let name = + try C.get_hostname (List.assoc conn_id conns) + with Not_found | Libvirt.Virterror _ -> + "Conn #" ^ string_of_int conn_id in + model#set ~row ~column:col_name_id name; + model#set ~row ~column:col_id conn_id; + (* XXX This doesn't work, why? *) + tree#expand_row (model#get_path row) + ) added; + + let new_state = + List.map ( + fun (conn_id, conn) -> + (* Get the old list of active and inactive domains. If this + * connection is newly created, start with empty lists. + *) + let old_active, old_inactive = + try List.assoc conn_id state + with Not_found -> [], [] in + + (* Get the top level row in the model corresponding to this + * connection. + *) + let parent = + try find_top_level_row model + (fun row -> conn_id = model#get ~row ~column:col_id) + with Not_found -> assert false (* Should never happen. *) in + + try + (* Node info & number of CPUs available. *) + let node_info = C.get_node_info conn in + let nr_cpus = C.maxcpus_of_node_info node_info in + + (* For this connection, get a current list of active domains (IDs) *) + let active = + let n = C.num_of_domains conn in + let doms = C.list_domains conn n in + Array.to_list doms in + + (* Which active domains have been added or removed? *) + let added, _, removed = differences old_active active in + + (* Remove any active domains which have disappeared. *) + if debug_repopulate then + List.iter (eprintf "-active %d\n%!") removed; + + List.iter ( + fun domid -> + filter_rows model + (fun row -> domid <> model#get ~row ~column:col_id) + (model#iter_children (Some parent)) + ) removed; + + (* Add any active domains which have appeared. *) + if debug_repopulate then + List.iter (eprintf "+active %d\n%!") added; + + List.iter ( + fun domid -> + let domname = + try + let dom = D.lookup_by_id conn domid in + D.get_name dom + with _ -> "" in (* Ignore any transient error. *) + + let row = model#append ~parent () in + model#set ~row ~column:col_name_id (string_of_int domid); + model#set ~row ~column:col_domname domname; + model#set ~row ~column:col_id domid + ) added; + + (* Get a current list of inactive domains (names). *) + let inactive = + let n = C.num_of_defined_domains conn in + let doms = C.list_defined_domains conn n in + Array.to_list doms in + + (* Which inactive domains have been added or removed? *) + let added, _, removed = differences old_inactive inactive in + + (* Remove any inactive domains which have disappeared. *) + if debug_repopulate then + List.iter (eprintf "-inactive %s\n%!") removed; + + List.iter ( + fun domname -> + filter_rows model + (fun row -> + model#get ~row ~column:col_id <> -1 || + model#get ~row ~column:col_domname <> domname) + (model#iter_children (Some parent)) + ) removed; + + (* Add any inactive domains which have appeared. *) + if debug_repopulate then + List.iter (eprintf "+inactive %s\n%!") added; + + List.iter ( + fun domname -> + let row = model#append ~parent () in + model#set ~row ~column:col_name_id ""; + model#set ~row ~column:col_domname domname; + model#set ~row ~column:col_status "inactive"; + model#set ~row ~column:col_id (-1) + ) added; + + (* Now iterate over all active domains and update their state, + * CPU and memory. + *) + iter_rows model ( + fun row -> + let domid = model#get ~row ~column:col_id in + if domid >= 0 then ( (* active *) + try + let dom = D.lookup_by_id conn domid in + let info = D.get_info dom in + let status = string_of_domain_state info.D.state in + model#set ~row ~column:col_status status; + let memory = sprintf "%Ld K" info.D.memory in + model#set ~row ~column:col_mem memory; + + let ns_now = info.D.cpu_time in (* ns = nanoseconds *) + let ns_prev = + try + let ns = Hashtbl.find last_cpu_time (conn_id, domid) in + if ns > ns_now then 0L else ns (* Rebooted? *) + with Not_found -> 0L in + Hashtbl.replace last_cpu_time (conn_id, domid) ns_now; + let ns_now = Int64.to_float ns_now in + let ns_prev = Int64.to_float ns_prev in + let ns_used = ns_now -. ns_prev in + let ns_available = 1_000_000_000. *. float nr_cpus in + let cpu_percent = + 100. *. (ns_used /. ns_available) /. time_passed in + let cpu_percent = sprintf "%.1f %%" cpu_percent in + model#set ~row ~column:col_cpu cpu_percent; + + with Libvirt.Virterror _ -> () (* Ignore any transient error *) + ) + ) (model#iter_children (Some parent)); + + (* Return new state. *) + conn_id, (active, inactive) + with + (* Libvirt errors here are not really fatal. They can happen + * if the state changes at the moment we read it. If it does + * happen, just return the old state, and next time we come + * around to this connection it'll be fixed. + *) + | Libvirt.Virterror err -> + prerr_endline (Libvirt.Virterror.to_string err); + conn_id, (old_active, old_inactive) + | Failure msg -> + prerr_endline msg; + conn_id, (old_active, old_inactive) + ) conns in + + (* Return the updated state. *) + new_state + +(* Make the treeview which displays the connections and domains. *) +let make_treeview ?packing () = + let cols = new GTree.column_list in + let col_name_id = cols#add Gobject.Data.string in + let col_domname = cols#add Gobject.Data.string in + let col_status = cols#add Gobject.Data.string in + let col_cpu = cols#add Gobject.Data.string in + let col_mem = cols#add Gobject.Data.string in + (* Hidden column containing the connection ID or domain ID. For + * inactive domains, this contains -1 and col_domname is the name. *) + let col_id = cols#add Gobject.Data.int in + let model = GTree.tree_store cols in + + (* Column sorting functions. *) + let make_sort_func_on column = + fun (model : GTree.model) row1 row2 -> + let col1 = model#get ~row:row1 ~column in + let col2 = model#get ~row:row2 ~column in + compare col1 col2 + in + (*model#set_default_sort_func (make_sort_func_on col_domname);*) + model#set_sort_func 0 (make_sort_func_on col_name_id); + model#set_sort_func 1 (make_sort_func_on col_domname); + model#set_sort_column_id 1 `ASCENDING; + + (* Make the GtkTreeView and attach column renderers to it. *) + let tree = GTree.view ~model ~reorderable:false ?packing () in + + let append_visible_column title column sort = + let renderer = GTree.cell_renderer_text [], ["text", column] in + let view_col = GTree.view_column ~title ~renderer () in + ignore (tree#append_column view_col); + match sort with + | None -> () + | Some (sort_indicator, sort_order, sort_column_id) -> + view_col#set_sort_indicator sort_indicator; + view_col#set_sort_order sort_order; + view_col#set_sort_column_id sort_column_id + in + append_visible_column "ID" col_name_id (Some (false, `ASCENDING, 0)); + append_visible_column "Name" col_domname (Some (true, `ASCENDING, 1)); + append_visible_column "Status" col_status None; + append_visible_column "CPU" col_cpu None; + append_visible_column "Memory" col_mem None; + + let columns = + col_name_id, col_domname, col_status, col_cpu, col_mem, col_id in + let state = repopulate tree model columns [] in + + (tree, model, columns, state) + +(* Callback function to open a connection. + * This should be a lot more sophisticated. XXX + *) +let open_connection () = + let title = "Open connection to hypervisor" in + let name = + GToolbox.input_string ~title ~text:"xen:///" ~ok:"Open" "Connection:" in + match name with + | None -> () + | Some name -> + (* If this fails, let the exception escape and be printed + * in the global exception handler. + *) + let conn = C.connect ~name () in + ignore (add_conn conn) diff --git a/mlvirtmanager/mlvirtmanager_connections.mli b/mlvirtmanager/mlvirtmanager_connections.mli new file mode 100644 index 0000000..eb11be8 --- /dev/null +++ b/mlvirtmanager/mlvirtmanager_connections.mli @@ -0,0 +1,34 @@ +(* virt-manager-like graphical management tool. + (C) Copyright 2007 Richard W.M. Jones, Red Hat Inc. + http://libvirt.org/ + $Id: mlvirtmanager_connections.mli,v 1.1 2007/08/06 10:16:53 rjones Exp $ + + Handle connections and the complicated GtkTreeView which + displays the connections / domains. +*) + +(** Get the list of current connections. *) +val get_conns : unit -> (int * Libvirt.rw Libvirt.Connect.t) list + +(** The current/previous state last time repopulate was called. The + repopulate function uses this state to determine what has changed + (eg. domains added, removed) since last time. +*) +type state + +type columns = string GTree.column * string GTree.column * string GTree.column * string GTree.column * string GTree.column * int GTree.column + +(** This function should be called once per second in order to + redraw the GtkTreeView. + + Takes the previous state as a parameter and returns the new state. +*) +val repopulate : GTree.view -> GTree.tree_store -> columns -> state -> state + +(** Create the GtkTreeView. Returns the widget itself, the model, + the list of columns, and the initial state. +*) +val make_treeview : ?packing:(GObj.widget -> unit) -> unit -> GTree.view * GTree.tree_store * columns * state + +(** This callback creates the Connect to hypervisor dialog. *) +val open_connection : unit -> unit diff --git a/mlvirtmanager/mlvirtmanager_domain_ops.ml b/mlvirtmanager/mlvirtmanager_domain_ops.ml new file mode 100644 index 0000000..f02cd1f --- /dev/null +++ b/mlvirtmanager/mlvirtmanager_domain_ops.ml @@ -0,0 +1,83 @@ +(* virt-manager-like graphical management tool. + (C) Copyright 2007 Richard W.M. Jones, Red Hat Inc. + http://libvirt.org/ + $Id: mlvirtmanager_domain_ops.ml,v 1.1 2007/08/06 10:16:53 rjones Exp $ + + Domain operations buttons. +*) + +open Printf + +module C = Libvirt.Connect +module D = Libvirt.Domain +module N = Libvirt.Network + +(* Get the selected domain (if there is one) or return None. *) +let get_domain (tree : GTree.view) (model : GTree.tree_store) + (columns : Mlvirtmanager_connections.columns) = + let path, _ = tree#get_cursor () in + match path with + | None -> None (* No row at all selected. *) + | Some path -> + let row = model#get_iter path in + (* Visit parent to get the conn_id. + * If this returns None, then it's a top-level row which is + * selected (ie. a connection), so just ignore. + *) + match model#iter_parent row with + | None -> None + | Some parent -> + try + let (_, col_domname, _, _, _, col_id) = columns in + let conn_id = model#get ~row:parent ~column:col_id in + let conn = + List.assoc conn_id (Mlvirtmanager_connections.get_conns ()) in + let domid = model#get ~row ~column:col_id in + if domid = -1 then ( (* Inactive domain. *) + let domname = model#get ~row ~column:col_domname in + let dom = D.lookup_by_name conn domname in + let info = D.get_info dom in + Some (dom, info, -1) + ) else if domid > 0 then ( (* Active domU. *) + let dom = D.lookup_by_id conn domid in + let info = D.get_info dom in + Some (dom, info, domid) + ) else (* Dom0 - ignore. *) + None + with + (* Domain or connection disappeared under us. *) + | Not_found -> None + | Failure msg -> + prerr_endline msg; + None + | Libvirt.Virterror err -> + prerr_endline (Libvirt.Virterror.to_string err); + None + +let start_domain tree model columns () = + match get_domain tree model columns with + | None -> () + | Some (dom, _, domid) -> + if domid = -1 then + D.create dom + +let pause_domain tree model columns () = + match get_domain tree model columns with + | None -> () + | Some (dom, info, domid) -> + if domid >= 0 && info.D.state <> D.InfoPaused then + D.suspend dom + +let resume_domain tree model columns () = + match get_domain tree model columns with + | None -> () + | Some (dom, info, domid) -> + if domid >= 0 && info.D.state = D.InfoPaused then + D.resume dom + +let shutdown_domain tree model columns () = + match get_domain tree model columns with + | None -> () + | Some (dom, info, domid) -> + if domid >= 0 && info.D.state <> D.InfoShutdown then + D.shutdown dom diff --git a/mlvirtmanager/mlvirtmanager_domain_ops.mli b/mlvirtmanager/mlvirtmanager_domain_ops.mli new file mode 100644 index 0000000..9824b3a --- /dev/null +++ b/mlvirtmanager/mlvirtmanager_domain_ops.mli @@ -0,0 +1,12 @@ +(* virt-manager-like graphical management tool. + (C) Copyright 2007 Richard W.M. Jones, Red Hat Inc. + http://libvirt.org/ + $Id: mlvirtmanager_domain_ops.mli,v 1.1 2007/08/06 10:16:53 rjones Exp $ + + Domain operations buttons. +*) + +val start_domain : GTree.view -> GTree.tree_store -> Mlvirtmanager_connections.columns -> unit -> unit +val pause_domain : GTree.view -> GTree.tree_store -> Mlvirtmanager_connections.columns -> unit -> unit +val resume_domain : GTree.view -> GTree.tree_store -> Mlvirtmanager_connections.columns -> unit -> unit +val shutdown_domain : GTree.view -> GTree.tree_store -> Mlvirtmanager_connections.columns -> unit -> unit diff --git a/mlvirtmanager/mlvirtmanager_helpers.ml b/mlvirtmanager/mlvirtmanager_helpers.ml new file mode 100644 index 0000000..ff30253 --- /dev/null +++ b/mlvirtmanager/mlvirtmanager_helpers.ml @@ -0,0 +1,82 @@ +(* virt-manager-like graphical management tool. + (C) Copyright 2007 Richard W.M. Jones, Red Hat Inc. + http://libvirt.org/ + $Id: mlvirtmanager_helpers.ml,v 1.1 2007/08/06 10:16:53 rjones Exp $ +*) + +module C = Libvirt.Connect +module D = Libvirt.Domain +module N = Libvirt.Network + +(* Given two lists, xs and ys, return a list of items which have been + * added to ys, items which are the same, and items which have been + * removed from ys. + * Returns a triplet (list of added, list of same, list of removed). + *) +let differences xs ys = + let rec d = function + | [], [] -> (* Base case. *) + ([], [], []) + | [], ys -> (* All ys have been added. *) + (ys, [], []) + | xs, [] -> (* All xs have been removed. *) + ([], [], xs) + | (x :: xs), (y :: ys) when x = y -> (* Not added or removed. *) + let added, unchanged, removed = d (xs, ys) in + added, x :: unchanged, removed + | (x :: xs), ((y :: _) as ys) when x < y -> (* x removed. *) + let added, unchanged, removed = d (xs, ys) in + added, unchanged, x :: removed + | ((x :: _) as xs), (y :: ys) (* when x > y *) -> (* y added. *) + let added, unchanged, removed = d (xs, ys) in + y :: added, unchanged, removed + in + d (List.sort compare xs, List.sort compare ys) + +let string_of_domain_state = function + | D.InfoNoState -> "unknown" + | D.InfoRunning -> "running" + | D.InfoBlocked -> "blocked" + | D.InfoPaused -> "paused" + | D.InfoShutdown -> "shutdown" + | D.InfoShutoff -> "shutoff" + | D.InfoCrashed -> "crashed" + +(* Filter top level rows (only) in a tree_store. If function f returns + * true then the row remains, but if it returns false then the row is + * removed. + *) +let rec filter_top_level_rows (model : GTree.tree_store) f = + match model#get_iter_first with + | None -> () + | Some iter -> filter_rows model f iter + +(* Filter rows in a tree_store at a particular level. *) +and filter_rows model f row = + let keep = f row in + let iter_still_valid = + if not keep then model#remove row else model#iter_next row in + if iter_still_valid then filter_rows model f row + +(* Find the first top level row matching predicate f and return it. *) +let rec find_top_level_row (model : GTree.tree_store) f = + match model#get_iter_first with + | None -> raise Not_found (* no rows *) + | Some row -> find_row model f row + +(* Find the first row matching predicate f at a particular level. *) +and find_row model f row = + if f row then row + else if model#iter_next row then find_row model f row + else raise Not_found + +(* Iterate over top level rows (only) in a tree_store. *) +let rec iter_top_level_rows (model : GTree.tree_store) f = + match model#get_iter_first with + | None -> () + | Some iter -> iter_rows model f iter + +(* Iterate over rows in a tree_store at a particular level. *) +and iter_rows model f row = + f row; + if model#iter_next row then iter_rows model f row diff --git a/mlvirtmanager/mlvirtmanager_helpers.mli b/mlvirtmanager/mlvirtmanager_helpers.mli new file mode 100644 index 0000000..2952636 --- /dev/null +++ b/mlvirtmanager/mlvirtmanager_helpers.mli @@ -0,0 +1,38 @@ +(* virt-manager-like graphical management tool. + (C) Copyright 2007 Richard W.M. Jones, Red Hat Inc. + http://libvirt.org/ + $Id: mlvirtmanager_helpers.mli,v 1.1 2007/08/06 10:16:53 rjones Exp $ + + Helper functions. +*) + +(** Given two lists, xs and ys, return a list of items which have been + added to ys, items which are the same, and items which have been + removed from ys. + Returns a triplet (list of added, list of same, list of removed). +*) +val differences : 'a list -> 'a list -> 'a list * 'a list * 'a list + +(** Convert libvirt domain state to a string. *) +val string_of_domain_state : Libvirt.Domain.state -> string + +(** Filter top level rows (only) in a GtkTreeStore. If function f returns + true then the row remains, but if it returns false then the row is + removed. +*) +val filter_top_level_rows : GTree.tree_store -> (Gtk.tree_iter -> bool) -> unit + +(** Filter rows in a tree_store at a particular level. *) +val filter_rows : GTree.tree_store -> (Gtk.tree_iter -> bool) -> Gtk.tree_iter -> unit + +(** Find the first top level row matching predicate and return it. *) +val find_top_level_row : GTree.tree_store -> (Gtk.tree_iter -> bool) -> Gtk.tree_iter + +(** Find the first row matching predicate f at a particular level. *) +val find_row : GTree.tree_store -> (Gtk.tree_iter -> bool) -> Gtk.tree_iter -> Gtk.tree_iter + +(** Iterate over top level rows (only) in a GtkTreeStore. *) +val iter_top_level_rows : GTree.tree_store -> (Gtk.tree_iter -> unit) -> unit + +(** Iterate over rows in a tree_store at a particular level. *) +val iter_rows : GTree.tree_store -> (Gtk.tree_iter -> unit) -> Gtk.tree_iter -> unit diff --git a/mlvirtmanager/mlvirtmanager_mainwindow.ml b/mlvirtmanager/mlvirtmanager_mainwindow.ml new file mode 100644 index 0000000..93ee34b --- /dev/null +++ b/mlvirtmanager/mlvirtmanager_mainwindow.ml @@ -0,0 +1,134 @@ +(* virt-manager-like graphical management tool. + (C) Copyright 2007 Richard W.M. Jones, Red Hat Inc. + http://libvirt.org/ + $Id: mlvirtmanager_mainwindow.ml,v 1.1 2007/08/06 10:16:53 rjones Exp $ +*) + +open Printf + +let title = "Virtual Machine Manager" + +let utf8_copyright = "\194\169" + +let help_about () = + let gtk_version = + let gtk_major, gtk_minor, gtk_micro = GMain.Main.version in + sprintf "%d.%d.%d" gtk_major gtk_minor gtk_micro in + let virt_version = string_of_int (fst (Libvirt.get_version ())) in + let title = "About " ^ title in + let icon = GMisc.image () in + icon#set_stock `DIALOG_INFO; + icon#set_icon_size `DIALOG; + GToolbox.message_box + ~title + ~icon + ("Virtual machine manager (OCaml version) by\n" ^ + "Richard W.M. Jones (rjones@redhat.com).\n\n" ^ + "Copyright " ^ utf8_copyright ^ " 2007 Red Hat Inc.\n\n" ^ + "Libvirt version: " ^ virt_version ^ "\n" ^ + "Gtk toolkit version: " ^ gtk_version) + +(* Catch any exception and throw up a dialog. *) +let () = + (* A nicer exception printing function. *) + let string_of_exn = function + | Libvirt.Virterror err -> + "Virtualisation error: " ^ (Libvirt.Virterror.to_string err) + | Failure msg -> msg + | exn -> Printexc.to_string exn + in + GtkSignal.user_handler := + fun exn -> + let label = string_of_exn exn in + let title = "Error" in + let icon = GMisc.image () in + icon#set_stock `DIALOG_ERROR; + icon#set_icon_size `DIALOG; + GToolbox.message_box ~title ~icon label + +let make ~open_connection + ~start_domain ~pause_domain ~resume_domain ~shutdown_domain = + (* Create the main window. *) + let window = GWindow.window ~width:800 ~height:600 ~title () in + let vbox = GPack.vbox ~packing:window#add () in + + (* Menu bar. *) + let menubar = GMenu.menu_bar ~packing:vbox#pack () in + let factory = new GMenu.factory menubar in + let accel_group = factory#accel_group in + let file_menu = factory#add_submenu "File" in + let help_menu = factory#add_submenu "Help" in + + (* File menu. *) + let factory = new GMenu.factory file_menu ~accel_group in + let open_item = factory#add_item "Open connection ..." + ~key:GdkKeysyms._O in + ignore (factory#add_separator ()); + let quit_item = factory#add_item "Quit" ~key:GdkKeysyms._Q in + + ignore (open_item#connect#activate ~callback:open_connection); + + (* Help menu. *) + let factory = new GMenu.factory help_menu ~accel_group in + let help_item = factory#add_item "Help" in + let help_about_item = factory#add_item "About ..." in + + ignore (help_about_item#connect#activate ~callback:help_about); + + (* The toolbar. *) + let toolbar = GButton.toolbar ~packing:vbox#pack () in + let connect_button = + GButton.tool_button ~label:"Connect ..." ~stock:`CONNECT + ~packing:toolbar#insert () in + let start_button = + GButton.tool_button ~label:"Start" ~stock:`ADD + ~packing:toolbar#insert () in + let pause_button = + GButton.tool_button ~label:"Pause" ~stock:`MEDIA_PAUSE + ~packing:toolbar#insert () in + let resume_button = + GButton.tool_button ~label:"Resume" ~stock:`MEDIA_PLAY + ~packing:toolbar#insert () in + let shutdown_button = + GButton.tool_button ~label:"Shutdown" ~stock:`STOP + ~packing:toolbar#insert () in + ignore (connect_button#connect#clicked ~callback:open_connection); + + (* The treeview. *) + let (tree, model, columns, initial_state) = + Mlvirtmanager_connections.make_treeview + ~packing:(vbox#pack ~expand:true ~fill:true) () in + + ignore (start_button#connect#clicked + ~callback:(start_domain tree model columns)); + ignore (pause_button#connect#clicked + ~callback:(pause_domain tree model columns)); + ignore (resume_button#connect#clicked + ~callback:(resume_domain tree model columns)); + ignore (shutdown_button#connect#clicked + ~callback:(shutdown_domain tree model columns)); + + (* Make a timeout function which is called once per second. *) + let state = ref initial_state in + let callback () = + state := Mlvirtmanager_connections.repopulate tree model columns !state; + true + in + let timeout_id = GMain.Timeout.add ~ms:1000 ~callback in + + (* Quit. *) + let quit _ = + GMain.Timeout.remove timeout_id; + GMain.Main.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 ()); ())); + + window#add_accel_group accel_group; + + (* Display the window. *) + window#show () diff --git a/mlvirtmanager/mlvirtmanager_mainwindow.mli b/mlvirtmanager/mlvirtmanager_mainwindow.mli new file mode 100644 index 0000000..2ca9928 --- /dev/null +++ b/mlvirtmanager/mlvirtmanager_mainwindow.mli @@ -0,0 +1,16 @@ +(* virt-manager-like graphical management tool. + (C) Copyright 2007 Richard W.M. Jones, Red Hat Inc. + http://libvirt.org/ + $Id: mlvirtmanager_mainwindow.mli,v 1.1 2007/08/06 10:16:53 rjones Exp $ + + Make the main window. +*) + +(** This function creates the main window. You have to pass in + callback functions to wire everything up. +*) +val make : open_connection:(unit -> unit) -> + start_domain:(GTree.view -> GTree.tree_store -> Mlvirtmanager_connections.columns -> unit -> unit) -> + pause_domain:(GTree.view -> GTree.tree_store -> Mlvirtmanager_connections.columns -> unit -> unit) -> + resume_domain:(GTree.view -> GTree.tree_store -> Mlvirtmanager_connections.columns -> unit -> unit) -> + shutdown_domain:(GTree.view -> GTree.tree_store -> Mlvirtmanager_connections.columns -> unit -> unit) -> unit |