From: Richard Jones Date: Wed, 16 Jun 2010 10:40:19 +0000 (+0100) Subject: Initial commit. X-Git-Tag: 0.0.1~1 X-Git-Url: http://git.annexia.org/?a=commitdiff_plain;h=bbfe03c47f1d7f03c3e6c0cab9e4f500f588c80a;p=guestfs-browser.git Initial commit. --- bbfe03c47f1d7f03c3e6c0cab9e4f500f588c80a diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..b25c15b --- /dev/null +++ b/.gitignore @@ -0,0 +1 @@ +*~ diff --git a/HACKING b/HACKING new file mode 100644 index 0000000..7a139bc --- /dev/null +++ b/HACKING @@ -0,0 +1,68 @@ +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'. diff --git a/Makefile.am b/Makefile.am new file mode 100644 index 0000000..9e02e88 --- /dev/null +++ b/Makefile.am @@ -0,0 +1,55 @@ +# 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 $@ diff --git a/Throbber.gif b/Throbber.gif new file mode 100644 index 0000000..deac700 Binary files /dev/null and b/Throbber.gif differ diff --git a/Throbber.png b/Throbber.png new file mode 100644 index 0000000..7f23bda Binary files /dev/null and b/Throbber.png differ diff --git a/configure.ac b/configure.ac new file mode 100644 index 0000000..3060420 --- /dev/null +++ b/configure.ac @@ -0,0 +1,51 @@ +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 diff --git a/m4/ocaml.m4 b/m4/ocaml.m4 new file mode 100644 index 0000000..fddd6a0 --- /dev/null +++ b/m4/ocaml.m4 @@ -0,0 +1,217 @@ +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 <&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 < 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 () diff --git a/slave.ml b/slave.ml new file mode 100644 index 0000000..1017dd8 --- /dev/null +++ b/slave.ml @@ -0,0 +1,158 @@ +(* 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 diff --git a/slave.mli b/slave.mli new file mode 100644 index 0000000..994890f --- /dev/null +++ b/slave.mli @@ -0,0 +1,108 @@ +(* 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. *) diff --git a/utils.ml b/utils.ml new file mode 100644 index 0000000..8f7ce3a --- /dev/null +++ b/utils.ml @@ -0,0 +1,32 @@ +(* 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 diff --git a/utils.mli b/utils.mli new file mode 100644 index 0000000..f2a00db --- /dev/null +++ b/utils.mli @@ -0,0 +1,35 @@ +(* 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. *)