--- /dev/null
+This document describes the software architecture of the Guestfs
+Browser, useful if you want to hack on it.
+
+About OCaml
+-----------
+
+First of all about OCaml: Read the tutorial and other resources
+available from this site:
+
+ http://ocaml-tutorial.org/
+
+If you are using emacs, install tuareg-mode instead of using the
+built-in emacs mode (which sucks). vi users have a good built-in
+OCaml mode already.
+
+All OCaml packages required are available in all good Linux
+distributions, well, Fedora, Debian and Ubuntu anyway. If you are
+using some other distribution, or Mac OS X or Windows, have a look at
+GODI.
+
+In OCaml, a module such as 'Slave' is defined by its interface in
+'slave.mli' (note lowercase first letter), and its implementation
+in 'slave.ml'.
+
+Threads and messages
+--------------------
+
+Because libvirt and libguestfs API calls are usually long-running, we
+have to use threads, making these API calls in one thread, while
+another thread keeps the display updated. In Guestfs Browser we use
+two threads, and send messages between them. The main thread keeps
+the display updated and runs the glib main loop. The slave thread
+issues libvirt and libguestfs API calls serially. There is a FIFO
+queue of commands, from the main thread to the slave thread. When
+each command finishes, a reply is delivered back to the main thread by
+adding an idle event to the glib main loop, see:
+
+ http://library.gnome.org/devel/gtk-faq/stable/x499.html
+
+If a command fails, it causes the input command queue to be cleared.
+In this case a failure response is added to the main loop which causes
+some error message to appear in the display.
+
+The main thread cannot directly access the libvirt or libguestfs
+handles, but instead it must send messages. (In older versions of
+libvirt, and all versions of libguestfs, these handles were not thread
+safe, and in any case we don't want the main thread to block because
+it performs some long-running operation by accident).
+
+The slave thread is defined in the Slave module (interface:
+'slave.mli') and all slave_* files. The Slave module also defines
+what commands are possible. Every other module and file is part of
+the main thread except for a few utility / library modules.
+
+The main thread starts in the module Main.
+
+Code style
+----------
+
+Most modules alias short names for some common libvirt and libguestfs
+modules, eg:
+
+ module C = Libvirt.Connect
+ module G = Guestfs
+
+So when you see a function such as 'C.connect_readonly', it's really
+the function 'connect_readonly' in the [nested] module
+'Libvirt.Connect'.
--- /dev/null
+# Guestfs Browser.
+# Copyright (C) 2010 Red Hat Inc.
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License along
+# with this program; if not, write to the Free Software Foundation, Inc.,
+# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+
+ACLOCAL_AMFLAGS = -I m4
+
+EXTRA_DIST = HACKING Throbber.png Throbber.gif
+
+CLEANFILES = *.cmi *.cmo *.cmx *.o guestfs-browser throbber.ml
+
+SOURCES = \
+ main.ml \
+ slave.mli \
+ slave.ml \
+ throbber.ml \
+ utils.mli \
+ utils.ml
+
+OBJECTS = \
+ main.cmx \
+ slave.cmx \
+ throbber.cmx \
+ utils.cmx
+
+bin_SCRIPTS = guestfs-browser
+
+OCAMLOPTFLAGS = \
+ -warn-error A \
+ -thread \
+ -package libvirt,guestfs,lablgtk2,extlib,xml-light,threads
+
+guestfs-browser: $(OBJECTS)
+ ocamlfind ocamlopt $(OCAMLOPTFLAGS) \
+ -predicates init,threads \
+ -linkpkg gtkThread.cmx \
+ $^ -o $@
+
+throbber.ml: Throbber.png Throbber.gif
+ gdk_pixbuf_mlsource --build-list \
+ static Throbber.png \
+ animation Throbber.gif \
+ > $@-t && mv $@-t $@
--- /dev/null
+dnl Guestfs Browser.
+dnl Copyright (C) 2010 Red Hat Inc.
+dnl
+dnl This program is free software; you can redistribute it and/or modify
+dnl it under the terms of the GNU General Public License as published by
+dnl the Free Software Foundation; either version 2 of the License, or
+dnl (at your option) any later version.
+dnl
+dnl This program is distributed in the hope that it will be useful,
+dnl but WITHOUT ANY WARRANTY; without even the implied warranty of
+dnl MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+dnl GNU General Public License for more details.
+dnl
+dnl You should have received a copy of the GNU General Public License along
+dnl with this program; if not, write to the Free Software Foundation, Inc.,
+dnl 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+
+AC_INIT([guestfs-browser],[0.0.1])
+AM_INIT_AUTOMAKE([foreign])
+AC_CONFIG_MACRO_DIR([m4])
+
+dnl Check for C compiler.
+AC_PROG_CC_STDC
+AC_PROG_INSTALL
+AC_PROG_CPP
+AC_C_PROTOTYPES
+test "x$U" != "x" && AC_MSG_ERROR([Compiler not ANSI compliant])
+AM_PROG_CC_C_O
+AC_SYS_LARGEFILE
+
+dnl Check for OCaml compiler.
+AC_PROG_OCAML
+if test "$OCAMLOPT" = "no"; then
+ AC_MSG_ERROR([You must install the OCaml native compiler (ocamlopt)])
+fi
+
+dnl Check for OCaml findlib.
+AC_PROG_FINDLIB
+if test "$OCAMLFIND" = "no"; then
+ AC_MSG_ERROR([You must install OCaml findlib (ocamlfind)])
+fi
+
+dnl Check for all OCaml packages.
+AC_CHECK_OCAML_PKG([lablgtk2])
+if test "$OCAML_PKG_lablgtk2" = "no"; then
+ AC_MSG_ERROR([Please install OCaml module 'lablgtk2'.])
+fi
+
+AC_CONFIG_HEADERS([config.h])
+AC_CONFIG_FILES([Makefile])
+AC_OUTPUT
--- /dev/null
+dnl autoconf macros for OCaml
+dnl
+dnl Copyright © 2009 Richard W.M. Jones
+dnl Copyright © 2009 Stefano Zacchiroli
+dnl Copyright © 2000-2005 Olivier Andrieu
+dnl Copyright © 2000-2005 Jean-Christophe Filliâtre
+dnl Copyright © 2000-2005 Georges Mariano
+dnl
+dnl For documentation, please read the ocaml.m4 man page.
+
+AC_DEFUN([AC_PROG_OCAML],
+[dnl
+ # checking for ocamlc
+ AC_CHECK_TOOL([OCAMLC],[ocamlc],[no])
+
+ if test "$OCAMLC" != "no"; then
+ OCAMLVERSION=`$OCAMLC -v | sed -n -e 's|.*version* *\(.*\)$|\1|p'`
+ AC_MSG_RESULT([OCaml version is $OCAMLVERSION])
+ OCAMLLIB=`$OCAMLC -where 2>/dev/null || $OCAMLC -v|tail -1|cut -d ' ' -f 4`
+ AC_MSG_RESULT([OCaml library path is $OCAMLLIB])
+
+ AC_SUBST([OCAMLVERSION])
+ AC_SUBST([OCAMLLIB])
+
+ # checking for ocamlopt
+ AC_CHECK_TOOL([OCAMLOPT],[ocamlopt],[no])
+ OCAMLBEST=byte
+ if test "$OCAMLOPT" = "no"; then
+ AC_MSG_WARN([Cannot find ocamlopt; bytecode compilation only.])
+ else
+ TMPVERSION=`$OCAMLOPT -v | sed -n -e 's|.*version* *\(.*\)$|\1|p' `
+ if test "$TMPVERSION" != "$OCAMLVERSION" ; then
+ AC_MSG_RESULT([versions differs from ocamlc; ocamlopt discarded.])
+ OCAMLOPT=no
+ else
+ OCAMLBEST=opt
+ fi
+ fi
+
+ AC_SUBST([OCAMLBEST])
+
+ # checking for ocamlc.opt
+ AC_CHECK_TOOL([OCAMLCDOTOPT],[ocamlc.opt],[no])
+ if test "$OCAMLCDOTOPT" != "no"; then
+ TMPVERSION=`$OCAMLCDOTOPT -v | sed -n -e 's|.*version* *\(.*\)$|\1|p' `
+ if test "$TMPVERSION" != "$OCAMLVERSION" ; then
+ AC_MSG_RESULT([versions differs from ocamlc; ocamlc.opt discarded.])
+ else
+ OCAMLC=$OCAMLCDOTOPT
+ fi
+ fi
+
+ # checking for ocamlopt.opt
+ if test "$OCAMLOPT" != "no" ; then
+ AC_CHECK_TOOL([OCAMLOPTDOTOPT],[ocamlopt.opt],[no])
+ if test "$OCAMLOPTDOTOPT" != "no"; then
+ TMPVERSION=`$OCAMLOPTDOTOPT -v | sed -n -e 's|.*version* *\(.*\)$|\1|p' `
+ if test "$TMPVERSION" != "$OCAMLVERSION" ; then
+ AC_MSG_RESULT([version differs from ocamlc; ocamlopt.opt discarded.])
+ else
+ OCAMLOPT=$OCAMLOPTDOTOPT
+ fi
+ fi
+ fi
+
+ AC_SUBST([OCAMLOPT])
+ fi
+
+ AC_SUBST([OCAMLC])
+
+ # checking for ocamldep
+ AC_CHECK_TOOL([OCAMLDEP],[ocamldep],[no])
+
+ # checking for ocamlmktop
+ AC_CHECK_TOOL([OCAMLMKTOP],[ocamlmktop],[no])
+
+ # checking for ocamlmklib
+ AC_CHECK_TOOL([OCAMLMKLIB],[ocamlmklib],[no])
+
+ # checking for ocamldoc
+ AC_CHECK_TOOL([OCAMLDOC],[ocamldoc],[no])
+
+ # checking for ocamlbuild
+ AC_CHECK_TOOL([OCAMLBUILD],[ocamlbuild],[no])
+])
+
+
+AC_DEFUN([AC_PROG_OCAMLLEX],
+[dnl
+ # checking for ocamllex
+ AC_CHECK_TOOL([OCAMLLEX],[ocamllex],[no])
+ if test "$OCAMLLEX" != "no"; then
+ AC_CHECK_TOOL([OCAMLLEXDOTOPT],[ocamllex.opt],[no])
+ if test "$OCAMLLEXDOTOPT" != "no"; then
+ OCAMLLEX=$OCAMLLEXDOTOPT
+ fi
+ fi
+ AC_SUBST([OCAMLLEX])
+])
+
+AC_DEFUN([AC_PROG_OCAMLYACC],
+[dnl
+ AC_CHECK_TOOL([OCAMLYACC],[ocamlyacc],[no])
+ AC_SUBST([OCAMLYACC])
+])
+
+
+AC_DEFUN([AC_PROG_CAMLP4],
+[dnl
+ AC_REQUIRE([AC_PROG_OCAML])dnl
+
+ # checking for camlp4
+ AC_CHECK_TOOL([CAMLP4],[camlp4],[no])
+ if test "$CAMLP4" != "no"; then
+ TMPVERSION=`$CAMLP4 -v 2>&1| sed -n -e 's|.*version *\(.*\)$|\1|p'`
+ if test "$TMPVERSION" != "$OCAMLVERSION" ; then
+ AC_MSG_RESULT([versions differs from ocamlc])
+ CAMLP4=no
+ fi
+ fi
+ AC_SUBST([CAMLP4])
+
+ # checking for companion tools
+ AC_CHECK_TOOL([CAMLP4BOOT],[camlp4boot],[no])
+ AC_CHECK_TOOL([CAMLP4O],[camlp4o],[no])
+ AC_CHECK_TOOL([CAMLP4OF],[camlp4of],[no])
+ AC_CHECK_TOOL([CAMLP4OOF],[camlp4oof],[no])
+ AC_CHECK_TOOL([CAMLP4ORF],[camlp4orf],[no])
+ AC_CHECK_TOOL([CAMLP4PROF],[camlp4prof],[no])
+ AC_CHECK_TOOL([CAMLP4R],[camlp4r],[no])
+ AC_CHECK_TOOL([CAMLP4RF],[camlp4rf],[no])
+ AC_SUBST([CAMLP4BOOT])
+ AC_SUBST([CAMLP4O])
+ AC_SUBST([CAMLP4OF])
+ AC_SUBST([CAMLP4OOF])
+ AC_SUBST([CAMLP4ORF])
+ AC_SUBST([CAMLP4PROF])
+ AC_SUBST([CAMLP4R])
+ AC_SUBST([CAMLP4RF])
+])
+
+
+AC_DEFUN([AC_PROG_FINDLIB],
+[dnl
+ AC_REQUIRE([AC_PROG_OCAML])dnl
+
+ # checking for ocamlfind
+ AC_CHECK_TOOL([OCAMLFIND],[ocamlfind],[no])
+ AC_SUBST([OCAMLFIND])
+])
+
+
+dnl Thanks to Jim Meyering for working this next bit out for us.
+dnl XXX We should define AS_TR_SH if it's not defined already
+dnl (eg. for old autoconf).
+AC_DEFUN([AC_CHECK_OCAML_PKG],
+[dnl
+ AC_REQUIRE([AC_PROG_FINDLIB])dnl
+
+ AC_MSG_CHECKING([for OCaml findlib package $1])
+
+ unset found
+ unset pkg
+ found=no
+ for pkg in $1 $2 ; do
+ if $OCAMLFIND query $pkg >/dev/null 2>/dev/null; then
+ AC_MSG_RESULT([found])
+ AS_TR_SH([OCAML_PKG_$1])=$pkg
+ found=yes
+ break
+ fi
+ done
+ if test "$found" = "no" ; then
+ AC_MSG_RESULT([not found])
+ AS_TR_SH([OCAML_PKG_$1])=no
+ fi
+
+ AC_SUBST(AS_TR_SH([OCAML_PKG_$1]))
+])
+
+
+AC_DEFUN([AC_CHECK_OCAML_MODULE],
+[dnl
+ AC_MSG_CHECKING([for OCaml module $2])
+
+ cat > conftest.ml <<EOF
+open $3
+EOF
+ unset found
+ for $1 in $$1 $4 ; do
+ if $OCAMLC -c -I "$$1" conftest.ml >&5 2>&5 ; then
+ found=yes
+ break
+ fi
+ done
+
+ if test "$found" ; then
+ AC_MSG_RESULT([$$1])
+ else
+ AC_MSG_RESULT([not found])
+ $1=no
+ fi
+ AC_SUBST([$1])
+])
+
+
+dnl XXX Cross-compiling
+AC_DEFUN([AC_CHECK_OCAML_WORD_SIZE],
+[dnl
+ AC_MSG_CHECKING([for OCaml compiler word size])
+ cat > conftest.ml <<EOF
+ print_endline (string_of_int Sys.word_size)
+ EOF
+ OCAML_WORD_SIZE=`ocaml conftest.ml`
+ AC_MSG_RESULT([$OCAML_WORD_SIZE])
+ AC_SUBST([OCAML_WORD_SIZE])
+])
--- /dev/null
+(* Guestfs Browser.
+ * Copyright (C) 2010 Red Hat Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2 of the License, or
+ * (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License along
+ * with this program; if not, write to the Free Software Foundation, Inc.,
+ * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+ *)
+
+open Utils
+
+(* Display state. *)
+type display_state = {
+ window : GWindow.window;
+ throbber_busy : unit -> unit;
+ throbber_idle : unit -> unit;
+}
+
+let open_main_window () =
+ let title = "Guest Filesystem Browser" in
+ let window = GWindow.window ~width:800 ~height:600 ~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 ());
+
+ (* 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_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
+ and throbber_idle () =
+ throbber#set_pixbuf static
+ in
+
+ window#show ();
+ window#add_accel_group accel_group;
+
+ (* display_state which is threaded through all the other callbacks,
+ * allowing callbacks to update the window.
+ *)
+ { window = window;
+ throbber_busy = throbber_busy; throbber_idle = throbber_idle }
+
+let () =
+ let ds = open_main_window () in
+ Slave.set_failure_hook (failure ds);
+ Slave.set_busy_hook ds.throbber_busy;
+ Slave.set_idle_hook ds.throbber_idle;
+
+ (* Run the main display thread. When this returns, the application
+ * has been closed.
+ *)
+ GtkThread.main ();
+ Slave.exit_thread ()
--- /dev/null
+(* Guestfs Browser.
+ * Copyright (C) 2010 Red Hat Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2 of the License, or
+ * (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License along
+ * with this program; if not, write to the Free Software Foundation, Inc.,
+ * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+ *)
+
+open Utils
+
+module C = Libvirt.Connect
+module Cond = Condition
+module D = Libvirt.Domain
+module G = Guestfs
+module M = Mutex
+module Q = Queue
+
+type 'a callback = 'a -> unit
+
+(* The commands. *)
+type command =
+ | Exit_thread
+ | Connect of string option * unit callback
+ | Get_domains of domain list callback
+
+and domain = {
+ dom_id : int;
+ dom_name : string;
+ dom_state : D.state;
+}
+
+let no_callback _ = ()
+
+let failure_hook = ref (fun _ -> ())
+let busy_hook = ref (fun _ -> ())
+let idle_hook = ref (fun _ -> ())
+
+let set_failure_hook cb = failure_hook := cb
+let set_busy_hook cb = busy_hook := cb
+let set_idle_hook cb = idle_hook := cb
+
+(* Execute a function, while holding a mutex. If the function
+ * fails, ensure we release the mutex before rethrowing the
+ * exception.
+ *)
+let with_lock m f =
+ M.lock m;
+ let r = try Left (f ()) with exn -> Right exn in
+ M.unlock m;
+ match r with
+ | Left r -> r
+ | Right exn -> raise exn
+
+(* The queue of commands, and a lock and condition to protect it. *)
+let q = Q.create ()
+let q_lock = M.create ()
+let q_cond = Cond.create ()
+
+(* Send a command message to the slave thread. *)
+let send_to_slave cmd =
+ debug "sending message %s to slave thread ..." (string_of_command cmd)
+ with_lock q_lock (
+ fun () ->
+ Q.push cmd q;
+ Cond.signal q_cond
+ )
+
+let discard_command_queue () = with_lock q_lock (fun () -> Q.clear q)
+
+let connect uri cb = send_to_slave (Connect (uri, cb))
+let get_domains cb = send_to_slave (Get_domains cb)
+
+(*----- Slave thread starts here -----*)
+
+(* Set this to true to exit the thread. *)
+let quit = ref false
+
+let rec loop () =
+ (* Get the next command. *)
+ let cmd =
+ with_lock q_lock (
+ fun () ->
+ while Q.is_empty q do
+ Cond.wait q_cond q_lock
+ done;
+ Q.pop q
+ ) in
+
+ debug "slave thread processing command %s ..." (string_of_command cmd);
+
+ (try
+ call_callback !busy_hook ();
+ execute_command cmd;
+ call_callback !idle_hook ();
+ with exn ->
+ (* If a command fails, clear the command queue and run the
+ * failure hook in the main thread.
+ *)
+ call_callback !idle_hook ();
+ discard_command_queue ();
+ call_callback !failure_hook exn
+ );
+
+ if !quit then Thread.exit ();
+ loop ()
+
+and execute_command = function
+ | Exit_thread ->
+ quit := true;
+ disconnect_all ()
+
+ | Connect (uri, cb) ->
+ disconnect_all ();
+ conn := Some (C.connect_readonly ?uri ());
+ call_callback cb ()
+
+ | Get_domains cb ->
+ let conn = get_conn () in
+ let doms = D.get_domains conn [D.ListAll] in
+ let doms = List.map (
+ fun d ->
+ D.get_id d, D.get_name d, (D.get_info d).D.state
+ ) doms in
+ call_callback cb doms
+
+(* Call a callback function or hook in the main thread. *)
+and call_callback cb arg =
+ GtkThread.async cb arg
+
+(* Expect to be connected, and return the current libvirt connection. *)
+let get_conn () =
+ match !conn with
+ | Some conn -> conn
+ | None -> failwith "not connected to libvirt"
+
+(* Close all libvirt and libguestfs handles. *)
+and disconnect_all () =
+ (match !conn with Some conn -> C.close conn | None -> ());
+ conn := None
+
+(* Start up one slave thread. *)
+let slave_thread = Thread.create loop ()
+
+(* Note the following function is called from the main thread. *)
+let exit_thread () =
+ discard_command_queue ();
+ send_to_slave Exit_thread;
+ Thread.join slave_thread
--- /dev/null
+(* Guestfs Browser.
+ * Copyright (C) 2010 Red Hat Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2 of the License, or
+ * (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License along
+ * with this program; if not, write to the Free Software Foundation, Inc.,
+ * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+ *)
+
+(** The public interface to the slave thread.
+ Please see HACKING file. *)
+
+(** {2 Commands and callbacks} *)
+
+type 'a callback = 'a -> unit
+ (** A callback function in the main thread which is called when the
+ command finishes (successfully).
+
+ This can also return some data (the ['a] parameter). A command
+ that returns a list of strings might have callback type [string
+ list callback], and a command that returns nothing would have
+ callback type [unit callback].
+
+ Note that errors are not returned this way. Errors result
+ in the command queue being discarded and the failure_hook
+ function being called. *)
+
+val no_callback : 'a callback
+ (** The main thread uses this as a callback if it doesn't care about
+ the return value from a command. *)
+
+val connect : string option -> unit callback -> unit
+ (** [connect uri cb] sends the [Connect] message to the slave
+ thread.
+
+ This causes the slave thread to disconnect from libvirt and
+ connect to the libvirt [uri]. If this succeeds, [cb] is called
+ in the main thread.
+
+ Although you can connect to remote hosts, libguestfs won't
+ usually be able to see the drives on those hosts, so it normally
+ doesn't make sense to use remote URIs. *)
+
+type domain = {
+ dom_name : string;
+ dom_state : Libvirt.Domain.state;
+}
+ (** List of domains as returned in the [Get_domains] message callback.
+
+ Note that [dom_state] is the state of the domain and should
+ control whether we are allowed to write to the domain's
+ filesystem (disallowed if [dom_state] is [InfoRunning]). *)
+
+val get_domains : domain list callback -> unit
+ (** [get_domains cb] sends the [Get_domains] message to the
+ slave thread.
+
+ This causes the slave thread to retrieve the list of domains
+ from libvirt (active and inactive ones). If this succeeds,
+ [cb] is called in the main thread with the list of
+ domains. See also the {!domain} type. *)
+
+val discard_command_queue : unit -> unit
+ (** [discard_command_queue ()] discards any commands on the command
+ queue. The currently running command is not (and can not be)
+ stopped. *)
+
+val exit_thread : unit -> unit
+ (** [exit_thread ()] causes the slave thread to exit, and returns
+ once it has exited. *)
+
+(** {2 Hooks}
+
+ Hooks are like callbacks, except they hook into special events
+ that happen in the slave threads, rather than just being a
+ response to commands.
+
+ The other difference is that hooks are global variables. You can
+ only set one hook of each type.
+
+ {!set_failure_hook} is used to catch errors in slave commands
+ and display those in the main thread.
+
+ {!set_busy_hook} and {!set_idle_hook} are used to implement a
+ "throbber". *)
+
+val set_failure_hook : exn callback -> unit
+ (** Set the function in the main thread which is called if there is
+ an error in the slave thread. If this is not set then errors
+ are discarded. [exn] is the exception. *)
+
+val set_busy_hook : unit callback -> unit
+ (** Set the function in the main thread which is called whenever
+ the slave thread starts working on a command. *)
+
+val set_idle_hook : unit callback -> unit
+ (** Set the function in the main thread which is called whenever
+ the slave thread stops working on a command {i and} has no
+ more commands left in the queue to work on. *)
--- /dev/null
+(* Guestfs Browser.
+ * Copyright (C) 2010 Red Hat Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2 of the License, or
+ * (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License along
+ * with this program; if not, write to the Free Software Foundation, Inc.,
+ * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+ *)
+
+type ('a, 'b) choice = Either of 'a | Or of 'b
+
+let verbose = ref true (* XXX settable *)
+
+let debug fs =
+ let f str = if !verbose then (prerr_string str; prerr_newline ()) in
+ ksprintf f fs
+
+let failwith fs =
+ let f str =
+ if !verbose then (prerr_string str; prerr_newline ());
+ raise (Failure str)
+ in
+ ksprintf f fs
--- /dev/null
+(* Guestfs Browser.
+ * Copyright (C) 2010 Red Hat Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2 of the License, or
+ * (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License along
+ * with this program; if not, write to the Free Software Foundation, Inc.,
+ * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+ *)
+
+(** General-purpose utility code used everywhere. *)
+
+type ('a, 'b) either = Left of 'a | Right of 'b
+ (** A value which is either an ['a] or a ['b], just like Haskell's
+ "Either" type. *)
+
+val verbose : bool ref
+ (** If this contains [true] then {!debug} will send debugging
+ messages to stderr, else debugging messages are dropped. *)
+
+val debug : ('a, out_channel, unit) format -> 'a
+ (** A printf-like function for writing debugging messages. *)
+
+val failwith : ('a, out_channel, unit) format -> 'a
+ (** Replacement for standard OCaml [failwith] function. This can
+ take a printf-like argument list, and also logs errors on stderr
+ when verbose is enabled. *)
git.annexia.org / guestfs-browser.git / commitdiff
