From ec0cd9b799e2cf0686f11df45f296d00e09760de Mon Sep 17 00:00:00 2001 From: "Richard W.M. Jones" Date: Fri, 2 Sep 2011 10:55:03 +0100 Subject: [PATCH] Initial commit. --- .depend | 29 ++++++ .gitignore | 25 +++++ Makefile.am | 163 +++++++++++++++++++++++++++++ config.ml.in | 20 ++++ config.mli | 25 +++++ configure.ac | 85 ++++++++++++++++ destination_tab.ml | 26 +++++ destination_tab.mli | 28 +++++ logvols_tab.ml | 26 +++++ logvols_tab.mli | 28 +++++ m4/ocaml.m4 | 217 +++++++++++++++++++++++++++++++++++++++ main.ml | 22 ++++ partitions_tab.ml | 26 +++++ partitions_tab.mli | 28 +++++ slave.ml | 289 ++++++++++++++++++++++++++++++++++++++++++++++++++++ slave.mli | 138 +++++++++++++++++++++++++ slave_types.ml | 52 ++++++++++ slave_types.mli | 56 ++++++++++ source_tab.ml | 213 ++++++++++++++++++++++++++++++++++++++ source_tab.mli | 44 ++++++++ utils.ml | 119 ++++++++++++++++++++++ utils.mli | 85 ++++++++++++++++ virt-resize-ui.pod | 129 +++++++++++++++++++++++ window.ml | 123 ++++++++++++++++++++++ window.mli | 24 +++++ 25 files changed, 2020 insertions(+) create mode 100644 .depend create mode 100644 .gitignore create mode 100644 Makefile.am create mode 100644 config.ml.in create mode 100644 config.mli create mode 100644 configure.ac create mode 100644 destination_tab.ml create mode 100644 destination_tab.mli create mode 100644 logvols_tab.ml create mode 100644 logvols_tab.mli create mode 100644 m4/ocaml.m4 create mode 100644 main.ml create mode 100644 partitions_tab.ml create mode 100644 partitions_tab.mli create mode 100644 slave.ml create mode 100644 slave.mli create mode 100644 slave_types.ml create mode 100644 slave_types.mli create mode 100644 source_tab.ml create mode 100644 source_tab.mli create mode 100644 utils.ml create mode 100644 utils.mli create mode 100644 virt-resize-ui.pod create mode 100644 window.ml create mode 100644 window.mli diff --git a/.depend b/.depend new file mode 100644 index 0000000..7cd1b72 --- /dev/null +++ b/.depend @@ -0,0 +1,29 @@ +config.cmi: +config.cmo: config.cmi +config.cmx: config.cmi +destination_tab.cmi: +destination_tab.cmo: destination_tab.cmi +destination_tab.cmx: destination_tab.cmi +logvols_tab.cmi: +logvols_tab.cmo: logvols_tab.cmi +logvols_tab.cmx: logvols_tab.cmi +main.cmo: window.cmi slave.cmi +main.cmx: window.cmx slave.cmx +partitions_tab.cmi: +partitions_tab.cmo: partitions_tab.cmi +partitions_tab.cmx: partitions_tab.cmi +slave.cmi: slave_types.cmi +slave.cmo: utils.cmi slave_types.cmi slave.cmi +slave.cmx: utils.cmx slave_types.cmx slave.cmi +slave_types.cmi: +slave_types.cmo: slave_types.cmi +slave_types.cmx: slave_types.cmi +source_tab.cmi: +source_tab.cmo: utils.cmi slave_types.cmi slave.cmi source_tab.cmi +source_tab.cmx: utils.cmx slave_types.cmx slave.cmx source_tab.cmi +utils.cmi: +utils.cmo: config.cmi utils.cmi +utils.cmx: config.cmx utils.cmi +window.cmi: +window.cmo: source_tab.cmi partitions_tab.cmi logvols_tab.cmi destination_tab.cmi window.cmi +window.cmx: source_tab.cmx partitions_tab.cmx logvols_tab.cmx destination_tab.cmx window.cmi diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..f3fc8ab --- /dev/null +++ b/.gitignore @@ -0,0 +1,25 @@ +*~ +*.cmi +*.cmo +*.cmx +*.o +Makefile +Makefile.in +aclocal.m4 +autom4te.cache +compile +config.h +config.h.in +config.log +config.ml +config.status +configure +doc/ +html/*.html +install-sh +missing +pod2htm?.tmp +stamp-h1 +virt-resize-ui-*.tar.gz +virt-resize-ui +virt-resize-ui.1 diff --git a/Makefile.am b/Makefile.am new file mode 100644 index 0000000..8962540 --- /dev/null +++ b/Makefile.am @@ -0,0 +1,163 @@ +# Virt resize UI. +# Copyright (C) 2011 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 = \ + $(SOURCES) \ + config.ml.in \ + .gitignore \ + virt-resize-ui.pod \ + virt-resize-ui.1 \ + html/pod.css + +CLEANFILES = *.cmi *.cmo *.cmx *.cmxa *.o virt-resize-ui *~ + +# These are listed here in alphabetical order. +SOURCES = \ + config.mli \ + destination_tab.mli \ + destination_tab.ml \ + logvols_tab.mli \ + logvols_tab.ml \ + main.ml \ + partitions_tab.mli \ + partitions_tab.ml \ + slave.mli \ + slave.ml \ + slave_types.mli \ + slave_types.ml \ + source_tab.mli \ + source_tab.ml \ + utils.mli \ + utils.ml \ + window.ml \ + window.mli + +BUILT_SOURCES = \ + config.ml + +# Note this list must be in dependency order. +OBJECTS = \ + config.cmo \ + utils.cmo \ + slave_types.cmo \ + slave.cmo \ + source_tab.cmo \ + destination_tab.cmo \ + partitions_tab.cmo \ + logvols_tab.cmo \ + window.cmo \ + main.cmo + +XOBJECTS = $(OBJECTS:.cmo=.cmx) + +bin_SCRIPTS = virt-resize-ui + +OCAMLPACKAGES = \ + -package threads,libvirt,guestfs,lablgtk2,extlib +OCAMLCFLAGS = \ + -g \ + -warn-error CDEFLMPSUVYZX \ + -thread \ + $(OCAMLPACKAGES) \ + -predicates threads +OCAMLOPTFLAGS = \ + -ccopt -g \ + $(OCAMLCFLAGS) +OCAMLDOCFLAGS = \ + $(OCAMLPACKAGES) \ + -predicates threads \ + -I +threads \ + -sort -html + +if HAVE_OCAMLOPT +virt-resize-ui: $(XOBJECTS) + $(OCAMLFIND) ocamlopt $(OCAMLOPTFLAGS) \ + -predicates init,threads \ + -linkpkg gtkThread.cmx \ + $^ -o $@ +else +virt-resize-ui: $(OBJECTS) + $(OCAMLFIND) ocamlc $(OCAMLCFLAGS) \ + -predicates init,threads \ + -linkpkg gtkThread.cmo \ + $^ -o $@ +endif + +.mli.cmi: + $(OCAMLFIND) ocamlc $(OCAMLCFLAGS) -c $< -o $@ +.ml.cmo: + $(OCAMLFIND) ocamlc $(OCAMLCFLAGS) -c $< -o $@ +.ml.cmx: + $(OCAMLFIND) ocamlopt $(OCAMLCFLAGS) -c $< -o $@ + +# Man page. +man_MANS = virt-resize-ui.1 + +if HAVE_PERLDOC + +virt-resize-ui.1: virt-resize-ui.pod + pod2man \ + --section 1 \ + -c "Virtualization Support" \ + --release "$(PACKAGE_NAME)-$(PACKAGE_VERSION)" \ + $< > $@ + +noinst_DATA = \ + html/virt-resize-ui.1.html + +html/virt-resize-ui.1.html: virt-resize-ui.pod + mkdir -p html + pod2html \ + --css 'pod.css' \ + --htmldir html \ + --outfile html/virt-resize-ui.1.html \ + virt-resize-ui.pod + +endif + +# Maintainer website update. +HTMLFILES = \ + html/virt-resize-ui.1.html + +WEBSITEDIR = $(HOME)/d/redhat/websites/libguestfs + +website: $(HTMLFILES) + cp $(HTMLFILES) $(WEBSITEDIR) + +CLEANFILES += $(HTMLFILES) pod2*.tmp + +# Convert internal documentation to HTML. +docs: + rm -rf doc + mkdir -p doc + $(OCAMLFIND) ocamldoc -d doc $(OCAMLDOCFLAGS) $(SOURCES) + +# Dependencies. +depend: .depend + +.depend: $(wildcard *.mli) $(wildcard *.ml) + $(OCAMLFIND) ocamldep $(OCAMLPACKAGES) $^ | \ + $(SED) -e 's/ *$$//' | \ + $(SED) -e :a -e '/ *\\$$/N; s/ *\\\n */ /; ta' | \ + LANG=C sort > $@-t + mv $@-t $@ + +include .depend + +.PHONY: depend docs diff --git a/config.ml.in b/config.ml.in new file mode 100644 index 0000000..f7fe92d --- /dev/null +++ b/config.ml.in @@ -0,0 +1,20 @@ +(* Virt resize UI. + * Copyright (C) 2011 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. + *) + +let package = "@PACKAGE_NAME@" +let version = "@PACKAGE_VERSION@" diff --git a/config.mli b/config.mli new file mode 100644 index 0000000..a4a584f --- /dev/null +++ b/config.mli @@ -0,0 +1,25 @@ +(* Virt resize UI. + * Copyright (C) 2011 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. + *) + +(** Configuration. *) + +val package : string + (** The package name. *) + +val version : string + (** The version number as a string. *) diff --git a/configure.ac b/configure.ac new file mode 100644 index 0000000..63ed5d4 --- /dev/null +++ b/configure.ac @@ -0,0 +1,85 @@ +dnl Virt resize UI. +dnl Copyright (C) 2011 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([virt-resize-ui],[0.1.0]) +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 + +AC_PROG_SED + +dnl Check for OCaml compiler. +AC_PROG_OCAML +if test "$OCAMLC" = "no"; then + AC_MSG_ERROR([You must install the OCaml compiler (ocamlc or ocamlopt)]) +fi + +dnl Choose native code if available, but allow the user to specify +dnl bytecode only (useful for debugging). +AC_ARG_WITH([native], + [AS_HELP_STRING([--without-native], + [disable native compilation (slow, but useful for debugging)])], + [], + [with_native=yes]) +AM_CONDITIONAL([HAVE_OCAMLOPT], + [test "x$with_native" != "xno" && test "x$OCAMLBEST" = "xopt"]) + +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_CHECK_OCAML_PKG([libvirt]) +if test "$OCAML_PKG_libvirt" = "no"; then + AC_MSG_ERROR([Please install OCaml module 'libvirt'.]) +fi + +AC_CHECK_OCAML_PKG([guestfs]) +if test "$OCAML_PKG_guestfs" = "no"; then + AC_MSG_ERROR([Please install OCaml module 'guestfs'.]) +fi + +AC_CHECK_OCAML_PKG([extlib]) +if test "$OCAML_PKG_extlib" = "no"; then + AC_MSG_ERROR([Please install OCaml module 'extlib'.]) +fi + +dnl Optional programs. +AC_CHECK_PROG([PERLDOC],[perldoc],[perldoc],[no]) +if test "x$PERLDOC" = "xno" ; then + AC_MSG_WARN([perldoc not found - install perl to make man pages]) +fi +AM_CONDITIONAL([HAVE_PERLDOC],[test "x$PERLDOC" != "xno"]) + +AC_CONFIG_HEADERS([config.h]) +AC_CONFIG_FILES([Makefile config.ml]) +AC_OUTPUT diff --git a/destination_tab.ml b/destination_tab.ml new file mode 100644 index 0000000..60fb60f --- /dev/null +++ b/destination_tab.ml @@ -0,0 +1,26 @@ +(* Virt resize UI. + * Copyright (C) 2011 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. + *) + +class tab (vbox : GPack.box) = +object + inherit GObj.widget (vbox#as_widget) +end + +let tab () = + let vbox = GPack.vbox ~border_width:8 () in + new tab vbox diff --git a/destination_tab.mli b/destination_tab.mli new file mode 100644 index 0000000..207c27b --- /dev/null +++ b/destination_tab.mli @@ -0,0 +1,28 @@ +(* Virt resize UI. + * Copyright (C) 2011 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 Destination_tab module handles the "Destionation" tab in the + main window. *) + +class tab : GPack.box -> +object + inherit GObj.widget + val obj : Gtk.widget Gtk.obj +end + +val tab : unit -> tab diff --git a/logvols_tab.ml b/logvols_tab.ml new file mode 100644 index 0000000..60fb60f --- /dev/null +++ b/logvols_tab.ml @@ -0,0 +1,26 @@ +(* Virt resize UI. + * Copyright (C) 2011 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. + *) + +class tab (vbox : GPack.box) = +object + inherit GObj.widget (vbox#as_widget) +end + +let tab () = + let vbox = GPack.vbox ~border_width:8 () in + new tab vbox diff --git a/logvols_tab.mli b/logvols_tab.mli new file mode 100644 index 0000000..3bf7206 --- /dev/null +++ b/logvols_tab.mli @@ -0,0 +1,28 @@ +(* Virt resize UI. + * Copyright (C) 2011 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 Logvols_tab module handles the "Logical volumes" tab in the + main window. *) + +class tab : GPack.box -> +object + inherit GObj.widget + val obj : Gtk.widget Gtk.obj +end + +val tab : unit -> tab 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 < +object + inherit GObj.widget + val obj : Gtk.widget Gtk.obj +end + +val tab : unit -> tab diff --git a/slave.ml b/slave.ml new file mode 100644 index 0000000..9167ff0 --- /dev/null +++ b/slave.ml @@ -0,0 +1,289 @@ +(* Virt-resize UI. + * Copyright (C) 2011 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 Printf + +open Slave_types +open Utils + +(*module C = Libvirt.Connect*) +module Cond = Condition +(*module D = Libvirt.Domain*) +module G = Guestfs +module M = Mutex +module Q = Queue + +(* Callbacks. *) +type 'a callback = 'a -> unit +let no_callback _ = () + +(* Hooks. *) +let failure_hook = ref (fun _ -> ()) +let busy_hook = ref (fun _ -> ()) +let idle_hook = ref (fun _ -> ()) +let status_hook = ref (fun _ -> ()) +let progress_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 +let set_status_hook cb = status_hook := cb +let set_progress_hook cb = progress_hook := cb + +(* Messages. *) +type message = + | Exit_thread + | Open_images of (string * string option) list * inspection_data callback + +let rec string_of_message = function + | Exit_thread -> "Exit_thread" + | Open_images (images, _) -> + sprintf "Open_images %s" (string_of_images images) + +and string_of_images images = + "[" ^ + String.concat "; " + (List.map ( + function + | fn, None -> fn + | fn, Some format -> sprintf "%s (%s)" fn format + ) images) ^ + "]" + +(* 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_discard = ref false +let q_lock = M.create () +let q_cond = Cond.create () + +(* Send a command message to the slave thread. *) +let send_message ?fail msg = + debug "sending message %s to slave thread ..." (string_of_message msg); + with_lock q_lock ( + fun () -> + Q.push (fail, msg) q; + Cond.signal q_cond + ) + +let discard_command_queue () = + with_lock q_lock ( + fun () -> + Q.clear q; + (* Discard the currently running command too. *) + q_discard := true + ) + +(*----------------------------------------------------------------------*) +(* This is the slave thread. *) + +(* Run the callback unless someone set the q_discard flag while we + were running the command. This allows discard_command_queue () to + discard both the command queue and the running command (although + the running command is not interrupted). *) +let callback_if_not_discarded (cb : 'a callback) (arg : 'a) = + let discard = with_lock q_lock (fun () -> !q_discard) in + if not discard then + GtkThread.async cb arg + +(* Set this to true to exit the thread. *) +let quit = ref false + +(* Handles. These are not protected by locks because only the slave + * thread has access to them. + *) +(*let conn = ref None*) +let g = ref None + +(* Update the status bar. *) +let status fs = + let f str = GtkThread.async !status_hook str in + ksprintf f fs + +let rec loop () = + debug "top of slave loop"; + + (* Get the next command. *) + let fail, cmd = + with_lock q_lock ( + fun () -> + while Q.is_empty q do Cond.wait q_cond q_lock done; + q_discard := false; + Q.pop q + ) in + + debug "slave processing command %s ..." (string_of_message cmd); + + (try + GtkThread.async !busy_hook (); + execute_command cmd + with exn -> + (* If the user provided an override ?fail parameter to the + original call, call that, else call the global hook. *) + match fail with + | Some cb -> GtkThread.async cb exn + | None -> GtkThread.async !failure_hook exn + ); + + (* If there are no more commands in the queue, run the idle hook. *) + let empty = with_lock q_lock (fun () -> Q.is_empty q) in + if empty then GtkThread.async !idle_hook (); + + if !quit then Thread.exit (); + loop () + +and execute_command = function + | Exit_thread -> + quit := true; + close_all () + + | Open_images (images, cb) as cmd -> + status "Opening disk images ..."; + + open_disk_images images cb cmd + +(* Close all handles. *) +and close_all () = +(* + (match !conn with Some conn -> C.close conn | None -> ()); + conn := None; +*) + close_g () + +and close_g () = + (match !g with Some g -> g#close () | None -> ()); + g := None + +(* The common code for Open_domain and Open_images which opens the + * libguestfs handle, adds the disks, and launches the appliance. + *) +and open_disk_images images cb cmd = + debug "opening disk image %s" (string_of_images images); + + close_g (); + let g' = new G.guestfs () in + g := Some g'; + let g = g' in + + g#set_trace (trace ()); + + (* Attach progress bar callback. *) + ignore ( + g#set_event_callback ( + fun g event handle buf array -> + if event == G.EVENT_PROGRESS && Array.length array >= 4 then ( + let proc_nr = array.(0) + and serial = array.(1) + and position = array.(2) + and total = array.(3) in + debug "progress callback proc_nr=%Ld serial=%Ld posn=%Ld total=%Ld" + proc_nr serial position total; + GtkThread.async !progress_hook (position, total) + ) + ) [ G.EVENT_PROGRESS ] + ); + + List.iter ( + function + | filename, None -> + g#add_drive_opts ~readonly:true filename + | filename, Some format -> + g#add_drive_opts ~readonly:true ~format filename + ) images; + + g#launch (); + + status "Listing filesystems ..."; + + (* Get list of filesystems. *) + let fses = g#list_filesystems () in + + status "Looking for operating systems ..."; + + (* Perform inspection. This can fail, ignore errors. *) + let roots = + try Array.to_list (g#inspect_os ()) + with + G.Error msg -> + debug "inspection failed (error ignored): %s" msg; + [] in + + let oses = List.map ( + fun root -> + let typ = g#inspect_get_type root in + let windows_current_control_set = + if typ <> "windows" then None + else ( + try Some (g#inspect_get_windows_current_control_set root) + with G.Error _ -> None + ) in + let windows_systemroot = + if typ <> "windows" then None + else ( + try Some (g#inspect_get_windows_systemroot root) + with G.Error _ -> None + ) in + + { + insp_root = root; + insp_arch = g#inspect_get_arch root; + insp_distro = g#inspect_get_distro root; + insp_drive_mappings = g#inspect_get_drive_mappings root; + insp_filesystems = g#inspect_get_filesystems root; + insp_hostname = g#inspect_get_hostname root; + insp_major_version = g#inspect_get_major_version root; + insp_minor_version = g#inspect_get_minor_version root; + insp_mountpoints = g#inspect_get_mountpoints root; + insp_package_format = g#inspect_get_package_format root; + insp_package_management = g#inspect_get_package_management root; + insp_product_name = g#inspect_get_product_name root; + insp_product_variant = g#inspect_get_product_variant root; + insp_type = typ; + insp_windows_current_control_set = windows_current_control_set; + insp_windows_systemroot = windows_systemroot; + } + ) roots in + + let data = { + insp_all_filesystems = fses; + insp_oses = oses; + } in + + status "Finished opening disk"; + + callback_if_not_discarded cb data + +(*----------------------------------------------------------------------*) +(* Start up one slave thread when the program starts. *) +let slave_thread = Thread.create loop () + +let exit_thread () = + discard_command_queue (); + send_message Exit_thread; + Thread.join slave_thread diff --git a/slave.mli b/slave.mli new file mode 100644 index 0000000..2323938 --- /dev/null +++ b/slave.mli @@ -0,0 +1,138 @@ +(* Virt-resize UI. + * Copyright (C) 2011 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. *) + +(** {2 Commands and callbacks} + + Commands for libvirt and libguestfs are executed in a separate + slave thread. This file describes the interface with that thread + that the rest of the program sees. + + Commands are intentionally as high level as possible. Often a + single command may perform many libvirt and libguestfs operations + before returing a result. This is to make use of the slave thread + as simple as possible. + + Commands are executed in a "continuation-passing style" (CPS), + which means that you call a function to issue the command, passing + in a callback ("continuation"). The function returns immediately. + The callback may be called some time later once the issued command + completes successfully. Several commands can be queued up for + execution. Commands are executed and callbacks are performed in + sequence. + + The callback returns the result of the command. The callback does + not get invoked if there was an error, or if the command was + cancelled before it runs (see {!discard_command_queue}). For some + commands the callback can be called multiple times (see + documentation below). +*) + +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. Each function can + optionally supply an extra callback to handle errors, or if + not supplied then it defaults to the failure hook set by + {!set_failure_hook}. *) + +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. *) + +type message = + (** {!b Do not use this directly}. Call {!Slave.exit_thread} + instead. *) + | Exit_thread + + (** Open disk image(s). Return the guest inspection data. *) + | Open_images of (string * string option) list * + Slave_types.inspection_data callback + +val string_of_message : message -> string +(** Useful debugging function to display a message. *) + +val send_message : ?fail:exn callback -> message -> unit +(** Send a message to the slave thread. + + Note as described above, this function returns immediately. A + callback (passed in the message) is called some time later if + the call succeeds, otherwise one of the failure methods + described above is used. *) + +val discard_command_queue : unit -> unit +(** [discard_command_queue ()] discards any commands on the command + queue. + + The currently running command cannot be discarded (because of + the design of libguestfs). Instead the callback is discarded, + so from the point of view of the main thread, the effect is + similar. *) + +val exit_thread : unit -> unit +(** [exit_thread ()] causes the slave thread to exit, and returns + synchronously once the slave thread has exited. *) + +(** {2 Hooks} + + Hooks are like callbacks, except they hook into special events + that happen in the slave thread, 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". + + {!set_progress_hook} is used to implement a progress bar. *) + +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. *) + +val set_status_hook : string callback -> unit +(** Set the function in the main thread which is called to + update the status bar. The slave thread updates the + status bar when an operation starts or stops, keeping the + user informed of what is happening. *) + +val set_progress_hook : (int64 * int64) callback -> unit +(** Set the function in the main thread which is called whenever the + slave thread receives a progress notification message from + libguestfs. *) diff --git a/slave_types.ml b/slave_types.ml new file mode 100644 index 0000000..4e65976 --- /dev/null +++ b/slave_types.ml @@ -0,0 +1,52 @@ +(* Virt-resize UI. + * Copyright (C) 2011 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. + *) + +module D = Libvirt.Domain +module G = Guestfs + +(* +type domain = { + dom_id : int; + dom_name : string; + dom_state : D.state; +} +*) + +type inspection_data = { + insp_all_filesystems : (string * string) list; + insp_oses : inspection_os list; +} + +and inspection_os = { + insp_root : string; + insp_arch : string; + insp_distro : string; + insp_drive_mappings : (string * string) list; + insp_filesystems : string array; + insp_hostname : string; + insp_major_version : int; + insp_minor_version : int; + insp_mountpoints : (string * string) list; + insp_package_format : string; + insp_package_management : string; + insp_product_name : string; + insp_product_variant : string; + insp_type : string; + insp_windows_current_control_set : string option; + insp_windows_systemroot : string option; +} diff --git a/slave_types.mli b/slave_types.mli new file mode 100644 index 0000000..cb90d77 --- /dev/null +++ b/slave_types.mli @@ -0,0 +1,56 @@ +(* Virt-resize UI. + * Copyright (C) 2011 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 types used by the slave thread. *) + +(* +type domain = { + dom_id : int; + dom_name : string; + dom_state : Libvirt.Domain.state; +} + (** List of domains as returned in the {!Slave.connect} callback. *) +*) + +type inspection_data = { + insp_all_filesystems : (string * string) list; + (** see {!Guestfs.list_filesystems} *) + insp_oses : inspection_os list; + (** one entry per root (operating system), see {!Guestfs.inspect_os} *) +} + (** The inspection data returned in the callback from + {!Slave.open_domain} and {!Slave.open_images}. *) + +and inspection_os = { + insp_root : string; (** see {!Guestfs.inspect_os} *) + insp_arch : string; + insp_distro : string; + insp_drive_mappings : (string * string) list; + insp_filesystems : string array; + insp_hostname : string; + insp_major_version : int; + insp_minor_version : int; + insp_mountpoints : (string * string) list; + insp_package_format : string; + insp_package_management : string; + insp_product_name : string; + insp_product_variant : string; + insp_type : string; + insp_windows_current_control_set : string option; + insp_windows_systemroot : string option; +} diff --git a/source_tab.ml b/source_tab.ml new file mode 100644 index 0000000..f791e80 --- /dev/null +++ b/source_tab.ml @@ -0,0 +1,213 @@ +(* Virt resize UI. + * Copyright (C) 2011 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 Printf + +open Slave_types +open Utils + +type file_input = { + file_button : GButton.radio_button; + file_chooser : GFile.chooser_button; + file_format_raw : GButton.radio_button; + file_format_qcow2 : GButton.radio_button; + file_format_detect : GButton.radio_button; + file_open_button : GButton.button; +} + +let file_input_set_sensitive t b = + t.file_chooser#misc#set_sensitive b; + t.file_format_raw#misc#set_sensitive b; + t.file_format_qcow2#misc#set_sensitive b; + t.file_format_detect#misc#set_sensitive b; + t.file_open_button#misc#set_sensitive b + +type libvirt_input = { + libvirt_button : GButton.radio_button; + libvirt_combo : GEdit.combo; +} + +let libvirt_input_set_sensitive t b = + t.libvirt_combo#misc#set_sensitive b + +type inspection = { + inspection_label : GMisc.label; +} + +class tab + (tbl : GPack.table) ready_signal not_ready_signal + file_input libvirt_input inspection = +object (self) + inherit GObj.widget (tbl#as_widget) + inherit GUtil.ml_signals [ready_signal#disconnect; + not_ready_signal#disconnect] + + (* Signals. *) + method ready : callback:(unit -> unit) -> GtkSignal.id = + ready_signal#connect ~after + method not_ready : callback:(unit -> unit) -> GtkSignal.id = + not_ready_signal#connect ~after + + (* This method will be called back when disk image or guest is + opened. *) + method private opened inspection_data = + (* We expect that there are some filesystems in the image, + otherwise fail. *) + if inspection_data.insp_all_filesystems = [] then + inspection.inspection_label#set_text + "error: no filesystems were found in the selected disk image or guest" + else ( + (match inspection_data.insp_oses with + | [] -> (* no OS, but there were filesystems *) + inspection.inspection_label#set_text + "warning: no operating systems were recognized in this disk image or guest" + + | [ os ] -> + let label = + sprintf "%s %s %d.%d" + os.insp_type os.insp_distro + os.insp_major_version os.insp_minor_version in + let label = + if os.insp_product_name <> "" then + label ^ " (" ^ os.insp_product_name ^ ")" + else + label in + inspection.inspection_label#set_text label + + | _ -> + inspection.inspection_label#set_text + "warning: resizing multi-boot virtual machines may not be successful" + ); + + (* Raise the ready signal. *) + ready_signal#call () + ) + + initializer + (* Set the inputs to be sensitive according to the state of the + top level radio buttons. *) + let make_sensitive = function + | `FileInput -> + file_input_set_sensitive file_input true; + libvirt_input_set_sensitive libvirt_input false + | `LibvirtInput -> + file_input_set_sensitive file_input false; + libvirt_input_set_sensitive libvirt_input true + in + + ignore ( + file_input.file_button#connect#toggled ~callback:( + fun () -> + if file_input.file_button#active then + make_sensitive `FileInput + else + make_sensitive `LibvirtInput + ) + ); + ignore ( + libvirt_input.libvirt_button#connect#toggled ~callback:( + fun () -> + if libvirt_input.libvirt_button#active then + make_sensitive `LibvirtInput + else + make_sensitive `FileInput + ) + ); + + (* Default sensitivity. *) + make_sensitive `FileInput; + + (* Wire up file dialog. *) + ignore ( + file_input.file_open_button#connect#clicked ~callback:( + fun () -> + match file_input.file_chooser#filename with + | None -> () (* nothing selected yet *) + | Some filename -> (* filename selected *) + let format = + if file_input.file_format_raw#active then Some "raw" + else if file_input.file_format_qcow2#active then Some "qcow2" + else if file_input.file_format_detect#active then None + else assert false in (* shouldn't be possible??? *) + let msg = Slave.Open_images ([filename, format], self#opened) in + Slave.send_message msg + ) + ) + +end + +let tab () = + let tbl = GPack.table ~border_width:8 ~columns:2 ~rows:1 () in + + (* Signals. *) + let ready_signal = new GUtil.signal () in + let not_ready_signal = new GUtil.signal () in + + let file_input = + let button = + GButton.radio_button ~label:"File or device:" + ~packing:(tbl#attach ~top:0 ~left:0) () in + let chooser = + GFile.chooser_button ~action:`OPEN + ~packing:(tbl#attach ~top:0 ~left:1) () in + (* We have an "unnecessary" open button here for a couple of + reasons: Firstly because lablgtk2 doesn't bind the file-set + callback, so we can't tell when a file has been picked in the + file chooser. But secondly because it allows the user to pick + a file and the format before actually opening the file (which + could be an expensive operation). *) + let open_button = + GButton.button ~label:"Open" + ~packing:(tbl#attach ~top:0 ~left:2) () in + let raw = GButton.radio_button ~label:"raw" + ~packing:(tbl#attach ~top:1 ~left:1) () in + let group = raw#group in + let qcow2 = GButton.radio_button ~label:"qcow2" ~group + ~packing:(tbl#attach ~top:2 ~left:1) () in + let detect = GButton.radio_button ~label:"autodetect format" + ~group ~active:true + ~packing:(tbl#attach ~top:3 ~left:1) () in + { file_button = button; file_chooser = chooser; + file_format_raw = raw; file_format_qcow2 = qcow2; + file_format_detect = detect; + file_open_button = open_button } in + + (* Add a dummy row as a spacer. *) + ignore (GMisc.label ~packing:(tbl#attach ~top:4 ~left:0) ()); + tbl#set_row_spacing 4 16; + + let libvirt_input = + let group = file_input.file_button#group in + let button = + GButton.radio_button ~label:"Guest:" ~group + ~packing:(tbl#attach ~top:5 ~left:0) () in + let combo = + GEdit.combo ~packing:(tbl#attach ~top:5 ~left:1) () in + { libvirt_button = button; libvirt_combo = combo } in + + (* Add a dummy row as a spacer. *) + ignore (GMisc.label ~packing:(tbl#attach ~top:6 ~left:0) ()); + tbl#set_row_spacing 6 16; + + let inspection = + let label = GMisc.label ~packing:(tbl#attach ~top:7 ~left:0 ~right:2) () in + { inspection_label = label } in + + (* Return the object. *) + new tab tbl ready_signal not_ready_signal + file_input libvirt_input inspection diff --git a/source_tab.mli b/source_tab.mli new file mode 100644 index 0000000..7da62ad --- /dev/null +++ b/source_tab.mli @@ -0,0 +1,44 @@ +(* Virt resize UI. + * Copyright (C) 2011 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 Source_tab module handles the "Source" tab in the main window. *) + +type file_input +type libvirt_input +type inspection + +class tab : GPack.table -> unit GUtil.signal -> unit GUtil.signal -> + file_input -> libvirt_input -> inspection -> +object ('a) + inherit GObj.widget + + val obj : Gtk.widget Gtk.obj + method after : 'a + method disconnect : GtkSignal.id -> unit + + (** Signal [not_ready] is raised when the source tab has missing + information. This is the initial state of the tab. *) + method not_ready : callback:(unit -> unit) -> GtkSignal.id + + (** Signal [ready] is raised when the user has provided all the + information requested, and the source disk image or guest has + been opened successfully. *) + method ready : callback:(unit -> unit) -> GtkSignal.id +end + +val tab : unit -> tab diff --git a/utils.ml b/utils.ml new file mode 100644 index 0000000..daeba0f --- /dev/null +++ b/utils.ml @@ -0,0 +1,119 @@ +(* Virt-resize UI. + * Copyright (C) 2011 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 ExtString +open ExtList + +open Printf + +let (+^) = Int64.add +let (-^) = Int64.sub +let ( *^ ) = Int64.mul +let (/^) = Int64.div +let (&^) = Int64.logand + +type ('a, 'b) either = Left of 'a | Right of 'b + +let verbose = ref false +let set_verbose_flag () = verbose := true +let verbose () = !verbose + +let debug fs = + let f str = + if verbose () then ( + prerr_string Config.package; + prerr_string ": tid "; + prerr_string (string_of_int (Thread.id (Thread.self ()))); + prerr_string ": "; + 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 + +let trace = ref false +let set_trace_flag () = trace := true +let trace () = !trace + +let connect_uri = ref None +let set_connect_uri conn = connect_uri := conn +let connect_uri () = !connect_uri + +let utf8_copyright = "\194\169" +let utf8_rarrow = "\xe2\x86\x92" + +let human_size i = + if i < 1024L then + sprintf "%Ld" i + else if i < 1024L *^ 1024L then + sprintf "%.1f KB" (Int64.to_float i /. 1024.) + else if i < 1024L *^ 1024L *^ 1024L then + sprintf "%.1f MB" (Int64.to_float i /. 1024. /. 1024.) + else if i < 1024L *^ 1024L *^ 1024L *^ 1024L then + sprintf "%.1f GB" (Int64.to_float i /. 1024. /. 1024. /. 1024.) + else + sprintf "%.1f TB" (Int64.to_float i /. 1024. /. 1024. /. 1024. /. 1024.) + +let human_size_1k i = + if i < 1024L then + sprintf "%Ld KB" i + else if i < 1024L *^ 1024L then + sprintf "%.1f MB" (Int64.to_float i /. 1024.) + else + sprintf "%.1f GB" (Int64.to_float i /. 1024. /. 1024.) + +let unique = let i = ref 0 in fun () -> incr i; !i + +let rec find_map f = function + | [] -> raise Not_found + | x :: xs -> + match f x with + | Some y -> y + | None -> find_map f xs + +(* g_markup_escape is not bound by lablgtk2, but we want to provide + * extra protection for \0 characters appearing in the string + * anyway. + *) +let markup_escape name = + let f = function + | '&' -> "&" | '<' -> "<" | '>' -> ">" + | '\000' -> "\\0" + | c -> String.make 1 c + in + String.replace_chars f name + +let libguestfs_version_string () = + let g = new Guestfs.guestfs () in + let v = g#version () in + let s = + sprintf "%Ld.%Ld.%Ld%s" + v.Guestfs.major v.Guestfs.minor v.Guestfs.release v.Guestfs.extra in + g#close (); + s + +let libvirt_version_string () = + let v = fst (Libvirt.get_version ()) in + sprintf "%d.%d.%d" (v / 1_000_000) ((v / 1_000) mod 1_000) (v mod 1_000) diff --git a/utils.mli b/utils.mli new file mode 100644 index 0000000..9825e3c --- /dev/null +++ b/utils.mli @@ -0,0 +1,85 @@ +(* Virt-resize UI. + * Copyright (C) 2011 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. *) + +val (+^) : int64 -> int64 -> int64 +val (-^) : int64 -> int64 -> int64 +val ( *^ ) : int64 -> int64 -> int64 +val (/^) : int64 -> int64 -> int64 +val (&^) : int64 -> int64 -> int64 + (** Int64 arithmetic operators. *) + +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 : unit -> bool +val set_verbose_flag : unit -> unit + (** If this contains [true] then {!debug} will send debugging + messages to stderr, else debugging messages are dropped. + + This is set through the --verbose command line option. *) + +val debug : ('a, unit, string, unit) format4 -> 'a + (** A printf-like function for writing debugging messages. *) + +val failwith : ('a, unit, string, 'b) format4 -> '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. *) + +val trace : unit -> bool +val set_trace_flag : unit -> unit + (** If this contains [true] then calls to libguestfs are traced. + + This is set through the [-x] command line option. *) + +val connect_uri : unit -> string option +val set_connect_uri : string option -> unit + (** The libvirt connection URI. + + This is set through the [--connect] command line option. *) + +val utf8_copyright : string (** UTF-8 copyright symbol *) +val utf8_rarrow : string (** UTF-8 RIGHTWARDS ARROW *) + +val human_size : int64 -> string + (** Convert a number of bytes into a human readable string. *) + +val human_size_1k : int64 -> string + (** Same as {!human_size} but the argument is 1KB blocks (used for + disk usage). *) + +val unique : unit -> int + (** Return a new integer each time called. *) + +val find_map : ('a -> 'b option) -> 'a list -> 'b + (** [find_map f xs] calls function [f] on each member of [xs] in order. + If [f] returns [Some b] then we stop and return [b]. If all calls + to [f] return [None] then this raises [Not_found]. *) + +val markup_escape : string -> string + (** Like g_markup_escape but with extra protection for strings + containing \0 characters. *) + +val libguestfs_version_string : unit -> string + (** Return the version of libguestfs as a string. *) + +val libvirt_version_string : unit -> string + (** Return the version of libvirt as a string. *) diff --git a/virt-resize-ui.pod b/virt-resize-ui.pod new file mode 100644 index 0000000..a6ffe5b --- /dev/null +++ b/virt-resize-ui.pod @@ -0,0 +1,129 @@ +=encoding utf8 + +=head1 NAME + +virt-resize-ui - Graphical interface for virt-resize + +=head1 SYNOPSIS + + virt-resize-ui [--options] + +=head1 DESCRIPTION + +C is a graphical interface for the command line +L program. It enables many of the features of +C through a guided, interactive interface. + +In most cases you can just run C and follow the +questions. + +C does not I to run as root, but it may have to +access disk images that can only be read or created as root (for +example to read virtual machines or do C). If you only want +to resize disk images stored as files in your home directory then root +is not needed. + +=head1 OPTIONS + +=over 4 + +=item B<-a> + +=item B<--add> + +Add I which should be a disk image. You can supply multiple +disk images by repeating this option. + +The format of the disk image is auto-detected. To override this and +force a particular format use the I<--format=..> option. + +=item B<-c> URI + +=item B<--connect> URI + +If using libvirt, connect to the given I. If omitted, then we +connect to the default libvirt hypervisor. + +If you specify guest block devices directly (I<-a>), then libvirt is +not used at all. + +=item B<-d> guest + +=item B<--domain> guest + +Add all the disks from the named libvirt guest. + +=item B<--format raw> + +=item B<--format qcow2> + +=item B<--format ""> + +The default for the I<-a> option is to auto-detect the format of the +disk image. Using this forces the disk format for I<-a> options which +follow on the command line. Using I<--format ""> (an empty string +argument) switches back to auto-detection for subsequent I<-a> +options. + +For example: + + virt-resize-ui --format raw -a disk.img + +forces raw format (no auto-detection) for C. + + virt-resize-ui --format raw -a disk.img --format "" -a another.img + +forces raw format (no auto-detection) for C and reverts to +auto-detection for C. + +If you have untrusted raw-format guest disk images, you should use +this option to specify the disk format. This avoids a possible +security problem with malicious guests (CVE-2010-3851). + +=item B<-v> + +=item B<--verbose> + +Enable verbose messages for debugging. + +=item B<-V> + +=item B<--version> + +Display version number and exit. + +=item B<-x> + +Enable tracing of libguestfs API calls. + +=back + +=head1 SEE ALSO + +L, +L, +L, +L, +L. + +=head1 AUTHOR + +Richard W.M. Jones L + +=head1 COPYRIGHT + +Copyright (C) 2011 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., 675 Mass Ave, Cambridge, MA 02139, USA. diff --git a/window.ml b/window.ml new file mode 100644 index 0000000..b00c6b0 --- /dev/null +++ b/window.ml @@ -0,0 +1,123 @@ +(* Virt resize UI. + * Copyright (C) 2011 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 file_menu = { + quit_item : GMenu.menu_item; +} + +type help_menu = { + about_item : GMenu.menu_item; +} + +type tabs = { + source_tab : Source_tab.tab; + destination_tab : Destination_tab.tab; + partitions_tab : Partitions_tab.tab; + logvols_tab : Logvols_tab.tab; +} + +type buttons = { + prev_button : GButton.button; + next_button : GButton.button; + go_button : GButton.button; + exit_button : GButton.button; +} + +class window = + let title = "Resize a virtual machine - virt-resize-ui" in +object (self) + initializer + (* Window. *) + let window = GWindow.window ~width:700 ~height:700 ~title () in + let vbox = GPack.vbox ~packing:window#add () in + + (* 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 file_menu = + let menu = factory#add_submenu "_File" in + let factory = new GMenu.factory menu ~accel_group in + let quit = factory#add_item "E_xit" ~key:GdkKeysyms._Q in + { quit_item = quit } in + + let help_menu = + let menu = factory#add_submenu "_Help" in + let factory = new GMenu.factory menu ~accel_group in + let about = factory#add_item "About virt-resize-ui ..." in + { about_item = about } in + + (* Tabbed notebook for main part of the display. *) + let tabs = + let nb = GPack.notebook ~packing:(vbox#pack ~expand:true ~fill:true) () in + + let src = Source_tab.tab () in + let tab_label = (GMisc.label ~text:"Source" () :> GObj.widget) in + ignore (nb#append_page ~tab_label (src :> GObj.widget)); + + let dest = Destination_tab.tab () in + let tab_label = (GMisc.label ~text:"Destination" () :> GObj.widget) in + ignore (nb#append_page ~tab_label (dest :> GObj.widget)); + + let parts = Partitions_tab.tab () in + let tab_label = + (GMisc.label ~text:"Resize partitions" () :> GObj.widget) in + ignore (nb#append_page ~tab_label (parts :> GObj.widget)); + + let lvs = Logvols_tab.tab () in + let tab_label = + (GMisc.label ~text:"Expand logical volumes" () :> GObj.widget) in + ignore (nb#append_page ~tab_label (lvs :> GObj.widget)); + + { source_tab = src; destination_tab = dest; + partitions_tab = parts; logvols_tab = lvs } in + + (* Buttons. *) + let buttons = + let bbox = GPack.button_box `HORIZONTAL ~packing:vbox#pack () in + bbox#set_border_width 8; + + let ex = GButton.button ~stock:`QUIT ~packing:bbox#pack () in + ex#misc#set_sensitive true; + let prev = GButton.button ~stock:`GO_BACK ~packing:bbox#pack () in + prev#misc#set_sensitive false; + let next = GButton.button ~stock:`GO_FORWARD ~packing:bbox#pack () in + next#misc#set_sensitive true; + let go = GButton.button ~stock:`APPLY ~packing:bbox#pack () in + go#misc#set_sensitive false; + { prev_button = prev; next_button = next; go_button = go; + exit_button = ex } in + + ignore help_menu; + ignore tabs; + + (* Quit button. *) + let quit _ = GMain.quit (); false in + ignore (window#connect#destroy ~callback:GMain.quit); + ignore (window#event#connect#delete ~callback:quit); + ignore (file_menu.quit_item#connect#activate + ~callback:(fun () -> ignore (quit ()); ())); + ignore (buttons.exit_button#connect#clicked + ~callback:(fun () -> ignore (quit ()); ())); + + (* Accel_group. *) + window#add_accel_group accel_group; + + window#show () +end diff --git a/window.mli b/window.mli new file mode 100644 index 0000000..f8eadac --- /dev/null +++ b/window.mli @@ -0,0 +1,24 @@ +(* Virt resize UI. + * Copyright (C) 2011 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 Window module handles the main window and menus. *) + +class window : +object + (* empty, for now *) +end -- 1.8.3.1