*~
+*.1
+*.o
+*.cmi
+*.cmx
+.depend
Makefile
Makefile.in
+/.deps
/aclocal.m4
/autom4te.cache
+/compile
/configure
+/config.guess
+/config.h
+/config.h.in
/config.log
+/config.ml
/config.status
-/local*
+/config.sub
+/depcomp
/install-sh
+/libtool
+/link.sh
+/local*
+/ltmain.sh
/mclu-*.tar.gz
/mclu
+/m4/libtool.m4
+/m4/ltoptions.m4
+/m4/ltsugar.m4
+/m4/ltversion.m4
+/m4/lt~obsolete.m4
/missing
/run
+/stamp-h1
--- /dev/null
+# mclu: Mini Cloud
+# Copyright (C) 2014-2015 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.
+
+CLEANFILES = *~ *.cmi *.cmo *.cmx
+
+ACLOCAL_AMFLAGS = -I m4
+
+EXTRA_DIST = \
+ $(SOURCES_MLI) \
+ $(SOURCES_ML) \
+ templates/rawhide.sh
+
+# In alphabetical order.
+SOURCES_MLI = \
+ mclu_boot.mli \
+ mclu_conf.mli \
+ mclu_list.mli \
+ mclu_onoff.mli \
+ mclu_status.mli \
+ parallel.mli \
+ template.mli \
+ utils.mli
+
+# These must appear in dependency order.
+SOURCES_ML = \
+ config.ml \
+ utils.ml \
+ parallel.ml \
+ template.ml \
+ mclu_conf.ml \
+ mclu_list.ml \
+ mclu_status.ml \
+ mclu_onoff.ml \
+ mclu_boot.ml \
+ mclu.ml
+
+OCAMLPACKAGES = -package unix,pcre,libvirt
+OCAMLFLAGS = -g -warn-error CDEFLMPSUVYZX-3
+
+BOBJECTS = $(SOURCES_ML:.ml=.cmo)
+XOBJECTS = $(BOBJECTS:.cmo=.cmx)
+if !HAVE_OCAMLOPT
+OBJECTS = $(BOBJECTS)
+BEST = ocamlc
+else
+OBJECTS = $(XOBJECTS)
+BEST = ocamlopt
+endif
+
+bin_PROGRAMS = mclu
+# Since there are no real C sources (at least, not yet) we have a
+# token C file that is empty, just to keep automake happy. The real
+# sources are *.ml files.
+mclu_SOURCES = empty.c
+mclu_DEPENDENCIES = $(OBJECTS)
+mclu_LINK = \
+ ./link.sh \
+ $(OCAMLFIND) $(BEST) $(OCAMLFLAGS) $(OCAMLPACKAGES) \
+ $(OBJECTS) -o $@
+
+.mli.cmi:
+ $(OCAMLFIND) ocamlc $(OCAMLFLAGS) $(OCAMLPACKAGES) -c $< -o $@
+.ml.cmo:
+ $(OCAMLFIND) ocamlc $(OCAMLFLAGS) $(OCAMLPACKAGES) -c $< -o $@
+if HAVE_OCAMLOPT
+.ml.cmx:
+ $(OCAMLFIND) ocamlopt $(OCAMLFLAGS) $(OCAMLPACKAGES) -c $< -o $@
+endif
+
+# Dependencies.
+depend: .depend
+
+.depend: $(SOURCES_MLI) $(SOURCES_ML)
+ rm -f $@ $@-t
+ $(OCAMLFIND) ocamldep -I $(abs_srcdir) -I . $^ | \
+ $(SED) 's/ *$$//' | \
+ $(SED) -e :a -e '/ *\\$$/N; s/ *\\\n */ /; ta' | \
+ $(SED) -e 's,$(abs_srcdir)/,$(builddir)/,g' | \
+ sort > $@-t
+ mv $@-t $@
+
+-include .depend
+
+DISTCLEANFILES = .depend
+.PHONY: depend
+
+# Configuration file.
+sysconf_DATA = mclu.conf
+
+# Documentation.
+man_MANS = mclu.1
+
+mclu.1: mclu.pod
+ $(POD2MAN) \
+ -c "Virtualization Support" \
+ --release "$(PACKAGE)-$(VERSION)" \
+ $< > $@-t
+ mv $@-t $@
--- /dev/null
+(* mclu: Mini Cloud
+ * Copyright (C) 2014-2015 Red Hat Inc.
+ * @configure_input@
+ *
+ * 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 maybe = function "no" -> None | s -> Some s
+
+let path_virt_builder = maybe "@VIRT_BUILDER@"
+let path_virt_viewer = maybe "@VIRT_VIEWER@"
+let path_wol = maybe "@WOL@"
+
+let package_name = "@PACKAGE_NAME@"
+let package_version = "@PACKAGE_VERSION@"
+
+let prefix = "@prefix@"
+let sysconfdir = "@sysconfdir@"
+
+(* Avoid stupid crap with datarootdir: *)
+let pkgdatadir = "@prefix@/share/@PACKAGE_NAME@"
--- /dev/null
+# mclu: Mini Cloud
+# Copyright (C) 2014-2015 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.
+
+AC_INIT([mclu],[2.0])
+AM_INIT_AUTOMAKE([foreign])
+
+AC_CONFIG_MACRO_DIR([m4])
+
+dnl Check for basic C environment.
+AC_PROG_CC_STDC
+AM_PROG_CC_C_O
+AC_PROG_CPP
+
+AC_C_PROTOTYPES
+test "x$U" != "x" && AC_MSG_ERROR([Compiler not ANSI compliant])
+
+AC_PROG_INSTALL
+
+dnl Define GNU_SOURCE etc.
+AC_USE_SYSTEM_EXTENSIONS
+
+dnl Need libtool for creating the shared library.
+AC_PROG_LIBTOOL
+
+dnl Check for OCaml.
+AC_PROG_OCAML
+AS_IF([test "x$OCAMLOPT" = "xno"],[
+ AC_MSG_ERROR([OCaml native compiler is required])
+])
+AC_PROG_FINDLIB
+AS_IF([test "x$OCAMLFIND" = "xno"],[
+ AC_MSG_ERROR([ocamlfind (findlib) is required])
+])
+
+dnl OCaml packages (all required).
+AC_CHECK_OCAML_PKG(pcre)
+AS_IF([test "x$OCAML_PKG_pcre" = "xno"],[
+ AC_MSG_ERROR([OCaml library 'pcre' is required])
+])
+
+AC_CHECK_OCAML_PKG(libvirt)
+AS_IF([test "x$OCAML_PKG_libvirt" = "xno"],[
+ AC_MSG_ERROR([OCaml library 'ocaml-libvirt' is required])
+])
+
+AM_CONDITIONAL([HAVE_OCAMLOPT], [test "x$OCAMLOPT" != "xno"])
+
+dnl virt-builder (optional).
+AC_PATH_PROG([VIRT_BUILDER],[virt-builder],[no])
+
+dnl virt-viewer (optional).
+AC_PATH_PROG([VIRT_VIEWER],[virt-viewer],[no])
+
+dnl Wake-on-LAN client (optional).
+AC_PATH_PROG([WOL],[wol],[no])
+
+dnl Check for pod2man (from Perl, for the manual).
+AC_CHECK_PROG([POD2MAN], [pod2man], [pod2man], [no])
+if test "x$POD2MAN" = "xno"; then
+ AC_MSG_ERROR([pod2man was not found. This is needed to build man pages.])
+fi
+
+dnl Produce output files.
+AC_CONFIG_HEADERS([config.h])
+AC_CONFIG_FILES([Makefile config.ml])
+AC_CONFIG_FILES([link.sh], [chmod +x,-w link.sh])
+AC_CONFIG_FILES([run], [chmod +x,-w run])
+
+AC_OUTPUT
--- /dev/null
+/* mclu: Mini Cloud
+ * Copyright (C) 2014-2015 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.
+ */
+
+/* intentionally empty */
--- /dev/null
+# mclu: Mini Cloud
+# @configure_input@
+# (C) Copyright 2014-2014 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.
+
+# Hack automake to link binary properly.
+
+exec "$@" -linkpkg
--- /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
+# mclu: Mini Cloud
+# Configuration file.
+
+[nodes]
+# Hostname followed by key=value pairs:
+# mac= MAC (hardware network) address, for wake-on-LAN
+# uri= The libvirt URI used to connect to the host
+# (default: qemu+ssh://root@$hostname/system)
+ham0 mac=74:d4:35:55:85:3f
+ham1 mac=74:d4:35:51:ab:86
+ham2 mac=74:d4:35:55:82:96
+ham3 mac=74:d4:35:55:84:b4
--- /dev/null
+(* mclu: Mini Cloud
+ * Copyright (C) 2014-2015 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
+
+open Printf
+
+let config_file =
+ let default =
+ try Sys.getenv "MCLU_CONFIG"
+ with Not_found -> Config.sysconfdir // "mclu.conf" in
+ ref default
+
+let verbose = ref false
+
+let show_version () =
+ printf "%s %s\n" Config.package_name Config.package_version;
+ exit 0
+
+let global_speclist = Arg.align [
+ "--config-file", Arg.Set_string config_file, "FILE Set configuration file";
+ "-f", Arg.Set_string config_file, "FILE Set configuration file";
+ "-v", Arg.Set verbose, " Enable verbose/debugging messages";
+ "--verbose", Arg.Set verbose, " Enable verbose/debugging messages";
+ "-V", Arg.Unit show_version, " Display version and exit";
+ "--version", Arg.Unit show_version, " Display version and exit";
+]
+let speclist = ref global_speclist
+let subcommand_run = ref (fun ~verbose _ -> assert false)
+let anon_fun, get_anon_args =
+ let i = ref 0 in
+ let args = ref [] in
+ let anon_fun arg =
+ incr i; let i = !i in
+ if i = 1 then (
+ match arg with
+ | "boot" ->
+ speclist := Mclu_boot.get_arg_speclist ();
+ subcommand_run := Mclu_boot.run
+ | "list" ->
+ speclist := Mclu_list.get_arg_speclist ();
+ subcommand_run := Mclu_list.run
+ | "off" ->
+ speclist := Mclu_onoff.get_arg_speclist ();
+ subcommand_run := Mclu_onoff.run ~on:false
+ | "on" ->
+ speclist := Mclu_onoff.get_arg_speclist ();
+ subcommand_run := Mclu_onoff.run ~on:true
+ | "status" ->
+ speclist := Mclu_status.get_arg_speclist ();
+ subcommand_run := Mclu_status.run
+ | _ ->
+ eprintf "mclu: unknown subcommand '%s'
+For help, use mclu --help or read the mclu(1) man page.\n" arg;
+ exit 1
+ )
+ else
+ args := arg :: !args
+ in
+ let get_anon_args () = List.rev !args in
+ anon_fun, get_anon_args
+let usage_msg = "\
+Usage:
+ mclu [-f mclu.conf] [--options] [list|status|boot|...] ...
+
+For more help, use mclu --help or read the mclu(1) man page.
+
+Options:"
+
+let () =
+ (* Parse the command line and subcommand arguments. *)
+ Arg.parse_dynamic speclist anon_fun usage_msg;
+
+ (* Load the configuration file. *)
+ Mclu_conf.load_configuration !config_file;
+
+ (* Run the subcommand. *)
+ let verbose = !verbose in
+ !subcommand_run ~verbose (get_anon_args ())
--- /dev/null
+=head1 NAME
+
+ mclu - Mini Cloud, a tiny, sane cloud
+
+=head1 SUMMARY
+
+mclu [-f mclu.conf] [--options] [list|status|boot|...] [...]
+
+mclu --help
+
+=head1 DESCRIPTION
+
+
+
+
+
+
+=head1 GLOBAL OPTIONS
+
+=over 4
+
+=item B<--help>
+
+Display brief help message and exit.
+
+=item B<-f mclu.conf>
+
+=item B<--config-file mclu.conf>
+
+Specify the path to the configuration file. If this command option is
+I<not> given, then the environment variable C<MCLU_CONFIG> is used,
+and if that environment variable is not set then C</etc/mclu.conf> is
+used.
+
+See also: L</CONFIGURATION FILE> below.
+
+=item B<-v>
+
+=item B<--verbose>
+
+Enable verbose / debugging messages.
+
+=item B<-V>
+
+=item B<--version>
+
+Display version number and exit.
+
+=back
+
+
+
+
+=head1 SUBCOMMANDS
+
+=over 4
+
+=item B<mclu boot template [host:]name [--memory ..] [--vcpus ..]>
+
+Boot (create) a new instance from B<template>. It will be started on
+B<host> and named B<name>. If the C<host:> prefix is not given then
+it is started on the first host that has sufficient free memory.
+
+The instance is created by running the template script. You can
+control resources using the following options:
+
+=over 4
+
+=item B<--memory nnG>
+
+Specify the amount of memory (RAM) to give this guest. You can use
+a number followed by a unit, eg. C<--memory=4G>
+
+=item B<--vcpus N>
+
+Specify the number of virtual CPUs to give to the guest. The default
+is the number of physical CPUs, but not more than 4.
+
+=back
+
+=item B<mclu list [--active] [--all] [--templates]>
+
+List all active (running) guests and/or templates. You can use
+the following options:
+
+=over 4
+
+=item B<--active>
+
+List only active (running) guests.
+
+=item B<--all>
+
+List active (running) guests, and templates. This is the default.
+
+=item B<--templates>
+
+List only templates.
+
+=back
+
+=item B<mclu off node|wildcard ...>
+
+Switch the node(s) off. Wildcards can be used in place of hostnames.
+
+mclu checks that no guests are running on the nodes. Migrate or shut
+down the guests first.
+
+=item B<mclu on node|wildcard ...>
+
+Switch the node(s) on. Wildcards can be used in place of hostnames.
+
+This requires Wake-on-LAN support, both on the target host and in the
+mclu configuration. mclu must have been compiled with the L<wol(1)>
+client installed, and the C<mclu.conf> file must list a MAC address
+for each host:
+
+ [nodes]
+ host0 mac=11:22:33:44:55:66
+ host1 mac=11:22:33:44:55:67
+
+=item B<mclu status>
+
+Display the status of the cloud. This shows you which nodes are on
+and off, and the amount of resources used and free on each node.
+
+=back
+
+
+=head1 CONFIGURATION FILE
+
+
+
+
+
+=head1 TEMPLATE FILES
+
+
+
+
+=head1 ENVIRONMENT VARIABLES
+
+=over 4
+
+=item C<MCLU_CONFIG>
+
+May be used to override the default configuration file location
+(C</etc/mclu.conf>). See L</CONFIGURATION FILE> above.
+
+=item C<MCLU_PATH>
+
+The path to the directory that contains template files. See
+L</TEMPLATE FILES> above.
+
+=back
+
+=head1 FILES
+
+
+
+
+=head1 SEE ALSO
+
+L<virt-builder(1)>,
+L<http://www.redhat.com/mailman/listinfo/virt-tools-list>
+
+=head1 AUTHORS
+
+Richard W.M. Jones <rjones @ redhat . com>
+
+=head1 COPYRIGHT
+
+(C) Copyright 2014-2015 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.
--- /dev/null
+(* mclu: Mini Cloud
+ * Copyright (C) 2014-2015 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.
+ *)
+
+(* Implement 'mclu boot'. *)
+
+module C = Libvirt.Connect
+module D = Libvirt.Domain
+module MS = Mclu_status
+
+open Printf
+
+open Utils
+
+let memory = ref 0L (* 0 = choose for me *)
+let set_memory s =
+ try memory := bytes_of_human_size s
+ with Not_found ->
+ eprintf "mclu: don't understand --memory parameter '%s'
+Try something like --memory 1G\n" s;
+ exit 1
+let vcpus = ref 0 (* 0 = choose for me *)
+
+let get_arg_speclist () = Arg.align [
+ "--cpus", Arg.Set_int vcpus, "n Number of virtual CPUs";
+ "--memory", Arg.String set_memory, "nnG Amount of RAM to give guest";
+ "--ram", Arg.String set_memory, "nnG Amount of RAM to give guest";
+ "--vcpus", Arg.Set_int vcpus, "n Number of virtual CPUs";
+]
+
+let boot ~verbose template name =
+ let templates = Template.templates () in
+
+ (* Does the template exist? *)
+ let template_filename =
+ try List.assoc template templates
+ with Not_found ->
+ eprintf "mclu: template %s not found
+Try `mclu list --templates' to list all known templates.\n" template;
+ exit 1 in
+
+ (* Probe the template for various features. *)
+ let template_info = Template.probe ~verbose template_filename in
+
+ (* Decide how much RAM we will give the guest. This affects our
+ * choice of node, so do it early.
+ *)
+ let memory = !memory in
+ let memory =
+ if memory > 0L then (
+ (* User requested, just check it's above the minimum. *)
+ match template_info.Template.minimum_memory with
+ | None -> memory
+ | Some min when min > memory ->
+ eprintf "mclu: minimum memory for this template is %s\n"
+ (human_size min);
+ exit 1
+ | Some _ -> memory
+ ) else (
+ (* User didn't request any memory setting, use the recommended. *)
+ match template_info.Template.recommended_memory with
+ | Some memory -> memory
+ | None -> 4L *^ 1024L *^ 1024L *^ 1024L (* 4 GB *)
+ ) in
+
+ (* Check what's running. *)
+ let summary = MS.node_guest_summary ~verbose () in
+
+ (* Did the user request a specific host? If not, choose one. *)
+ let hostname, name =
+ match name_parse name with
+ | Some hostname, name -> hostname, name
+ | None, name ->
+ (* Choose the first host with enough free memory. *)
+ let nodes = List.filter (
+ fun { MS.free_memory = free_memory } -> free_memory >= memory
+ ) summary in
+ match nodes with
+ | [] ->
+ eprintf "mclu: no node with enough free memory found
+Try: `mclu status' and `mclu on <node>'\n";
+ exit 1
+ | node :: _ ->
+ let hostname =
+ node.MS.node_status.MS.node.Mclu_conf.hostname in
+ hostname, name in
+
+ (* Check there isn't a guest with this name running anywhere
+ * in the cluster already.
+ *)
+ List.iter (
+ fun ({ MS.active_guests = guests } as node) ->
+ List.iter (
+ fun { Mclu_list.dom_name = n } ->
+ if name = n then (
+ let hostname =
+ node.MS.node_status.MS.node.Mclu_conf.hostname
+ in
+ eprintf "mclu: there is already a guest called '%s' (running on %s)\n"
+ name hostname;
+ exit 1
+ )
+ ) guests
+ ) summary;
+
+ (* Convert hostname to a specific node, and check it is up. *)
+ let node =
+ try List.find (
+ fun node ->
+ node.MS.node_status.MS.node.Mclu_conf.hostname = hostname
+ ) summary
+ with Not_found ->
+ eprintf "mclu: no node is called '%s'\n" hostname;
+ exit 1 in
+ if not node.MS.node_status.MS.node_on then (
+ eprintf "mclu: node '%s' is switched off
+Try: `mclu on %s'\n" hostname hostname;
+ exit 1
+ );
+
+ (* Where we upload the template and image on remote. *)
+ let format, extension = "qcow2", "qcow2" in
+ let remote_filename = sprintf "/tmp/mclu%s.sh" (string_random8 ()) in
+ let remote_image = sprintf "/var/tmp/%s.%s" name extension in
+
+ (* Get ready to generate the guest XML. *)
+ let vcpus = !vcpus in
+ let vcpus =
+ if vcpus > 0 then vcpus
+ else min 4 node.MS.node_status.MS.node_info.C.cpus in
+ let mac_addr =
+ sprintf "52:54:00:%02x:%02x:%02x"
+ (Random.int 256) (Random.int 256) (Random.int 256) in
+
+ (* Generate the guest XML. XXX Quoting. *)
+ let xml = sprintf "\
+<domain type='kvm'>
+ <name>%s</name>
+ <memory unit='KiB'>%Ld</memory>
+ <currentMemory unit='KiB'>%Ld</currentMemory>
+ <vcpu>%d</vcpu>
+ <os>
+ <type>hvm</type>
+ <boot dev='hd'/>
+ </os>
+ <features>
+ <acpi/>
+ <apic/>
+ <pae/>
+ </features>
+ <cpu mode='host-model' fallback='allow' />
+ <clock offset='utc'>
+ <timer name='rtc' tickpolicy='catchup'/>
+ <timer name='pit' tickpolicy='delay'/>
+ <timer name='hpet' present='no'/>
+ </clock>
+ <on_poweroff>destroy</on_poweroff>
+ <on_reboot>restart</on_reboot>
+ <on_crash>restart</on_crash>
+ <devices>
+" name (memory /^ 1024L) (memory /^ 1024L) vcpus in
+
+ let xml = xml ^ sprintf "\
+ <disk type='file' device='disk'>
+ <driver name='qemu' type='%s' cache='none' io='native'/>
+ <source file='%s'/>
+" format remote_image in
+ let xml = xml ^
+ match template_info.Template.disk_bus with
+ | Some "ide" ->
+ " <target dev='sda' bus='ide'/>\n"
+ | Some "virtio-scsi" | None ->
+ " <target dev='sda' bus='scsi'/>\n"
+ | Some bus ->
+ eprintf "mclu: unknown disk-bus: %s\n" bus;
+ exit 1 in
+ let xml = xml ^ "\
+ </disk>
+" in
+
+ let xml = xml ^
+ if template_info.Template.disk_bus = Some "virtio-scsi" then
+ " <controller type='scsi' index='0' model='virtio-scsi'/>\n"
+ else
+ "" in
+
+ (* XXX Don't hard-code bridge name here. *)
+ let network_model =
+ match template_info with
+ | { Template.network_model = None } -> "virtio"
+ | { Template.network_model = Some d } -> d in
+ let xml = xml ^ sprintf "\
+ <interface type='bridge'>
+ <mac address='%s'/>
+ <source bridge='br0'/>
+ <model type='%s'/>
+ </interface>
+" mac_addr network_model in
+
+ let xml = xml ^ "\
+ <console type='pty'>
+ <target type='virtio' port='0'/>
+ </console>
+ <input type='tablet' bus='usb'/>
+ <input type='mouse' bus='ps2'/>
+ <input type='keyboard' bus='ps2'/>
+ <graphics type='vnc' autoport='yes'/>
+ <video>
+ <model type='cirrus' vram='9216' heads='1'/>
+ </video>
+ </devices>
+</domain>" in
+
+ (* Copy the template to remote and build the guest. *)
+ let cmd =
+ sprintf "scp %s root@%s:%s"
+ (quote template_filename) (quote hostname) remote_filename in
+ if verbose then printf "%s\n%!" cmd;
+ if Sys.command cmd <> 0 then (
+ eprintf "mclu: scp template to remote failed\n";
+ exit 1
+ );
+ let cmd =
+ (* XXX Don't hard-code network_bridge here. *)
+ sprintf "ssh root@%s LIBGUESTFS_BACKEND_SETTINGS=network_bridge=br0 %s build %s %s %s"
+ (quote hostname) remote_filename
+ (quote template_info.Template.base_image) (quote remote_image)
+ format in
+ if verbose then printf "%s\n%!" cmd;
+ if Sys.command cmd <> 0 then (
+ eprintf "mclu: remote build failed\n";
+ exit 1
+ );
+
+ (* Start the guest. *)
+ try
+ let conn =
+ let name = node.MS.node_status.MS.node.Mclu_conf.libvirt_uri in
+ C.connect ~name () in
+ let dom = D.create_xml conn xml [] in
+ printf "mclu: %s:%s started\n" hostname (D.get_name dom)
+ with Libvirt.Virterror msg ->
+ eprintf "mclu: %s: %s\n" hostname (Libvirt.Virterror.to_string msg);
+ exit 1
+
+let run ~verbose = function
+ | [ template; name ] ->
+ boot ~verbose template name
+ | _ ->
+ eprintf "Usage: mclu boot <template> <[host:]name>\n";
+ exit 1
--- /dev/null
+(* mclu: Mini Cloud
+ * Copyright (C) 2014-2015 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.
+ *)
+
+val get_arg_speclist : unit -> (Arg.key * Arg.spec * Arg.doc) list
+
+val run : verbose:bool -> string list -> unit
--- /dev/null
+(* mclu: Mini Cloud
+ * Copyright (C) 2014-2015 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.
+ *)
+
+(* Parsing /etc/mclu.conf *)
+
+open Printf
+
+(* blank line *)
+let is_blank_line =
+ let rex = Pcre.regexp "^\\s*$" in
+ Pcre.pmatch ~rex
+
+(* comment *)
+let is_comment =
+ let rex = Pcre.regexp "^\\s*#" in
+ Pcre.pmatch ~rex
+
+(* [header] *)
+let is_header =
+ let rex = Pcre.regexp "^\\s*\\[(\\w+)\\]\\s*$" in
+ fun line ->
+ try
+ let subs = Pcre.exec ~rex line in
+ Some (Pcre.get_substring subs 1)
+ with
+ Not_found -> None
+
+let ws_rex = Pcre.regexp "\\s+"
+
+type node = {
+ hostname : string;
+ libvirt_uri : string;
+ mac_addr : string option;
+}
+
+let _nodes : node list ref = ref []
+
+let load_configuration config_file =
+ let chan =
+ try open_in config_file
+ with Sys_error msg ->
+ eprintf "mclu: %s: cannot open configuration file: %s\n" config_file msg;
+ exit 1 in
+ let rec loop section =
+ let line = input_line chan in
+ if is_blank_line line || is_comment line then
+ loop section
+ else (
+ match is_header line with
+ | Some "nodes" ->
+ loop `Nodes
+ | Some section ->
+ (* Ignore unknown sections and keep going. *)
+ printf "mclu: %s: warning: ignoring unknown section [%s]\n"
+ config_file section;
+ loop `Unknown
+ | None ->
+ (* How we parse lines within sections depends on the header. *)
+ match section with
+ | `Nodes ->
+ (* If we're in the [nodes] section, parse "hostname [key=value].." *)
+ (match Pcre.split ~rex:ws_rex line with
+ | [] -> assert false
+ | hostname :: defs ->
+ let node = {
+ hostname = hostname;
+ libvirt_uri = sprintf "qemu+ssh://root@%s/system" hostname;
+ mac_addr = None
+ } in
+ let node = List.fold_left (
+ fun node def ->
+ match Pcre.split ~pat:"=" ~max:2 def with
+ | ["mac"; value] -> { node with mac_addr = Some value }
+ | ["uri"; value] -> { node with libvirt_uri = value }
+ | [_] -> node (* key with no value - ignore *)
+ | [_; _] -> node (* unknown key=value - ignore *)
+ | _ -> assert false
+ ) node defs in
+ _nodes := node :: !_nodes;
+ loop section
+ )
+ | `Global
+ | `Unknown ->
+ (* Ignore the line. *)
+ printf "mclu: %s: warning: ignoring `%s'\n" config_file line;
+ loop section
+ )
+ in
+ (try
+ loop `Global
+ with End_of_file -> ()
+ );
+ close_in chan;
+
+ _nodes := List.rev !_nodes
+
+(* Get list of nodes. *)
+let nodes () = !_nodes
--- /dev/null
+(* mclu: Mini Cloud
+ * Copyright (C) 2014-2015 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.
+ *)
+
+val load_configuration : string -> unit
+
+type node = {
+ hostname : string;
+ libvirt_uri : string;
+ mac_addr : string option;
+}
+
+val nodes : unit -> node list
--- /dev/null
+(* mclu: Mini Cloud
+ * Copyright (C) 2014-2015 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.
+ *)
+
+(* Implement 'mclu list'. *)
+
+open Printf
+
+open Utils
+
+module C = Libvirt.Connect
+module D = Libvirt.Domain
+
+let list_what = ref `All
+let set_all () = list_what := `All
+let set_active () = list_what := `ActiveOnly
+let set_templates () = list_what := `TemplatesOnly
+
+let get_arg_speclist () = Arg.align [
+ "--active", Arg.Unit set_active, " List only active/running guests";
+ "--all", Arg.Unit set_all, " List active guests and templates (default)";
+ "--inactive", Arg.Unit set_templates, " List only templates";
+ "--running", Arg.Unit set_active, " List only active/running guests";
+ "--templates", Arg.Unit set_templates, " List only templates";
+]
+
+type dom_info = {
+ dom_name : string;
+ dom_info : D.info;
+}
+
+(* Return the active (running) guests. This utility function is
+ * also called from other places.
+ *)
+let active_guests ?(verbose = false) ?(nodes = Mclu_conf.nodes ()) () =
+ (* A list of running guests, indexed by each node. *)
+ let active_guests =
+ Parallel.map (
+ fun node ->
+ let hostname = node.Mclu_conf.hostname
+ and name = node.Mclu_conf.libvirt_uri in
+ let conn =
+ try Some (C.connect_readonly ~name ())
+ with Libvirt.Virterror msg ->
+ if verbose then
+ eprintf "mclu: %s: %s (ignored)\n" hostname
+ (Libvirt.Virterror.to_string msg);
+ None in
+ let dominfo =
+ match conn with
+ | Some conn ->
+ let dominfos = D.get_domains_and_infos conn [D.ListActive] in
+ (* D.t is abstract so we cannot marshal it. *)
+ List.map (
+ fun (dom, info) ->
+ { dom_name = D.get_name dom; dom_info = info }
+ ) dominfos
+ | None -> [] in
+ (node, dominfo)
+ ) nodes in
+ List.map (fun s -> Marshal.from_bytes s 0) active_guests
+
+let list ~verbose () =
+ let list_what = !list_what in
+
+ (match list_what with
+ | `TemplatesOnly -> ()
+ | `All | `ActiveOnly ->
+ let active_guests = active_guests ~verbose () in
+
+ List.iter (
+ fun ({ Mclu_conf.hostname = hostname }, dominfos) ->
+ List.iter (
+ fun { dom_name = name;
+ dom_info = { D.nr_virt_cpu = vcpus;
+ D.memory = memory_kb;
+ D.state = state } } ->
+ let host_dom_name = sprintf "%s:%s" hostname name in
+ printf "%-28s %s %dvcpus %s\n"
+ host_dom_name (string_of_dom_state state)
+ vcpus (human_size (memory_kb *^ 1024L))
+ ) dominfos
+ ) active_guests
+ );
+
+ (* For quasi-historical reasons, this command also lists the inactive
+ * guests, which in mclu v2 are templates.
+ *)
+ (match list_what with
+ | `ActiveOnly -> ()
+ | `All | `TemplatesOnly ->
+ let templates = Template.template_names () in
+
+ List.iter (
+ fun name ->
+ printf "%-28s template\n" name
+ ) templates
+ )
+
+let run ~verbose = function
+ | [] -> list ~verbose ()
+ | _ ->
+ eprintf "mclu list: Too many arguments\n";
+ exit 1
--- /dev/null
+(* mclu: Mini Cloud
+ * Copyright (C) 2014-2015 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.
+ *)
+
+val get_arg_speclist : unit -> (Arg.key * Arg.spec * Arg.doc) list
+
+val run : verbose:bool -> string list -> unit
+
+type dom_info = {
+ dom_name : string;
+ dom_info : Libvirt.Domain.info;
+}
+
+val active_guests : ?verbose:bool -> ?nodes:Mclu_conf.node list -> unit -> (Mclu_conf.node * dom_info list) list
+(** Return the active (running) guests on each node.
+
+ The optional [?nodes] parameter is the list of nodes to start
+ with. If not passed, then it examines every node. This parameter
+ is useful if you already know which nodes are up, to avoid trying
+ to connect to down nodes a second time. *)
--- /dev/null
+(* mclu: Mini Cloud
+ * Copyright (C) 2014-2015 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.
+ *)
+
+(* Implement 'mclu on' and 'mclu off'. *)
+
+open Printf
+
+open Utils
+
+let get_arg_speclist () = Arg.align [
+]
+
+let wake ~verbose nodes =
+ let wol =
+ match Config.path_wol with
+ | Some wol -> wol
+ | None ->
+ eprintf "mclu: Wake-on-LAN is not available
+Recompile mclu with the 'wol' program installed\n";
+ exit 1 in
+
+ (* Only wake nodes which are switched off. *)
+ let nodes = List.filter (fun { Mclu_status.node_on = on } -> not on) nodes in
+ let nodes = List.map (fun { Mclu_status.node = node } -> node) nodes in
+
+ List.iter (
+ function
+ | { Mclu_conf.mac_addr = Some mac_addr } ->
+ let cmd = sprintf "%s %s" (quote wol) (quote mac_addr) in
+ if verbose then printf "%s\n%!" cmd;
+ if Sys.command cmd <> 0 then (
+ eprintf "mclu: wol: command failed\n";
+ exit 1
+ )
+ | { Mclu_conf.hostname = hostname; mac_addr = None } ->
+ eprintf "mclu: Wake-on-LAN is not configured for node %s
+Edit mclu.conf and add 'mac=<MAC address>' to this host line.\n" hostname;
+ exit 1
+ ) nodes
+
+let shutdown ~verbose nodes =
+ (* Only shutdown nodes which are switched on. *)
+ let nodes = List.filter (fun { Mclu_status.node_on = on } -> on) nodes in
+ let nodes = List.map (fun { Mclu_status.node = node } -> node) nodes in
+
+ (* Get the active guests on these nodes. *)
+ let active_guests = Mclu_list.active_guests ~verbose ~nodes () in
+
+ let errors = ref 0 in
+
+ List.iter (
+ fun ({ Mclu_conf.hostname = hostname } as node) ->
+ let guests = try List.assoc node active_guests with Not_found -> [] in
+ if guests <> [] then (
+ eprintf "mclu: node %s has %d guest(s) running: %s
+Shut down these guests before turning off the node.\n"
+ hostname (List.length guests)
+ (String.concat ", "
+ (List.map (fun guest -> guest.Mclu_list.dom_name) guests));
+ incr errors
+ )
+ else (
+ (* We have to be cunning about this else ssh will return an error. *)
+ let cmd =
+ sprintf "ssh -o ForwardX11=no root@%s '(sleep 5; poweroff) </dev/null >/dev/null 2>&1 &'"
+ (quote hostname) in
+ if verbose then printf "%s\n%!" cmd;
+ if Sys.command cmd <> 0 then (
+ eprintf "mclu: %s: poweroff: command failed\n" hostname;
+ incr errors
+ )
+ )
+ ) nodes;
+
+ if !errors > 0 then
+ exit 1
+
+let expand_wildcards exprs =
+ let regexps = List.map regexp_of_glob exprs in
+ let regexps = List.map Pcre.regexp regexps in
+
+ let nodes = Mclu_status.node_statuses () in
+
+ let nodes =
+ List.filter (
+ fun { Mclu_status.node = { Mclu_conf.hostname = hostname } } ->
+ List.exists (fun rex -> Pcre.pmatch ~rex hostname) regexps
+ ) nodes in
+
+ if List.length nodes < List.length exprs then (
+ eprintf "mclu: [on|off]: some wildcards don't match hostnames\n";
+ exit 1
+ );
+
+ nodes
+
+let run ~verbose ~on = function
+ | (_::_) as xs ->
+ let nodes = expand_wildcards xs in
+ (if on then wake else shutdown) ~verbose nodes
+ | [] ->
+ eprintf "Usage: mclu [on|off] node|wildcard ...\n";
+ exit 1
--- /dev/null
+(* mclu: Mini Cloud
+ * Copyright (C) 2014-2015 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.
+ *)
+
+val get_arg_speclist : unit -> (Arg.key * Arg.spec * Arg.doc) list
+
+val run : verbose:bool -> on:bool -> string list -> unit
--- /dev/null
+(* mclu: Mini Cloud
+ * Copyright (C) 2014-2015 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.
+ *)
+
+(* Implement 'mclu status'. *)
+
+open Printf
+
+open Utils
+
+module C = Libvirt.Connect
+module D = Libvirt.Domain
+
+let get_arg_speclist () = Arg.align [
+]
+
+type node_status = {
+ node : Mclu_conf.node;
+ node_on : bool; (* true = appears to be switched on *)
+ node_info : C.node_info;
+}
+
+let node_statuses ?(verbose = false) ?(nodes = Mclu_conf.nodes ()) () =
+ let nodes =
+ Parallel.map (
+ fun node ->
+ let hostname = node.Mclu_conf.hostname
+ and name = node.Mclu_conf.libvirt_uri in
+ let conn =
+ try Some (C.connect_readonly ~name ())
+ with Libvirt.Virterror msg ->
+ if verbose then
+ eprintf "mclu: %s: %s (ignored)\n" hostname
+ (Libvirt.Virterror.to_string msg);
+ None in
+ let node_info =
+ match conn with
+ | Some conn -> C.get_node_info conn
+ | None -> { C.model = ""; memory = 0L; cpus = 0;
+ mhz = 0; nodes = 0;
+ sockets = 0; cores = 0; threads = 0 } in
+ { node = node; node_on = conn <> None; node_info = node_info }
+ ) nodes in
+ List.map (fun s -> Marshal.from_bytes s 0) nodes
+
+type node_guest_summary = {
+ node_status : node_status;
+ active_guests : Mclu_list.dom_info list;
+ used_memory : int64;
+ used_vcpus : int;
+ free_memory : int64;
+}
+
+let node_guest_summary ?(verbose = false) () =
+ let node_statuses = node_statuses ~verbose () in
+
+ (* Get list of active guests for nodes which are on. *)
+ let active_guests =
+ let nodes = List.filter (fun { node_on = on } -> on) node_statuses in
+ let nodes = List.map (fun { node = node } -> node) nodes in
+ Mclu_list.active_guests ~verbose ~nodes () in
+
+ List.map (
+ fun node_status ->
+ let guests =
+ try List.assoc node_status.node active_guests with Not_found -> [] in
+ let used_vcpus, used_memory_kb =
+ List.fold_left (
+ fun (used_vcpus, used_memory_kb)
+ { Mclu_list.dom_info = { D.nr_virt_cpu = vcpus;
+ memory = memory_kb } } ->
+ (used_vcpus + vcpus, used_memory_kb +^ memory_kb)
+ ) (0, 0L) guests in
+ let used_memory = used_memory_kb *^ 1024L in
+ let total_memory =
+ node_status.node_info.C.memory *^ 1024L in
+ let total_memory =
+ max (total_memory -^ 1024L *^ 1024L *^ 1024L) 0L in
+ let free_memory = total_memory -^ used_memory in
+ { node_status = node_status;
+ active_guests = guests;
+ used_memory = used_memory;
+ used_vcpus = used_vcpus;
+ free_memory = free_memory }
+ ) node_statuses
+
+let status ~verbose () =
+ let summary = node_guest_summary ~verbose () in
+
+ List.iter (
+ function
+ | { node_status = { node_on = false;
+ node = { Mclu_conf.hostname = hostname } } } ->
+ printf "%-28s off\n" hostname
+ | { node_status = { node_on = true;
+ node = { Mclu_conf.hostname = hostname };
+ node_info = node_info };
+ active_guests = guests;
+ used_vcpus = used_vcpus;
+ used_memory = used_memory;
+ free_memory = free_memory } ->
+ printf "%-28s on\n" hostname;
+ printf " ";
+ printf "total: %dpcpus %s\n"
+ node_info.C.cpus (human_size (node_info.C.memory *^ 1024L));
+ if guests <> [] then (
+ printf " ";
+ printf "used: %dvcpus %s by %d guest(s)\n"
+ used_vcpus (human_size used_memory) (List.length guests)
+ );
+ printf " ";
+ printf "free: %s\n" (human_size free_memory)
+ ) summary;
+
+ ()
+
+let run ~verbose = function
+ | [] -> status ~verbose ()
+ | _ ->
+ eprintf "mclu status: Too many arguments\n";
+ exit 1
--- /dev/null
+(* mclu: Mini Cloud
+ * Copyright (C) 2014-2015 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.
+ *)
+
+val get_arg_speclist : unit -> (Arg.key * Arg.spec * Arg.doc) list
+
+val run : verbose:bool -> string list -> unit
+
+type node_status = {
+ node : Mclu_conf.node;
+ node_on : bool; (* true = appears to be switched on *)
+ node_info : Libvirt.Connect.node_info;
+}
+
+val node_statuses : ?verbose:bool -> ?nodes:Mclu_conf.node list -> unit -> node_status list
+
+type node_guest_summary = {
+ node_status : node_status;
+ active_guests : Mclu_list.dom_info list;
+ used_memory : int64;
+ used_vcpus : int;
+ free_memory : int64;
+}
+
+val node_guest_summary : ?verbose:bool -> unit -> node_guest_summary list
--- /dev/null
+(* mclu: Mini Cloud
+ * Copyright (C) 2014-2015 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.
+ *)
+
+(* Simple forking parallel primitives. *)
+
+open Printf
+open Unix
+
+let map f xs =
+ let xs = List.map (
+ fun x ->
+ let rfd, wfd = pipe () in
+ (x, rfd, wfd)
+ ) xs in
+
+ let xs = List.map (
+ fun (x, rfd, wfd) ->
+ match fork () with
+ | 0 -> (* child *)
+ close rfd;
+ let y = Printexc.catch f x in
+ (* Write the final value to the pipe. *)
+ output_value (out_channel_of_descr wfd) y;
+ exit 0
+
+ | pid -> (* parent *)
+ close wfd;
+ (pid, rfd)
+ ) xs in
+
+ let errors = ref 0 in
+ let xs = List.map (
+ fun (pid, rfd) ->
+ (* Read all the output from the pipe. *)
+ let buf = Buffer.create 13 in
+ let bytes = Bytes.create 4096 in
+ let rec loop () =
+ let len = read rfd bytes 0 (Bytes.length bytes) in
+ if len > 0 then (
+ Buffer.add_subbytes buf bytes 0 len;
+ loop ()
+ )
+ in
+ loop ();
+ let str = Buffer.to_bytes buf in
+
+ (* Wait for the subprocess. *)
+ match waitpid [] pid with
+ | _, WEXITED 0 -> str
+ | pid, WEXITED i ->
+ eprintf "mclu: subprocess pid %d died with exit status %d\n" pid i;
+ incr errors;
+ Bytes.empty
+ | pid, WSIGNALED i ->
+ eprintf "mclu: subprocess pid %d died with signal %d\n" pid i;
+ incr errors;
+ Bytes.empty
+ | pid, WSTOPPED i ->
+ eprintf "mclu: subprocess pid %d stopped with signal %d\n" pid i;
+ incr errors;
+ Bytes.empty
+ ) xs in
+
+ if !errors > 0 then
+ exit 1;
+
+ xs
+
+let iter f xs = ignore (map f xs)
--- /dev/null
+(* mclu: Mini Cloud
+ * Copyright (C) 2014-2015 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.
+ *)
+
+(** Simple forking parallel primitives. *)
+
+val iter : ('a -> unit) -> 'a list -> unit
+(** [iter f xs] iterates over each member [x] of the list [xs],
+ running [f x] in parallel in a forked subprocess. If [f] throws
+ an exception then the function exits with an error. *)
+
+val map : ('a -> 'b) -> 'a list -> bytes list
+(** [map f xs] maps over each member [x] of the list [xs], running
+ [f x] in parallel in a forked subprocess.
+
+ The list of {b marsalled} values from [f] is returned - you have
+ to unmarshall them (to get back the ['b]) using
+ {!Marshal.from_bytes}.
+
+ If [f] throws an exception, then the function exits with an
+ error. *)
--- /dev/null
+#!/bin/bash -
+# mclu: Mini Cloud
+# Copyright (C) 2014-2015 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.
+
+# Source and build directories (absolute paths so this works from any
+# directory).
+s="$(cd @abs_srcdir@ && pwd)"
+b="$(cd @abs_builddir@ && pwd)"
+
+PATH="$b:$PATH"
+export PATH
+
+if [ -z "$MCLU_PATH" ]; then
+ MCLU_PATH="$s/templates"
+ export MCLU_PATH
+fi
+
+if [ -z "$MCLU_CONFIG" ]; then
+ MCLU_CONFIG="$s/mclu.conf"
+ export MCLU_CONFIG
+fi
+
+if libtool --help >/dev/null 2>&1; then
+ libtool="libtool --mode=execute"
+fi
+
+exec $libtool "$@"
--- /dev/null
+(* mclu: Mini Cloud
+ * Copyright (C) 2014-2015 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.
+ *)
+
+(* Templates. *)
+
+open Utils
+
+open Printf
+
+let template_dir =
+ try Sys.getenv "MCLU_PATH"
+ with Not_found -> Config.pkgdatadir // "templates"
+
+let templates () =
+ let files = Sys.readdir template_dir in
+ let files = Array.to_list files in
+ let files = List.map ((//) template_dir) files in
+ let files =
+ List.filter (fun name -> Filename.check_suffix name ".template") files in
+ List.map (
+ fun filename ->
+ let name = Filename.basename filename in
+ let name = Filename.chop_suffix name ".template" in
+ (name, filename)
+ ) files
+
+let template_names () = List.map fst (templates ())
+
+let run_template ~verbose filename subcmd args =
+ let cmd =
+ sprintf "%s %s %s" (quote filename) (quote subcmd)
+ (String.concat " " (List.map quote args)) in
+ if verbose then printf "%s\n%!" cmd;
+ let chan = Unix.open_process_in cmd in
+ let lines = ref [] in
+ (try while true do lines := input_line chan :: !lines done
+ with End_of_file -> ());
+ let lines = List.rev !lines in
+ let stat = Unix.close_process_in chan in
+ (match stat with
+ | Unix.WEXITED 0 -> Some lines
+ | Unix.WEXITED 2 -> None
+ | Unix.WEXITED i ->
+ eprintf "mclu: template '%s' subcmd '%s' exited with error %d\n"
+ filename subcmd i;
+ exit 1
+ | Unix.WSIGNALED i ->
+ eprintf "mclu: template '%s' subcmd '%s' killed by signal %d\n"
+ filename subcmd i;
+ exit 1
+ | Unix.WSTOPPED i ->
+ eprintf "mclu: template '%s' subcmd '%s' stopped by signal %d\n"
+ filename subcmd i;
+ exit 1
+ )
+
+type template_info = {
+ base_image : string;
+ minimum_memory : int64 option;
+ recommended_memory : int64 option;
+ disk_bus : string option;
+ network_model : string option;
+}
+
+let probe ?(verbose = false) filename =
+ (* Check the template is a template. *)
+ (match run_template ~verbose filename "probe" [] with
+ | Some ["hello"] -> ()
+ | _ ->
+ eprintf "mclu: file %s is not an mclu template\n" filename;
+ exit 1
+ );
+
+ (* Probe for various properties. *)
+ let base_image =
+ match run_template ~verbose filename "base-image" [] with
+ | Some [answer] -> answer
+ | _ ->
+ eprintf "mclu: cannot parse '%s base-image'\n" filename;
+ exit 1 in
+ let minimum_memory =
+ match run_template ~verbose filename "minimum-memory" [] with
+ | Some [memory] ->
+ (try Some (bytes_of_human_size memory)
+ with Not_found ->
+ eprintf "mclu: cannot parse output of '%s minimum-memory'\n"
+ filename;
+ exit 1
+ );
+ | _ -> None in
+ let recommended_memory =
+ match run_template ~verbose filename "recommended-memory" [] with
+ | Some [memory] ->
+ (try Some (bytes_of_human_size memory)
+ with Not_found ->
+ eprintf "mclu: cannot parse output of '%s recommended-memory'\n"
+ filename;
+ exit 1
+ );
+ | _ -> None in
+ let disk_bus =
+ match run_template ~verbose filename "disk-bus" [] with
+ | Some [answer] -> Some answer
+ | _ -> None in
+ let network_model =
+ match run_template ~verbose filename "network-model" [] with
+ | Some [answer] -> Some answer
+ | _ -> None in
+
+ { base_image = base_image;
+ minimum_memory = minimum_memory;
+ recommended_memory = recommended_memory;
+ disk_bus = disk_bus;
+ network_model = network_model }
--- /dev/null
+(* mclu: Mini Cloud
+ * Copyright (C) 2014-2015 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.
+ *)
+
+(** Templates. *)
+
+val templates : unit -> (string * string) list
+(** Get the list of templates as a list of [name, filename]. *)
+
+val template_names : unit -> string list
+(** Get just the list of template names. *)
+
+type template_info = {
+ base_image : string;
+ minimum_memory : int64 option;
+ recommended_memory : int64 option;
+ disk_bus : string option;
+ network_model : string option;
+}
+
+val probe : ?verbose:bool -> string -> template_info
+(** Probe the template (filename) for information. *)
--- /dev/null
+#!/bin/bash -
+
+set -e
+
+case "$1" in
+ probe)
+ echo "hello"
+ ;;
+
+ # Build image.
+ build)
+ virt-builder "$2" --output "$3" --format "$4" \
+ --install fedora-repos-rawhide \
+ --update
+ ;;
+
+ base-image)
+ echo fedora-21
+ ;;
+
+ # Properties.
+ minimum-memory)
+ echo 1G
+ ;;
+ recommended-memory)
+ echo 4G
+ ;;
+ disk-bus)
+ echo virtio-scsi
+ ;;
+ network-model)
+ echo virtio
+ ;;
+
+ *)
+ exit 2
+ ;;
+esac
--- /dev/null
+(* mclu: Mini Cloud
+ * Copyright (C) 2014-2015 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.
+ *)
+
+(* Miscellaneous utility functions. *)
+
+open Scanf
+open Printf
+
+module D = Libvirt.Domain
+
+let (//) = Filename.concat
+let quote = Filename.quote
+
+let ( +^ ) = Int64.add
+let ( -^ ) = Int64.sub
+let ( *^ ) = Int64.mul
+let ( /^ ) = Int64.div
+let ( &^ ) = Int64.logand
+let ( ~^ ) = Int64.lognot
+
+let human_size i =
+ let sign, i = if i < 0L then "-", Int64.neg i else "", i in
+
+ if i < 1024L then
+ sprintf "%s%Ld" sign i
+ else (
+ let f = Int64.to_float i /. 1024. in
+ let i = i /^ 1024L in
+ if i < 1024L then
+ sprintf "%s%.1fK" sign f
+ else (
+ let f = Int64.to_float i /. 1024. in
+ let i = i /^ 1024L in
+ if i < 1024L then
+ sprintf "%s%.1fM" sign f
+ else (
+ let f = Int64.to_float i /. 1024. in
+ (*let i = i /^ 1024L in*)
+ sprintf "%s%.1fG" sign f
+ )
+ )
+ )
+
+let bytes_of_human_size s =
+ try sscanf s "%Ld%[Gg]" (fun b _ -> b *^ 1024L *^ 1024L *^ 1024L)
+ with Scan_failure _ ->
+ try sscanf s "%Ld%[Mm]" (fun b _ -> b *^ 1024L *^ 1024L)
+ with Scan_failure _ ->
+ try sscanf s "%Ld%[Kk]" (fun b _ -> b *^ 1024L)
+ with Scan_failure _ ->
+ try sscanf s "%Ld%[Bb]" (fun b _ -> b)
+ with Scan_failure _ ->
+ raise Not_found
+
+let string_of_dom_state = function
+ | D.InfoNoState -> "unknown"
+ | D.InfoRunning -> "running"
+ | D.InfoBlocked -> "blocked"
+ | D.InfoPaused -> "paused"
+ | D.InfoShutdown -> "shutdown"
+ | D.InfoShutoff -> "shutoff"
+ | D.InfoCrashed -> "crashed"
+
+let regexp_of_glob s =
+ let len = String.length s in
+ let buf = Buffer.create len in
+ Buffer.add_char buf '^';
+ for i = 0 to len-1 do
+ match String.unsafe_get s i with
+ (* Wildcard characters converted to regular expressions. *)
+ | '?' -> Buffer.add_char buf '.'
+ | '*' -> Buffer.add_string buf ".*"
+ (* Must escape any character which is special for PCRE - see
+ * pcrepattern(3). However ignore [..] because they are
+ * (approximately) the same for globs and regexps.
+ *)
+ | ('\\' | '^' | '$' | '.' | '|' | '(' | ')'
+ | '+' | '{') as c ->
+ Buffer.add_char buf '\\'; Buffer.add_char buf c
+ | c -> Buffer.add_char buf c
+ done;
+ Buffer.add_char buf '$';
+ Buffer.contents buf
+
+let string_random8 =
+ let chars = "abcdefghijklmnopqrstuvwxyz0123456789" in
+ fun () ->
+ String.concat "" (
+ List.map (
+ fun _ ->
+ let c = Random.int 36 in
+ let c = chars.[c] in
+ String.make 1 c
+ ) [1;2;3;4;5;6;7;8]
+ )
+
+let name_parse name =
+ let i = try Some (String.index name ':') with Not_found -> None in
+ match i with
+ | None -> None, name
+ | Some i ->
+ Some (String.sub name 0 i),
+ String.sub name (i+1) (String.length name - i - 1)
--- /dev/null
+(* mclu: Mini Cloud
+ * Copyright (C) 2014-2015 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.
+ *)
+
+(** Miscellaneous utility functions. *)
+
+val (//) : string -> string -> string
+val quote : string -> string
+
+val ( +^ ) : int64 -> int64 -> int64
+val ( -^ ) : int64 -> int64 -> int64
+val ( *^ ) : int64 -> int64 -> int64
+val ( /^ ) : int64 -> int64 -> int64
+val ( &^ ) : int64 -> int64 -> int64
+val ( ~^ ) : int64 -> int64
+(** Various int64 operators. *)
+
+val human_size : int64 -> string
+(** Turn a bytes count into a human-readable string (eg. [4.0G]). *)
+
+val bytes_of_human_size : string -> int64
+
+val string_of_dom_state : Libvirt.Domain.state -> string
+
+val regexp_of_glob : string -> string
+(** Convert glob to regular expression. *)
+
+val string_random8 : unit -> string
+
+val name_parse : string -> string option * string
+(** Parse a guest name of either [name] or [node:name] into the parts. *)
git.annexia.org / mclu.git / commitdiff